> module Doc2Html where
> import Control.Monad ( join )
> import Data.List ( intersperse )
> -- import HsColour

> import HTMLEnt

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

My modules

> import ListToTree
> import Doc
> import GroupSquash ( groupSquash )

> import XHTML

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

 > elems2string ps = concat (intersperse "\n" (map htmlEntityEncode (extractStrings ps)))

> elems2string ps = concat (intersperse "\n" (extractStrings ps))

> doc2xml :: Document -> [XML]
> doc2xml d = map topsToXML d

> topsToXML :: TopElem -> XML
> topsToXML (Par es) = pp $ elemsToXMLs es
> topsToXML (RawBeg c i es) = error$ "Unsupported special paragraph: "++show c
> topsToXML (SpecPar Comment ps) = comment $ extractStrings ps
> topsToXML (SpecPar Pre     ps) = "pre" `around` [txt $ htmlEntityEncode $ elems2string ps]
> topsToXML (SpecPar Code    ps) = elm "pre" ["class"-->"code"] [txt $ tail $ '\n':elems2string ps]

> topsToXML (SpecPar Head4   ps) = h1 $ concat $ intersperse [br] (map elemsToXMLs ps)
> topsToXML (SpecPar Head3   ps) = h2 $ concat $ intersperse [br] (map elemsToXMLs ps)
> topsToXML (SpecPar Head2   ps) = h3 $ concat $ intersperse [br] (map elemsToXMLs ps)
> topsToXML (SpecPar Head1   ps) = h4 $ concat $ intersperse [br] (map elemsToXMLs ps)
> topsToXML (SpecPar BQuote  ps) = ulNone $ map (li . elemsToXMLs) ps

> topsToXML (TreePar special (Tree _ treelist)) = head $ subtreeToXML 0 special treelist
> topsToXML x = error$ "Some unknown TopElem: " ++ show x ++"\n\n"

> subtreeToXML _ _              []       = []
> subtreeToXML l special@NList  treelist = [ol l $ map (li . (treeToXMLs l special)) treelist]
> subtreeToXML l special@BList  treelist = [ul $ map (li . (treeToXMLs l special)) treelist]
> subtreeToXML l special@SList  treelist = [ulNone $ map (li . (singleton . bb) . (treeToXMLs l special)) treelist]
> subtreeToXML l special@Poetry treelist = [ulNone $ map (li . (treeToXMLs l special)) treelist]

> treeToXMLs l special (Tree a treelist) = elemsToXMLs a ++ subtreeToXML (l+1) special treelist

> singleton x = [x]
> li     = around "li"
> olLoop = [ around "ol"
>          , elm "ol" ["style"-->"list-style-type: upper-alpha;"]
>          , elm "ol" ["style"-->"list-style-type: upper-roman;"]
>          , elm "ol" ["style"-->"list-style-type: lower-alpha;"]
>          , elm "ol" ["style"-->"list-style-type: lower-roman;"] ]
> ol l   = olLoop !! (l `mod` (length olLoop))
> ul     = around "ul"
> ulNone = elm "ul" ["style"-->"list-style-type: none; list-style-image: none;"]

> extractStrings ps = map (getStrings "") ps
>   where getStrings acc []             = acc
>         getStrings acc ((Txt s):rest) = getStrings (acc++s) rest
>         getStrings acc (_:rest)       = getStrings acc rest

 > xflatnl :: Elems -> [XML]
 > xflatnl es = [txt "nothing"]

> elemsToXMLs :: Elems -> [XML]
> elemsToXMLs = map elemToXML

> elemToXML (Txt t) = txt $ t    -- htmlEntityEncode t
> elemToXML (Ent x) = case length x of
>                       1 -> txt $ htmlEntityEncode x
>                       _ -> txt $ "&"++x++";"   -- single chars are self
> elemToXML (Ital es) = ii $ elemsToXMLs es
> elemToXML (Bold es) = bb $ elemsToXMLs es

> -- TODO Variable Interpolation: this should generate an error OR an
> -- empty string for normal use because it should have been replaced
> -- by now.  Maybe literally printing it is a good thing because then
> -- the author knows where variables failed to be expanded ... but
> -- this is not where a lookup occurs, so this point should never
> -- really be reached.

> elemToXML (VarInt ((Txt keyname):_)) = hole $ keyname
> elemToXML (VarInt es) = tt $ [txt "<<"] ++ elemsToXMLs es ++ [txt ">>"]

 > elemToXML (VarInt es) | isNothing val = tt $ [txt "<<"] ++ key ++ [txt ">>"]
 >                       | otherwise = val
 >     where xml = lookup key env
 >           key = elemsToXMLs es

> -- TODO This gets flattened, but it should either do something different or cause an error, right?
> elemToXML (RawLnk es) = tt $ elemsToXMLs es

> elemToXML (TT es) = tt $ elemsToXMLs es
> elemToXML (Fnote n es) = lnk showN [sup $ [txt showN]] where showN = show n

Deal with the different shaped UrlElem, Img, and Lnk elements and do
the best thing possible with the given amount of information.

> elemToXML (UrlElem url) = let (Url p u) = url
>                               pu = p++u in aa pu pu
> elemToXML (Img (Url _ i) targ a) =
>     let altt = case a of Nothing -> []
>                          Just s  -> ["alt"-->s] in
>     case targ of Nothing -> imgWith $ altt++["src"-->i]
>                  Just (Url p u) -> lnk pu [imgWith $ altt ++ ["src"-->i]]
>                                      where pu = p++u

> -- TODO use strip on elemsToXMLs es
> elemToXML (Lnk (Url p u) es) = lnk pu $ elemsToXMLs es where pu = p++u