{-# LANGUAGE MultiParamTypeClasses #-}

module Text.BluePrintCSS.Base (
    render,
    section,
    Layout(..),
    AsSection(..),
    AsMargin(..),
    AsCssClass(..),
    makeCssClass,
    Tag(..),
    Align(..),
    hsectionA,
    hsection,
    vsectionA,
    vsection,
    equalA,
    equal,
    greaterA,
    greater,
    floatA,
    float
    ) where 

import Control.Monad
import Control.Monad.Writer
import Data.Maybe ()
import Data.Either ()
import Data.List

-- | User can specify fixed of `greater than` width of section.
-- Width is measured in blueprint css units (see official manual)
data Layout = LEQ Int | LGE Int 
    deriving (Eq,Show)

(.|.) :: Layout -> Layout -> Layout
LEQ m .|. LEQ n = LEQ (m+n)
LGE m .|. LGE n = LGE (m+n)
LEQ m .|. LGE n = LGE (m+n)
LGE n .|. LEQ m = LGE (m+n)

(.||.) :: [Layout] -> [Layout] -> [Layout]
(.||.) = zipWith (.|.)

hsum :: [Layout] -> Layout
hsum = foldr (.|.) (LEQ 0)

(./.) :: Layout -> Layout -> Layout
LEQ m ./. LEQ n = LEQ (m `max` n)
LGE m ./. LGE n = LGE (m `max` n)
LEQ m ./. LGE n = LGE (m `max` n) --undefined
LGE n ./. LEQ m = LGE (m `max` n) --undefined

vsum :: [Layout] -> Layout
vsum = foldr (./.) (LEQ 0)

lmax :: Layout -> Layout -> Layout
LGE x `lmax` LGE y = LGE (x`max`y)
LEQ x `lmax` LGE y | y<=x = LEQ x
LEQ x `lmax` LGE _ | otherwise = LEQ x --undefined
LGE y `lmax` LEQ x | y<=x = LEQ x
LGE _ `lmax` LEQ x | otherwise = LEQ x --undefined
LEQ x `lmax` LEQ y = LEQ (x`min`y) --undefined

llmax :: [Layout] -> [Layout] -> [Layout]
llmax = zipWith lmax

fits :: Layout -> Int -> Bool
(LEQ x) `fits` y = x == y
(LGE x) `fits` y = x < y

classify :: [Layout] -> ([Int],[Int])
classify = foldr classify' ([],[])
    where classify' (LEQ w) (fx, dn) = (w:fx, dn) 
          classify' (LGE w) (fx, dn) = (fx, w:dn) 

(.++.) :: [Int] -> [Int] -> [Int]
(.++.) = zipWith (+)

class AsCssClass x where
    asCssClass :: x -> [String]

makeCssClass :: (AsCssClass x) => x -> Int -> Bool -> [String]
makeCssClass attrs w l =
    let cspan = ["span-" ++ show(w)] in
    let clast = if l then ["last"] else [] in
    cspan ++ (asCssClass attrs) ++ clast

split :: Int -> Int -> [Int]
split x parts 
    | x < parts = (replicate x 1) ++ (replicate (parts-x) 0)
    | otherwise = 
        let (quot', rem') = (x`div`parts, x`mod`parts) in
        (replicate parts quot') .++. (split rem' parts)

distribute :: Int -> [Layout] -> [Int]
distribute w attrs@(_:_) =
    let (fixed,floated) = classify attrs in
    let (sfx,sfl) = (sum fixed, sum floated) in
    let free = w - sfl - sfx in
    let float' = floated .++. split free (length floated) in
    fst $ foldr fn ([],(reverse fixed, reverse float')) attrs
    where
        fn (LEQ _) (res, (f:fx, fl)) = (f:res, (fx, fl)) 
        fn (LEQ _) (_, ([], _)) = undefined
        fn (LGE _) (res, (fx, f:fl)) = (f:res, (fx, fl)) 
        fn (LGE _) (_, (_, [])) = undefined
distribute _ [] = []

class AsMargin x where
    smargin :: x -> Int

data Align = HSet | VSet
    deriving(Show)

-- | Tuple represents individual section of blueprint document.
-- First argument is Layout (width constraint)
-- Second argument is a set of attributes (typically list of 'Attr')
-- Third argument is a section itself.
type Tuple a d = (Layout, a, Tag a d)

-- | Defines Html section tree from blueprint's point of view.
data Tag a d = Tag Align [Tuple a d] | Content d
    deriving(Show)

mark :: (AsMargin a, AsSection a d) => Tag a d -> (Tag a d, Layout)
mark (Tag align tagpairs) = 
    let (ls, attrs, tags) = unzip3 tagpairs
        (tags', ls') = unzip $ map mark tags
        ls'' = (ls `llmax` ls') .||. (map (LEQ . smargin) attrs)
        xsum HSet = hsum ; xsum VSet = vsum
    in (Tag align (zip3 ls'' attrs tags'), xsum align ls'')

mark (Content x) = (Content x, LGE 0)

class AsSection a d where
    asSection :: a -> Int -> Bool -> [d] -> d
    asRootSection :: a -> [d] -> d

render' :: (AsMargin a, AsSection a d) => Int -> Tag a d -> [d]
render' cw (Tag HSet tagpairs) = 
    let (ls, attrs, tags) = unzip3 tagpairs in
    let ws = distribute cw ls in
    execWriter $ do
        forM_ (zip4 tags attrs ws [1..]) $ \(tag, attr, w, i) -> do
            let w' = w - smargin attr
            let c = render' w' tag
            tell $ [asSection attr w' (i==(length ws)) c]

render' w (Tag VSet tagpairs) = 
    execWriter $ do
        forM_ (tagpairs) $ \(_,attr,tag) -> do
            let w' = w - smargin attr
            let c = render' w' tag
            tell $ [asSection attr w' True c]

render' _ (Content content) = [content]
 
-- | The most important function. Renders structure into solid html.
-- First argument is total width of your css grid (see blueprintcss manual).
-- Typical value is 24.
-- Second argument is the document skeleton as returned by one of *section functions.
-- Use it like this (HSX html generator is assumed):
--
-- > render 24 $ vsection [ 
-- >   float $ <h1> The header </h1>,
-- >   floatA [Box "Error"] $ <p>Password incorrect</p>,
-- >   hsection [ 
-- >     equal 3 $ <div> Column of width 3 </div>,
-- >     float   $ <div> Column of width (max - 3) </div>
-- >   ] 
-- > ]
--
render :: (AsMargin a, AsSection a d) => Int -> Tuple a d -> Either String d
render w (_,a,t) = 
    let (tree, l) = mark t in
    case l `fits` w of
        True -> Right $ asRootSection a $ render' w tree
        False -> Left $ "It is impossible to fit layout " ++ show(l) ++ " into " ++ show(w) ++ " box"

section :: a -> b -> c-> (a,b,c)
section = (,,)

-- | Starts horisontally aligned sectionlist
hsection :: (Monoid a) => [Tuple a d] -> Tuple a d
hsection = hsectionA mempty

-- | Starts vertically aligned section
vsection :: (Monoid a) => [Tuple a d] -> Tuple a d
vsection = vsectionA mempty

-- | Defines html content of fixed width.
-- First argument is a width allowed for this content (in blueprintcss units, see manual).
-- Second argument - html data type
equal :: (Monoid a) => Int -> d -> Tuple a d
equal = equalA mempty

-- | Defines html content with width in range [arg1 .. max).
-- First argument is a minimal width allowed (in blueprintcss units, see manual).
-- Second argument - html data type
greater :: (Monoid a) => Int -> d -> Tuple a d
greater = greaterA mempty

-- | Defines html content with any width (same as 'greater' with arg1 = 0) 
float :: (Monoid a) => d -> Tuple a d
float = floatA mempty

-- | Attributed version of hsection.
-- First argument is a attribute list which allows to tweak `class` of html tag.
-- Standard blueprint library contains a set of pre-defined classes like
-- `error`, `notify`, `box`, `append-`, `prepend-`.
-- Some of them, like `pull-` and `push-` are not supported.
-- See 'Attr' for details.
hsectionA :: a -> [Tuple a d] -> Tuple a d
hsectionA attrs = section (LGE 0) attrs . Tag HSet 

-- | Attributed version of 'vsection'
vsectionA :: a -> [Tuple a d] -> Tuple a d
vsectionA attrs = section (LGE 0) attrs . Tag VSet 

-- | Attributed version of 'equal'
equalA :: a -> Int -> d -> Tuple a d
equalA attrs x = section (LEQ x) attrs . Content

-- | Attributed version of 'greater'
greaterA :: a -> Int -> d -> Tuple a d
greaterA attrs x = section (LGE x) attrs . Content

-- | Attributed version of 'float'
floatA :: a -> d -> Tuple a d
floatA attrs = greaterA attrs 0