{-# LANGUAGE StandaloneDeriving #-}
module SimpleCss( 
        -- * Types
        Css, CssCode, Href, Tag, Pseudo, Context,

        -- * Constructors
        prim, hcat, vcat, acat, div', span', a',
        dot, pseudo, context,

        -- * Render
        HtmlSpec(..), renderCss, toBlaze
) 
where

import Data.List
import Data.Maybe
import Data.Ord
import Data.Function

import qualified Data.Map as M

import qualified Text.Blaze as H
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA 

import Language.Css.Syntax
import Language.Css.Build

-- Types

-- | representing Css data type
--
-- Css's parameter is html type
data Css a = Elem a               -- ^ html element
           | Div  [Css a]         -- ^ div groupping
           | Span [Css a]         -- ^ span groupping
           | A    Href [Css a]    -- ^ clickable group
           | Style Rule (Css a)   -- ^ styling


-- selector :
-- '.'className [tag]* ':'pseudo?

type Href    = String
type Tag     = String
type Context = [Tag]
type Pseudo  = [(PseudoVal, [Decl])]

data Rule = Rule 
            { ruleDecl   :: [Decl] 
            , ruleCtx    :: Context
            , rulePseudo :: Pseudo
            } 

-- Constructors

-- | html element constructor
prim :: a -> Css a
prim = Elem

-- | @div@ groupping
vcat :: [Css a] -> Css a
vcat = Div 

-- | @span@ groupping
hcat :: [Css a] -> Css a
hcat = Span

-- | @a@ groupping
acat :: Href -> [Css a] -> Css a
acat = A


-- | vcat for singleton
div' :: Css a -> Css a
div' = vcat . return

-- | hcat for singleton
span' :: Css a -> Css a
span' = hcat . return

-- | acat for singleton
a' :: Href -> Css a -> Css a
a' href = acat href . return

-- | style 
style :: [Decl] -> Context -> Pseudo -> Css a -> Css a
style ds ctx ps = Style (Rule ds ctx ps) 

-- | set class 
dot :: [Decl] -> Css a -> Css a
dot ds = style ds [] []

-- | set class with pseudo- element/class
pseudo :: Pseudo -> Css a -> Css a
pseudo ps = style [] [] ps

-- | styles descendants
context :: Context -> [Decl] -> Css a -> Css a
context ctx ds = style ds ctx []

-- Render

-- | Html specification
--
-- to render css you should specify html's elements groupping 
-- with @a@, @div@ and @span@ tags 
-- and way to assign values of @class@ attribute
data HtmlSpec a = HtmlSpec 
                 { divTag    :: [a] -> a
                 , spanTag   :: [a] -> a
                 , aTag      :: Href   -> [a] -> a
                 , classAttr :: String -> a -> a
                 }

-- putting it all together

-- | render css
--
-- returns string of css code and list of htmls
renderCss :: HtmlSpec a -> [Css a] -> (CssCode, [a])
renderCss spec xs = 
    (ppRuleSets table, map (ppHtml spec table . tagTree) xs)
    where decls = getCssDecls =<< map return xs 
          table = classTable decls

-- | render css for blaze-html
toBlaze :: [Css H.Html] -> (CssCode, [H.Html])
toBlaze = renderCss blazeSpec

blazeSpec = HtmlSpec
    (blazeTag H.div)
    (blazeTag H.span)
    (\href -> blazeTag (H.a H.! HA.href (H.stringValue href)))
    (\s x -> x H.! HA.class_ (H.stringValue s))

blazeTag tag xs
    | null xs   = tag $ H.string ""
    | otherwise = tag $ foldl1 (>>) xs

-------------------------------------------------------------------------
-- basement

data RuleType = Simple | Link | Visited | Hover | Active
    deriving (Show, Eq, Ord)

type ClassId    = String
type ClassTable = M.Map [RuleCode] (ClassId, [RuleType])

data CssTag a = DivTag | SpanTag | ATag Href | Prim a

type RuleCode  = String
type CssDecl   = [(RuleType, RuleCode)]
data CssNode a = CssNode (CssTag a) [[RuleCode]]

data TagTree a  = TagTree (CssNode a) [TagTree a] 

type CssCode = String

code :: Rule -> [RuleCode]
code r = case rulePseudo r of
            [] -> return $ show $ sel $ ruleDecl r
            xs -> [ show $ (sel /: ps) ds | (ps, ds) <- xs ]
    where sel = foldl1 (/-) $ star : (map ident $ ruleCtx r)


ruleType :: Rule -> [RuleType]
ruleType r = 
    case rulePseudo r of
        [] -> [Simple]
        xs -> map (pseudoType . fst) xs

pseudoType :: PseudoVal -> RuleType
pseudoType x = 
    case x of
        PIdent (Ident "link")    -> Link
        PIdent (Ident "visited") -> Visited
        PIdent (Ident "hover")   -> Hover
        PIdent (Ident "active")  -> Active
        _                        -> Simple

-- declarations
getCssDecls :: [Css a] -> [CssDecl]
getCssDecls x = 
    case x of
        [] -> []
        xs -> res xs ++ getCssDecls (children =<< xs)
    where res xs = (catMaybes $ map getCssDeclFromTree xs)

getCssDeclFromTree :: Css a -> Maybe CssDecl
getCssDeclFromTree x = 
    case x of  
        Style r _ -> Just $ zip (ruleType r) (code r)
        _         -> Nothing


children :: Css a -> [Css a]
children x =
    case x of
        Elem a    -> []
        A _ xs    -> xs
        Div xs    -> xs
        Span xs   -> xs
        Style _ x -> [x]

    
-- tag tree
tagTree :: Css a -> TagTree a
tagTree x = TagTree (CssNode t rc) $ map tagTree xs
    where rc = getRuleCode x
          (t, xs) = getTag x


getTag :: Css a -> (CssTag a, [Css a])
getTag x = 
    case x of
        Elem a     -> (Prim a, [])
        A href xs  -> (ATag href, xs) 
        Div    xs  -> (DivTag, xs)
        Span   xs  -> (SpanTag, xs)
        Style  _ a -> getTag a
        
        
getRuleCode :: Css a -> [[RuleCode]]
getRuleCode x =
    case x of
        Style r x -> code r : getRuleCode x
        _         -> []

-- class names table
classTable :: [CssDecl] -> ClassTable
classTable = M.fromList . zipWith phi ids . nubOn snd . map unzip
    where ids = map (('c' : ). show) [0 ..]  
          phi id (a, b) = (b, (id, a))
 

nubOn  f = nubBy ((==) `on` f)
sortOn f = sortBy (compare `on` f)

-- print ruleSets
ppRuleSets :: ClassTable -> String
ppRuleSets = 
    unlines . map snd . sortOn fst . (shape =<< ) . M.toList
    where shape (names, (id, types)) = zip types $ map (setClass id) names

setClass :: ClassId -> String -> String
setClass id str = ('.' : ) $ id ++ tail str

-- print html
ppHtml :: HtmlSpec a -> ClassTable -> TagTree a -> a
ppHtml spec table (TagTree (CssNode tag rules) xs) = 
    setAttrs spec attrs next
    where attrs = map (fst . (table M.! )) rules
          next  = case tag of
                    Prim a    -> a
                    DivTag    -> divTag  spec next'
                    SpanTag   -> spanTag spec next'
                    ATag href -> aTag    spec href next'
          next' = map (ppHtml spec table) xs

setAttrs :: HtmlSpec a -> [String] -> (a -> a)
setAttrs spec attrs 
    | null attrs = id
    | otherwise  = classAttr spec (unwords attrs)