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(..))
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid (mconcat)
#endif
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)