Commit 1d8597c7 authored by Tomislav Pree's avatar Tomislav Pree
Browse files

Merge branch 'debug' of https://gitlab.rlp.net/plmz/sturdy into debug

parents ba531861 b975af58
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
......@@ -22,6 +23,14 @@ class (Arrow c, Profunctor c) => ArrowControlFlow stmt c | c -> stmt where
-- For example, @(nextStatement -< e1; nextStatement -< e2)@ adds an CFG edge between @e1@ and @e2@.
nextStatement :: c x y -> c (Maybe stmt, x) y
class (Arrow c, Profunctor c) => ArrowCFG graph c | c -> graph where
-- | Get the current control flow graph of the program.
getCFG :: c () graph
default getCFG :: (c ~ t c', ArrowTrans t, ArrowCFG graph c') => c () graph
getCFG = lift' getCFG
{-# INLINE getCFG #-}
-- | Records the trace of the abstract interpreter as an control-flow graph.
recordControlFlowGraph :: ArrowControlFlow stmt c => (a -> stmt) -> FixpointCombinator c a b
recordControlFlowGraph getStatement f = proc a -> nextStatement f -< (Just (getStatement a),a)
......@@ -53,3 +62,6 @@ instance (Applicative f, ArrowControlFlow stmt c) => ArrowControlFlow stmt (Stat
instance (Monoid w, ArrowControlFlow stmt c) => ArrowControlFlow stmt (WriterT w c) where
nextStatement f = lift (nextStatement (unlift f))
{-# INLINE nextStatement #-}
instance ArrowCFG graph c => ArrowCFG graph (ConstT r c)
instance ArrowCFG graph c => ArrowCFG graph (ReaderT r c)
......@@ -186,6 +186,7 @@ parseSExpr val = case val of
LT.List (Atom "string-append": args) -> opvar_ StringAppend (map parseSExpr args)
LT.List (Atom "list": args) -> list (map parseSExpr args)
LT.List [Atom "error", LT.String err] -> error_ err
LT.List [Atom "breakpoint", e] -> breakpoint (parseSExpr e)
LT.List (Atom x: args) -> app (var_ (pack x)) (map parseSExpr args)
LT.List (fun: args) -> app (parseSExpr fun) (map parseSExpr args)
......
......@@ -137,6 +137,7 @@ data Expr
| Op2 Op2 Expr Expr Label
| OpVar OpVar [Expr] Label
| Error String Label
| Breakpoint Expr -- breakpoint z
deriving (Generic,NFData)
instance ToJSON Expr
......@@ -186,6 +187,8 @@ opvar_ :: OpVar -> [LExpr] -> LExpr
opvar_ operation es = OpVar operation <$> sequence es <*> fresh
error_ :: String -> LExpr
error_ err = Error err <$> fresh
breakpoint :: LExpr -> LExpr
breakpoint e = Breakpoint <$> e
instance Show Literal where show = show . pretty
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment