module Debug.Hoed.Pure.Render
(CompStmt(..)
,renderCompStmts
,CDS
,eventsToCDS
,rmEntrySet
,simplifyCDSSet
) where
import Debug.Hoed.Pure.EventForest
import Prelude hiding(lookup)
import Debug.Hoed.Pure.Observe
import Data.List(sort,sortBy,partition,nub
#if __GLASGOW_HASKELL__ >= 710
, sortOn
#endif
)
import Data.Graph.Libgraph
import Data.Array as Array
head' :: String -> [a] -> a
head' msg [] = error msg
head' _ xs = head xs
#if __GLASGOW_HASKELL__ < 710
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f = map snd . sortOn' fst . map (\x -> (f x, x))
sortOn' :: Ord b => (a -> b) -> [a] -> [a]
sortOn' f = sortBy (\x y -> compare (f x) (f y))
#endif
data CompStmt = CompStmt { stmtLabel :: String
, stmtIdentifier :: UID
, stmtRes :: String
}
deriving (Eq, Ord)
instance Show CompStmt where
show = stmtRes
showList eqs eq = unlines (map show eqs) ++ eq
renderCompStmts :: CDSSet -> [CompStmt]
renderCompStmts = foldl (\acc set -> acc ++ renderCompStmt set) []
renderCompStmt :: CDS -> [CompStmt]
renderCompStmt (CDSNamed name threadId dependsOn set uids')
= map mkStmt statements
where statements :: [(String,UID)]
statements = map (\(d,i) -> (pretty 120 d,i)) doc
doc = foldl (\a b -> a ++ renderNamedTop name b) [] output
output = cdssToOutput set
mkStmt :: (String,UID) -> CompStmt
mkStmt (s,i) = CompStmt name i s
renderNamedTop :: String -> Output -> [(DOC,UID)]
renderNamedTop name (OutData cds)
= map (\(args,res,Just i) -> (renderNamedFn name (args,res), i)) pairs
where pairs' = findFn [cds]
pairs = (nub . sortOn argAndRes) pairs'
nub [] = []
nub (a:a':as) | a == a' = nub (a' : as)
nub (a:as) = a : nub as
argAndRes (arg,res,_) = (arg,res)
data CDS = CDSNamed String ThreadId UID CDSSet [UID]
| CDSCons UID String [CDSSet]
| CDSFun UID CDSSet CDSSet
| CDSEntered UID
| CDSTerminated UID
deriving (Show,Eq,Ord)
type CDSSet = [CDS]
eventsToCDS :: [Event] -> CDSSet
eventsToCDS pairs = getChild 0 0
where
frt :: EventForest
frt = mkEventForest pairs
res i = (!) out_arr i
bnds = (0, length pairs)
mid_arr :: Array Int [(Int,CDS)]
mid_arr = accumArray (flip (:)) [] bnds
[ (pnode,(pport,res node))
| (Event node (Parent pnode pport) _) <- pairs
]
out_arr = array bnds
[ (node,getNode'' node e change)
| e@(Event node _ change) <- pairs
]
getNode'' :: Int -> Event -> Change -> CDS
getNode'' node e change =
case change of
(Observe str t i) -> let chd = getChild node 0
in CDSNamed str t (getId chd i) chd (treeUIDs frt e)
(Enter) -> CDSEntered node
(NoEnter) -> CDSTerminated node
Fun -> CDSFun node (getChild node 0) (getChild node 1)
(Cons portc cons)
-> CDSCons node cons
[ getChild node n | n <- [0..(portc1)]]
getId [] i = i
getId ((CDSFun i _ _ ):_) _ = i
getId (_:cs) i = getId cs i
getChild :: Int -> Int -> CDSSet
getChild pnode pport =
[ content
| (pport',content) <- (!) mid_arr pnode
, pport == pport'
]
render :: Int -> Bool -> CDS -> DOC
render prec par (CDSCons _ ":" [cds1,cds2]) =
if (par && not needParen)
then doc
else paren needParen doc
where
doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>
renderSet' 4 True cds2
needParen = prec > 4
render prec par (CDSCons _ "," cdss) | length cdss > 0 =
nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)
(map renderSet cdss) <>
text ")")
render prec par (CDSCons _ name cdss) =
paren (length cdss > 0 && prec /= 0)
(nest 2
(text name <> foldr (<>) nil
[ sep <> renderSet' 10 False cds
| cds <- cdss
]
)
)
renderSet :: CDSSet -> DOC
renderSet = renderSet' 0 False
renderSet' :: Int -> Bool -> CDSSet -> DOC
renderSet' _ _ [] = text "_"
renderSet' prec par [cons@(CDSCons {})] = render prec par cons
renderSet' prec par cdss =
nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>
text ", " <> b)
(map renderFn pairs) <>
line <> text "}")
where
findFn_noUIDs :: CDSSet -> [([CDSSet],CDSSet)]
findFn_noUIDs c = map (\(a,r,_) -> (a,r)) (findFn c)
pairs = nub (sort (findFn_noUIDs cdss))
nub [] = []
nub (a:a':as) | a == a' = nub (a' : as)
nub (a:as) = a : nub as
renderFn :: ([CDSSet],CDSSet) -> DOC
renderFn (args, res)
= grp (nest 3
(text "\\ " <>
foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)
nil
args <> sep <>
text "-> " <> renderSet' 0 False res
)
)
renderNamedFn :: String -> ([CDSSet],CDSSet) -> DOC
renderNamedFn name (args,res)
= grp (nest 3
( text name <> sep
<> foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b) nil args
<> sep <> text "= " <> renderSet' 0 False res
)
)
findFn :: CDSSet -> [([CDSSet],CDSSet, Maybe UID)]
findFn = foldr findFn' []
findFn' (CDSFun i arg res) rest =
case findFn res of
[(args',res',_)] -> (arg : args', res', Just i) : rest
_ -> ([arg], res, Just i) : rest
findFn' other rest = ([],[other], Nothing) : rest
renderTops [] = nil
renderTops tops = line <> foldr (<>) nil (map renderTop tops)
renderTop :: Output -> DOC
renderTop (OutLabel str set extras) =
nest 2 (text ("-- " ++ str) <> line <>
renderSet set
<> renderTops extras) <> line
rmEntry :: CDS -> CDS
rmEntry (CDSNamed str t i set us)= CDSNamed str t i (rmEntrySet set) us
rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets)
rmEntry (CDSFun i a b) = CDSFun i (rmEntrySet a) (rmEntrySet b)
rmEntry (CDSTerminated i) = CDSTerminated i
rmEntry (CDSEntered i) = error "found bad CDSEntered"
rmEntrySet = map rmEntry . filter noEntered
where
noEntered (CDSEntered _) = False
noEntered _ = True
simplifyCDS :: CDS -> CDS
simplifyCDS (CDSNamed str t i set us) = CDSNamed str t i (simplifyCDSSet set) us
simplifyCDS (CDSCons _ "throw"
[[CDSCons _ "ErrorCall" set]]
) = simplifyCDS (CDSCons 0 "error" set)
simplifyCDS cons@(CDSCons i str sets) =
case spotString [cons] of
Just str | not (null str) -> CDSCons 0 (show str) []
_ -> CDSCons 0 str (map simplifyCDSSet sets)
simplifyCDS (CDSFun i a b) = CDSFun i (simplifyCDSSet a) (simplifyCDSSet b)
simplifyCDS (CDSTerminated i) = (CDSCons i "<?>" [])
simplifyCDSSet = map simplifyCDS
spotString :: CDSSet -> Maybe String
spotString [CDSCons _ ":"
[[CDSCons _ str []]
,rest
]
]
= do { ch <- case reads str of
[(ch,"")] -> return ch
_ -> Nothing
; more <- spotString rest
; return (ch : more)
}
spotString [CDSCons _ "[]" []] = return []
spotString other = Nothing
paren :: Bool -> DOC -> DOC
paren False doc = grp (nest 0 doc)
paren True doc = grp (nest 0 (text "(" <> nest 0 doc <> brk <> text ")"))
sp :: DOC
sp = text " "
data Output = OutLabel String CDSSet [Output]
| OutData CDS
deriving (Eq,Ord,Show)
commonOutput :: [Output] -> [Output]
commonOutput = sortBy byLabel
where
byLabel (OutLabel lab _ _) (OutLabel lab' _ _) = compare lab lab'
cdssToOutput :: CDSSet -> [Output]
cdssToOutput = map cdsToOutput
cdsToOutput (CDSNamed name _ _ cdsset _)
= OutLabel name res1 res2
where
res1 = [ cdss | (OutData cdss) <- res ]
res2 = [ out | out@(OutLabel {}) <- res ]
res = cdssToOutput cdsset
cdsToOutput cons@(CDSCons {}) = OutData cons
cdsToOutput fn@(CDSFun {}) = OutData fn
data DOC = NIL
| DOC :<> DOC
| NEST Int DOC
| TEXT String
| LINE
| SEP
| BREAK
| DOC :<|> DOC
deriving (Eq,Show)
data Doc = Nil
| Text Int String Doc
| Line Int Int Doc
deriving (Show,Eq)
mkText :: String -> Doc -> Doc
mkText s d = Text (toplen d + length s) s d
mkLine :: Int -> Doc -> Doc
mkLine i d = Line (toplen d + i) i d
toplen :: Doc -> Int
toplen Nil = 0
toplen (Text w s x) = w
toplen (Line w s x) = 0
nil = NIL
x <> y = x :<> y
nest i x = NEST i x
text s = TEXT s
line = LINE
sep = SEP
brk = BREAK
fold x = grp (brk <> x)
grp :: DOC -> DOC
grp x =
case flatten x of
Just x' -> x' :<|> x
Nothing -> x
flatten :: DOC -> Maybe DOC
flatten NIL = return NIL
flatten (x :<> y) =
do x' <- flatten x
y' <- flatten y
return (x' :<> y')
flatten (NEST i x) =
do x' <- flatten x
return (NEST i x')
flatten (TEXT s) = return (TEXT s)
flatten LINE = Nothing
flatten SEP = return (TEXT " ")
flatten BREAK = return NIL
flatten (x :<|> y) = flatten x
layout :: Doc -> String
layout Nil = ""
layout (Text _ s x) = s ++ layout x
layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x
best w k doc = be w k [(0,doc)]
be :: Int -> Int -> [(Int,DOC)] -> Doc
be w k [] = Nil
be w k ((i,NIL):z) = be w k z
be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z)
be w k ((i,NEST j x):z) = be w k ((k+j,x):z)
be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z
be w k ((i,LINE):z) = i `mkLine` be w i z
be w k ((i,SEP):z) = i `mkLine` be w i z
be w k ((i,BREAK):z) = i `mkLine` be w i z
be w k ((i,x :<|> y):z) = better w k
(be w k ((i,x):z))
(be w k ((i,y):z))
better :: Int -> Int -> Doc -> Doc -> Doc
better w k x y = if (wk) >= toplen x then x else y
pretty :: Int -> DOC -> String
pretty w x = layout (best w 0 x)