{-# 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 Data.Hashable
import qualified Data.HashMap.Lazy as H

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.Pretty
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
            } deriving (Eq) 

-- 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] -> ([RuleSet], [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] -> ([RuleSet], [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 = H.HashMap Rule ClassId

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

type RuleCode  = String
data CssNode a = CssNode (CssTag a) [Rule]

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

type CssCode = String

instance Hashable Rule where
    hash (Rule a b c) = hash (a, b, c)

instance Hashable Decl where
    hash = hash . show . pretty

instance Hashable PseudoVal where
    hash = hash . show . pretty

-- class names table
classTable :: [Rule] -> ClassTable
classTable = H.fromList . flip zip ids . nub
    where ids = map (('c' : ). show) [0 ..]  
          phi id (a, b) = (b, (id, a))
 

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

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] -> [Rule]
getCssDecls x = 
    case x of
        [] -> []
        xs -> res xs ++ getCssDecls (children =<< xs)
    where res xs = (catMaybes $ map getCssDeclFromTree xs)

getCssDeclFromTree :: Css a -> Maybe Rule
getCssDeclFromTree x = 
    case x of  
        Style r _ -> Just 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 -> [Rule]
getRuleCode x =
    case x of
        Style r x -> r : getRuleCode x
        _         -> []

-- print ruleSets
ppRuleSets :: ClassTable -> [RuleSet]
ppRuleSets = ((uncurry $ flip toRuleSet) =<< ) 
    . sortOn snd . H.toList


toRuleSet :: String -> Rule -> [RuleSet]
toRuleSet className r = case rulePseudo r of
            [] -> return $ sel $ ruleDecl r
            xs -> [(sel /: ps) ds | (ps, ds) <- xs ]
    where sel = foldl1 (/-) $ (star /. className) 
                : (map ident $ ruleCtx r)


-- print html
ppHtml :: HtmlSpec a -> ClassTable -> TagTree a -> a
ppHtml spec table (TagTree (CssNode tag rules) xs) = 
    setAttrs spec attrs next
    where attrs = map (maybe [] id . flip H.lookup table) 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)