module Grin.HtmlAnnotate where
import Text.PrettyPrint
import qualified Text.XHtml
import Text.XHtml hiding (text,blue,white,align)
import qualified Data.Map as Map
import CompactString
import Grin.Types
annotate :: Map.Map Renamed Html -> Grin -> String
annotate annotations grin
= h "html" $ h "body" $ h "pre" $ show (ppGrin grin)
where h t s = "<"++t++">"++s++""++t++">"
(<$$>) = ($$)
vsep = vcat
pretty v = text (read (show v))
type QualMap = Map.Map CompactString Bool
grinQualMap :: Grin -> QualMap
grinQualMap grin
= Map.unionsWith (\_ _ -> True) [nodeMap, funcMap, argsMap]
where nodeMap = Map.fromListWith (\_ _ -> True) [ (name, False) | NodeDef{nodeName = Aliased _ name} <- grinNodes grin ]
funcMap = Map.fromListWith (\_ _ -> True) [ (name, False) | FuncDef{funcDefName = Aliased _ name} <- grinFunctions grin ]
argsMap = Map.fromListWith (\_ _ -> True) [ (name, False) | func <- grinFunctions grin, Aliased _ name <- funcDefArgs func ]
ppGrin :: Grin -> Doc
ppGrin grin
= text "Nodes:" <$$>
vsep (map (ppNodeDef qualMap) (grinNodes grin)) <$$>
(text "CAFs:") <$$>
vsep (map (ppCAF qualMap) (grinCAFs grin)) <$$>
(text "Functions:") <$$>
vsep (map (ppFuncDef qualMap) (grinFunctions grin))
where qualMap = grinQualMap grin
ppNodeDef :: QualMap -> NodeDef -> Doc
ppNodeDef qual (NodeDef name nodeType args)
= text "node" <+> ppNodeType setAnchor qual nodeType 0 name <+> hsep (map ppType args)
ppType PtrType = (text "*")
ppType WordType = (text "#")
ppNodeType def qual ConstructorNode 0 name = char 'C' <> ppRenamed def qual name
ppNodeType def qual ConstructorNode n name = char 'P' <> int n <> ppRenamed def qual name
ppNodeType def qual FunctionNode 0 name = char 'F' <> ppRenamed def qual name
ppNodeType def qual FunctionNode n name = char 'P' <> int n <> ppRenamed def qual name
ppRenamed def qual (Aliased n var) -- = pretty var <> if Map.findWithDefault False var qual then char '_' <> int n else empty
= def n (read (show var))
ppRenamed def qual (Anonymous n)
= def n ('x':show n)
ppRenamed def qual (Builtin p) = char '@' <> pretty p
ppRenamed def qual (External e) = parens (text "foreign" <+> text e)
ppCAF :: QualMap -> CAF -> Doc
ppCAF qual (CAF name value)
= ppRenamed setAnchor qual name <+> equals <+> ppValue linkToAnchor qual value
ppFuncDef :: QualMap -> FuncDef -> Doc
ppFuncDef qual (FuncDef name args body)
= hang (hsep (ppRenamed setAnchor qual name : map (ppRenamed setAnchor qual) args) <+> equals) 2
((ppBeginExpression qual body))
ppBeginExpression :: QualMap -> Expression -> Doc
ppBeginExpression qual e@(_ :>>= _)
= (text "do" <+> ppExpression qual e)
ppBeginExpression qual e = ppExpression qual e
ppExpression :: QualMap -> Expression -> Doc
ppExpression qual (Unit value) = text "unit" <+> ppValue linkToAnchor qual value
ppExpression qual (Case value alts)
= hang (text "case" <+> ppValue linkToAnchor qual (Variable value) <+> text "of") 2
(vsep (map (ppAlt qual) alts))
ppExpression qual (Application fn args)
= hsep (ppRenamed linkToAnchor qual fn:map (ppRenamed linkToAnchor qual) args)
ppExpression qual (Store v)
= text "store" <+> ppValue linkToAnchor qual v
ppExpression qual (a :>> c)
= ppExpression qual a <$$>
ppExpression qual c
ppExpression qual (a :>>= b :-> c)
= (ppValue setAnchor qual (Variable b) <+> text "<-" <+> (ppBeginExpression qual a)) <$$>
ppExpression qual c
ppAlt qual (value :> exp) = hang (ppValue setAnchor qual value) 2
(text "->" <+> (ppBeginExpression qual exp))
ppValue def qual (Node name nodeType missing args)
= parens (hsep (ppNodeType linkToAnchor qual nodeType missing name : map (ppRenamed def qual) args))
ppValue def qual (Vector vs) = brackets (hsep (map (ppRenamed def qual) vs))
ppValue def qual (Hole size) = parens (text "@hole" <+> hsep (replicate size (char '_')))
ppValue def qual Empty = text "()"
ppValue def qual (Lit lit) = ppLit lit
ppValue def qual (Variable variable) = ppRenamed def qual variable
ppLit (Lint i) = integer i
ppLit (Lrational r) = text (show r)
ppLit (Lchar char) = text (show char)
ppLit (Lstring string) = text (show string)
linkToAnchor ident var
= zeroWidthText ("") <> text var <> zeroWidthText ""
setAnchor ident var
= zeroWidthText ("") <> text var <> zeroWidthText ""