{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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 Prelude ()
import Prelude.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)
{-# INLINE showb #-}
$(deriveTextShow ''LabelMap)
$(deriveTextShow1 ''LabelMap)
$(deriveTextShow ''LabelSet)
instance TextShow a => TextShow (Pointed t b a) where
showbPrec = showbPrec1
{-# INLINE showbPrec #-}
instance TextShow1 (Pointed t b) where
liftShowbPrec _ _ _ Bot = "_|_"
liftShowbPrec _ _ _ Top = singleton 'T'
liftShowbPrec sp _ _ (PElem a) = sp 0 a
{-# INLINE liftShowbPrec #-}
instance TextShow2 (Pointed t) where
liftShowbPrec2 _ _ = liftShowbPrec
{-# INLINE liftShowbPrec2 #-}
#if !(MIN_VERSION_hoopl(3,9,0))
instance TextShow Unique where
showb = showb . uniqueToInt
{-# INLINE showb #-}
#endif
$(deriveTextShow ''UniqueMap)
$(deriveTextShow1 ''UniqueMap)
$(deriveTextShow ''UniqueSet)
instance TextShow DominatorNode where
showb Entry = "entryNode"
showb (Labelled l) = showb l
{-# INLINE showb #-}
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
{-# INLINE showb #-}