pinealservo-com/css/layout.hs

{-# 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"

  blockquote ? do
	backgroundColor "#F9F9F9"
	borderLeft solid (px 3) accent1
	paddingLeft (em 1)