> 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