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
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 (partsx) 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)
type Tuple a d = (Layout, a, Tag a d)
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]
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 = (,,)
hsection :: (Monoid a) => [Tuple a d] -> Tuple a d
hsection = hsectionA mempty
vsection :: (Monoid a) => [Tuple a d] -> Tuple a d
vsection = vsectionA mempty
equal :: (Monoid a) => Int -> d -> Tuple a d
equal = equalA mempty
greater :: (Monoid a) => Int -> d -> Tuple a d
greater = greaterA mempty
float :: (Monoid a) => d -> Tuple a d
float = floatA mempty
hsectionA :: a -> [Tuple a d] -> Tuple a d
hsectionA attrs = section (LGE 0) attrs . Tag HSet
vsectionA :: a -> [Tuple a d] -> Tuple a d
vsectionA attrs = section (LGE 0) attrs . Tag VSet
equalA :: a -> Int -> d -> Tuple a d
equalA attrs x = section (LEQ x) attrs . Content
greaterA :: a -> Int -> d -> Tuple a d
greaterA attrs x = section (LGE x) attrs . Content
floatA :: a -> d -> Tuple a d
floatA attrs = greaterA attrs 0