pinealservo-com/css/layout.hs

375 lines
9.3 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
import Clay hiding (div)
import Clay.Stylesheet
import Data.Monoid ((<>))
import Data.Text (pack)
import Prelude hiding ((**))
import qualified Data.List as L
data CalcSize = Px Integer
| Pt Double
| Em Double
| Rem Double
| Ex Double
| Zero
deriving (Eq, Ord)
instance Num CalcSize where
fromInteger i | j == 0 = Zero
| j < 0 = Zero
| otherwise = Px j
where j = fromIntegral i
Zero + b = b
a + Zero = a
Px a + Px b = Px $ a + b
Pt a + Pt b = Pt $ a + b
Em a + Em b = Em $ a + b
Rem a + Rem b = Rem $ a + b
Ex a + Ex b = Ex $ a + b
_ + _ = error "Can't add sizes of different kinds"
Zero * b = b
a * Zero = a
Px a * Px b = Px $ a * b
Pt a * Pt b = Pt $ a * b
Em a * Em b = Em $ a * b
Rem a * Rem b = Rem $ a * b
Ex a * Ex b = Ex $ a * b
_ * _ = error "Can't multiply sizes of different kinds"
abs Zero = Zero
abs (Px i) = Px $ abs i
abs (Pt d) = Pt $ abs d
abs (Em d) = Em $ abs d
abs (Rem d) = Rem $ abs d
abs (Ex d) = Ex $ abs d
signum Zero = Zero
signum (Px i) = Px $ signum i
signum (Pt d) = Pt $ signum d
signum (Em d) = Em $ signum d
signum (Rem d) = Rem $ signum d
signum (Ex d) = Ex $ signum d
times :: Integer -> CalcSize -> CalcSize
i `times` Zero = Zero
i `times` Px b = Px $ i * b
i `times` Pt b = Pt $ (fromIntegral i) * b
i `times` Em b = Em $ (fromIntegral i) * b
i `times` Rem b = Rem $ (fromIntegral i) * b
i `times` Ex b = Ex $ (fromIntegral i) * b
toSize :: CalcSize -> Size Abs
toSize s = case s of
Zero -> nil
Px i -> px i
Pt d -> pt d
Em d -> em d
Rem d -> em d -- todo: Add rem to Clay.Size
Ex d -> ex d
perct :: CalcSize -> CalcSize -> Double
perct Zero b = 0
perct a Zero = error "Division by zero"
perct (Px a) (Px b) = (fromIntegral a) / (fromIntegral b) * 100
perct (Pt a) (Pt b) = a / b * 100
perct (Em a) (Em b) = a / b * 100
perct (Rem a) (Rem b) = a / b * 100
perct (Ex a) (Ex b) = a / b * 100
perct _ _ = error "Can't take percentage of different kinds"
percentage :: CalcSize -> CalcSize -> Size Rel
percentage a b = pct $ perct a b
data LayoutSettings =
Layout { totalColumns :: Integer
, columnWidth :: CalcSize
, gutterWidth :: CalcSize
, gridPadding :: CalcSize
}
data ColSpec = Full
| Next Integer Integer
| Final Integer Integer
columnsWidth cols =
let gutter = gutterWidth def
colWidth = columnWidth def
baseWidth = cols `times` colWidth
in
if cols >= 1
then baseWidth + ((cols - 1) `times` gutter)
else baseWidth
relativeWidth width ctx =
percentage width (columnsWidth ctx)
widthWithGridPadding cols =
let width = columnsWidth cols
basePad = gridPadding def
in width + (2 `times` basePad)
container =
let pad = gridPadding def
width = widthWithGridPadding $ totalColumns def
in do
maxWidth $ toSize width
paddingLeft $ toSize pad
paddingRight $ toSize pad
marginLeft auto
marginRight auto
colSpan spec = case spec of
Full -> do
clear both
Next n m ->
let gutter = gutterWidth def
colsWidth = columnsWidth n
rw = relativeWidth colsWidth m
rm = percentage gutter (columnsWidth m)
in do
width rw
float floatLeft
marginRight rm
Final n m ->
let colsWidth = columnsWidth n
rw = relativeWidth colsWidth m
in do
width rw
float floatRight
marginRight nil
push spec = case spec of
Next n m ->
let gutter = gutterWidth def
colsWidth = columnsWidth n
rw = relativeWidth colsWidth m
in do
marginLeft rw
_ -> error "Bad push spec"
pull spec = case spec of
Next n m ->
let gutter = gutterWidth def
colsWidth = columnsWidth n
rw = relativeWidth colsWidth m
in do
marginLeft (0 - rw)
_ -> error "Bad pull spec"
data GridShow = Pad | Col | Gut
showGrid =
let begin = "-moz-linear-gradient(left center, "
gutColor = " transparent "
padColor = " transparent "
colColor = " rgba(255, 254, 251, 0.5) "
totalWidth = widthWithGridPadding $ totalColumns def
padWidth = perct (gridPadding def) totalWidth
colWidth = perct (columnWidth def) totalWidth
gutWidth = perct (gutterWidth def) totalWidth
colCount = fromIntegral (totalColumns def)
cols = Pad : L.intersperse Gut (replicate colCount Col)
go xs out s = case xs of
[] -> begin ++ out ++ padColor ++ (show s) ++ "%, " ++ padColor ++ "100%)"
Pad:xs ->
let n = padWidth + s
v = padColor ++ (show s) ++ "%, " ++ padColor ++ (show n) ++ "% ,"
in go xs (out ++ v) n
Col:xs ->
let n = colWidth + s
v = colColor ++ (show s) ++ "%, " ++ colColor ++ (show n) ++ "% ,"
in go xs (out ++ v) n
Gut:xs ->
let n = gutWidth + s
v = gutColor ++ (show s) ++ "%, " ++ gutColor ++ (show n) ++ "% ,"
in go xs (out ++ v) n
in pack $ go cols "" 0
showBaseline n = do
backgroundSize $ (px 40) `by` (px n)
backgroundImage $ repeatingLinearGradient (angular $ deg 0) [("#111", px 0)
,("#111", px 1)
,(transparent, px 1)
,(transparent, px n)]
height (pct 100)
width (pct 100)
opacity 0.75
position absolute
top nil
left nil
zIndex (-4)
defaultFontPx = 16
pxRatio x y = (fromIntegral x) / (fromIntegral y)
emFromRatio elemPx fontPx = em $ pxRatio elemPx fontPx
selectors :: [Selector] -> Selector
selectors = foldl1 (<>)
setFontSize x = do
let line = 1 + x `div` baselinePx
fontSize $ emFromRatio x defaultFontPx
lineHeight $ emFromRatio (line * baselinePx) x
{- Insert this into main for layout-debugging grids
body ? (showBaseline baselinePx)
"#container" ? do
container
backgroundColor "#EEE8D5"
"background-image" -: showGrid
-}
-----------------------------------------------------------------------------
-- Syntax Highlighting via highlighting-kate
scKeyword, scDataType, scDecimal, scBaseN, scFloat, scChar, scString :: Selector
scComment, scOther, scAlert, scFunction, scRegion, scError :: Selector
scKeyword = ".kw"
scDataType = ".dt"
scDecimal = ".dv"
scBaseN = ".bn"
scFloat = ".fl"
scChar = ".ch"
scString = ".st"
scComment = ".co"
scOther = ".ot"
scAlert = ".al"
scFunction = ".fu"
scRegion = ".re"
scError = ".er"
syntaxHighlight = pre # ".sourceCode" ? do
backgroundColor "#F9F9F9"
borderLeft solid (px 3) accent2
scKeyword <> scDataType ? color "#268BD2"
scDecimal <> scBaseN <> scFloat ? color "#D33682"
scChar ? color "#DC322F"
scString ? color "#2AA198"
scComment ? color "#93A1A1"
scOther ? color "#A57800"
scFunction ? color "#268BD2"
scError ? do color "#D30102"
fontWeight bold
scAlert ? do color "#CB4B16"
fontWeight bold
-----------------------------------------------------------------------------
def =
Layout { totalColumns = 12
, columnWidth = Em 3
, gutterWidth = Em 1
, gridPadding = Em 1
}
primary = "#033E6B"
accent1 = "#FFB400"
accent2 = "#A63F00"
bodyCopyColor = "#444"
baselinePx = 24
baseFontPx = 16
headingColor = primary
main = putCss $ do
typography
syntaxHighlight
"#container" ? do
container
"#header" ? do
push $ Next 1 12
colSpan $ Next 11 12
"#navigation" ? (colSpan $ Final 2 12)
"#content" ? do
push $ Next 1 12
colSpan $ Next 9 12
"#footer" ? do
push $ Next 1 12
colSpan $ Next 11 12
typography = do
-- Reset the padding/margin on all elements so we can set up a vertical
-- rhythm on a baseline grid
star ? do
sym margin nil
sym padding nil
body ? do
fontFamily ["PT Sans", "Verdana"] [sansSerif]
textRendering optimizeLegibility
color bodyCopyColor
a ? color primary
lineHeight $ emFromRatio baselinePx defaultFontPx
"#logo" ? do
paddingTop $ px (1*baselinePx)
a ? do
setFontSize 75
fontFamily ["Orbitron"] [sansSerif]
fontWeight (other "700")
textDecoration none
color headingColor
ul |> li ? do
paddingLeft $ em (-0.7)
textIndent $ indent (em (-0.7))
":before" & do
content $ stringContent "- "
color accent2
a ? do
textDecoration none
"#navigation" ** li ? do
setFontSize 24
fontFamily ["Oswald"] [sansSerif]
fontWeight (other "400")
".info" ? do
color accent2
"#footer" ** p ? do
color accent2
selectors [ p, ".info", "#logo", pre ] ? do
setFontSize baseFontPx
marginBottom $ px baselinePx
selectors [ h1, h2, h3] ? do
fontFamily ["Oswald"] [sansSerif]
fontWeight (other "400")
color headingColor
h1 ? do
setFontSize 42
let btw = 3
ptw = 6
paddingTop $ px ptw
borderTop solid (px btw) accent1
marginBottom $ px (baselinePx - btw - ptw)
h2 ? do
setFontSize 32
marginBottom $ px baselinePx
h3 ? do
setFontSize 24
ul <> ol ? do
marginLeft $ emFromRatio baselinePx baseFontPx
marginBottom $ px baselinePx
"list-style-type" -: "none"