module TextShow.Compiler.Hoopl (
showbLabel
, showbLabelMapPrecWith
, showbLabelSetPrec
, showbPointedWith
, showbUnique
, showbUniqueMapPrecWith
, showbUniqueSetPrec
, showbDominatorNode
, showbDominatorTree
, showbDPath
) where
import Compiler.Hoopl (Label, LabelMap, LabelSet, Pointed(..),
Unique, UniqueMap, UniqueSet)
#if MIN_VERSION_hoopl(3,9,0)
import Compiler.Hoopl.Internals (lblToUnique)
#else
import Compiler.Hoopl.GHC (lblToUnique, uniqueToInt)
#endif
import Compiler.Hoopl.Passes.Dominator (DominatorNode(..), DominatorTree(..), DPath(..))
import Data.Monoid.Compat
import TextShow (TextShow(showb, showbPrec), TextShow1(..),
TextShow2(..), Builder, singleton)
import TextShow.Data.Containers ()
import TextShow.Data.Integral (showbIntPrec)
import TextShow.TH (deriveTextShow, deriveTextShow1)
#include "inline.h"
showbLabel :: Label -> Builder
showbLabel l = singleton 'L' <> showbUnique (lblToUnique l)
showbLabelMapPrecWith :: (Int -> v -> Builder) -> Int -> LabelMap v -> Builder
showbLabelMapPrecWith = showbPrecWith
showbLabelSetPrec :: Int -> LabelSet -> Builder
showbLabelSetPrec = showbPrec
showbPointedWith :: (a -> Builder) -> Pointed t b a -> Builder
showbPointedWith _ Bot = "_|_"
showbPointedWith _ Top = singleton 'T'
showbPointedWith sp (PElem a) = sp a
showbUnique :: Unique -> Builder
#if MIN_VERSION_hoopl(3,9,0)
showbUnique = showbIntPrec 0
#else
showbUnique = showbIntPrec 0 . uniqueToInt
#endif
showbUniqueMapPrecWith :: (Int -> v -> Builder) -> Int -> UniqueMap v -> Builder
showbUniqueMapPrecWith = showbPrecWith
showbUniqueSetPrec :: Int -> UniqueSet -> Builder
showbUniqueSetPrec = showbPrec
showbDominatorNode :: DominatorNode -> Builder
showbDominatorNode Entry = "entryNode"
showbDominatorNode (Labelled l) = showbLabel l
showbDominatorTree :: DominatorTree -> Builder
showbDominatorTree 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 -> " "
: showbDominatorNode root
: " -> "
: showbDominatorNode n
: singleton '\n'
: outedges ts bs
dotnode :: DominatorNode -> Builder
dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n"
dotnode (Labelled l) = " " <> showbLabel l <> singleton '\n'
subtree :: [Builder] -> DominatorTree -> [Builder]
subtree = flip dot
showbDPath :: DPath -> Builder
showbDPath (DPath ls) = mconcat $ foldr (\l path ->showbLabel l <> " -> " : path)
["entry"]
ls
instance TextShow Label where
showb = showbLabel
INLINE_INST_FUN(showb)
$(deriveTextShow ''LabelMap)
$(deriveTextShow1 ''LabelMap)
$(deriveTextShow ''LabelSet)
instance TextShow a => TextShow (Pointed t b a) where
showbPrec = showbPrecWith showbPrec
INLINE_INST_FUN(showbPrec)
instance TextShow1 (Pointed t b) where
showbPrecWith sp _ = showbPointedWith $ sp 0
INLINE_INST_FUN(showbPrecWith)
instance TextShow2 (Pointed t) where
showbPrecWith2 _ = showbPrecWith
INLINE_INST_FUN(showbPrecWith2)
#if !(MIN_VERSION_hoopl(3,9,0))
instance TextShow Unique where
showb = showbUnique
INLINE_INST_FUN(showb)
#endif
$(deriveTextShow ''UniqueMap)
$(deriveTextShow1 ''UniqueMap)
$(deriveTextShow ''UniqueSet)
instance TextShow DominatorNode where
showb = showbDominatorNode
INLINE_INST_FUN(showb)
instance TextShow DominatorTree where
showb = showbDominatorTree
INLINE_INST_FUN(showb)
instance TextShow DPath where
showb = showbDPath
INLINE_INST_FUN(showb)