module TextShow.Compiler.Hoopl () where
import Compiler.Hoopl (Label, LabelMap, LabelSet, Pointed(..),
UniqueMap, UniqueSet)
#if MIN_VERSION_hoopl(3,9,0)
import Compiler.Hoopl.Internals (lblToUnique)
#else
import Compiler.Hoopl (Unique)
import Compiler.Hoopl.GHC (lblToUnique, uniqueToInt)
#endif
import Compiler.Hoopl.Passes.Dominator (DominatorNode(..), DominatorTree(..), DPath(..))
import Data.Monoid.Compat
import TextShow (TextShow(..), TextShow1(..),
TextShow2(..), Builder, singleton, showbPrec1)
import TextShow.Data.Containers ()
import TextShow.TH (deriveTextShow, deriveTextShow1)
instance TextShow Label where
showb l = singleton 'L' <> showb (lblToUnique l)
$(deriveTextShow ''LabelMap)
$(deriveTextShow1 ''LabelMap)
$(deriveTextShow ''LabelSet)
instance TextShow a => TextShow (Pointed t b a) where
showbPrec = showbPrec1
instance TextShow1 (Pointed t b) where
liftShowbPrec _ _ _ Bot = "_|_"
liftShowbPrec _ _ _ Top = singleton 'T'
liftShowbPrec sp _ _ (PElem a) = sp 0 a
instance TextShow2 (Pointed t) where
liftShowbPrec2 _ _ = liftShowbPrec
#if !(MIN_VERSION_hoopl(3,9,0))
instance TextShow Unique where
showb = showb . uniqueToInt
#endif
$(deriveTextShow ''UniqueMap)
$(deriveTextShow1 ''UniqueMap)
$(deriveTextShow ''UniqueSet)
instance TextShow DominatorNode where
showb Entry = "entryNode"
showb (Labelled l) = showb l
instance TextShow DominatorTree where
showb t = mconcat $ "digraph {\n" : dot t ["}\n"]
where
dot :: DominatorTree -> [Builder] -> [Builder]
dot (Dominates root trees) =
(dotnode root :) . outedges trees . flip (foldl subtree) trees
where
outedges :: [DominatorTree] -> [Builder] -> [Builder]
outedges [] = id
outedges (Dominates n _ : ts) =
\bs -> " "
: showb root
: " -> "
: showb n
: singleton '\n'
: outedges ts bs
dotnode :: DominatorNode -> Builder
dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n"
dotnode (Labelled l) = " " <> showb l <> singleton '\n'
subtree :: [Builder] -> DominatorTree -> [Builder]
subtree = flip dot
instance TextShow DPath where
showb (DPath ls) = mconcat $ foldr (\l path -> showb l <> " -> " : path)
["entry"]
ls