module Text.Show.Text.Compiler.Hoopl (
showbLabel
, showbLabelMapPrec
, showbLabelSetPrec
, showbPointed
, showbUnique
, showbUniqueMapPrec
, 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 Prelude hiding (Show)
import Text.Show.Text (Show(showb, showbPrec), Show1(showbPrec1), Builder)
import Text.Show.Text.Data.Containers ()
import Text.Show.Text.Data.Integral (showbIntPrec)
import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowbPrec)
import Text.Show.Text.Utils (s)
#include "inline.h"
showbLabel :: Label -> Builder
showbLabel l = s 'L' <> showbUnique (lblToUnique l)
showbLabelMapPrec :: Show v => Int -> LabelMap v -> Builder
showbLabelMapPrec = showbPrec
showbLabelSetPrec :: Int -> LabelSet -> Builder
showbLabelSetPrec = showbPrec
showbPointed :: Show a => Pointed t b a -> Builder
showbPointed Bot = "_|_"
showbPointed Top = s 'T'
showbPointed (PElem a) = showb a
showbUnique :: Unique -> Builder
#if MIN_VERSION_hoopl(3,9,0)
showbUnique = showbIntPrec 0
#else
showbUnique = showbIntPrec 0 . uniqueToInt
#endif
showbUniqueMapPrec :: Show v => Int -> UniqueMap v -> Builder
showbUniqueMapPrec = showbPrec
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
: s '\n'
: outedges ts bs
dotnode :: DominatorNode -> Builder
dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n"
dotnode (Labelled l) = " " <> showbLabel l <> s '\n'
subtree :: [Builder] -> DominatorTree -> [Builder]
subtree = flip dot
showbDPath :: DPath -> Builder
showbDPath (DPath ls) = mconcat $ foldr (\l path ->showbLabel l <> " -> " : path)
["entry"]
ls
instance Show Label where
showb = showbLabel
INLINE_INST_FUN(showb)
$(deriveShowPragmas defaultInlineShowbPrec ''LabelMap)
instance Show1 LabelMap where
showbPrec1 = showbPrec
INLINE_INST_FUN(showbPrec1)
$(deriveShowPragmas defaultInlineShowbPrec ''LabelSet)
instance Show a => Show (Pointed t b a) where
showb = showbPointed
INLINE_INST_FUN(showb)
instance Show1 (Pointed t b) where
showbPrec1 = showbPrec
INLINE_INST_FUN(showbPrec1)
#if !(MIN_VERSION_hoopl(3,9,0))
instance Show Unique where
showb = showbUnique
INLINE_INST_FUN(showb)
#endif
$(deriveShowPragmas defaultInlineShowbPrec ''UniqueMap)
instance Show1 UniqueMap where
showbPrec1 = showbPrec
INLINE_INST_FUN(showbPrec1)
$(deriveShowPragmas defaultInlineShowbPrec ''UniqueSet)
instance Show DominatorNode where
showb = showbDominatorNode
INLINE_INST_FUN(showb)
instance Show DominatorTree where
showb = showbDominatorTree
INLINE_INST_FUN(showb)
instance Show DPath where
showb = showbDPath
INLINE_INST_FUN(showb)