{-# LANGUAGE OverloadedStrings #-}
module GraphGen
( programToDataflowDot
) where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import Syntax
programToDataflowDot :: Program -> Text
programToDataflowDot :: Program -> Text
programToDataflowDot (Program [Decl]
decls) =
Text
"digraph Dataflow {\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" node [shape=record, fontname=\"Courier\"];\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat ((Integer -> Decl -> Text) -> [Integer] -> [Decl] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Integer
i Decl
d -> Text -> Decl -> Text
declToDFDot (Text
"f" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show Integer
i)) Decl
d) [Integer
0..] [Decl]
decls)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}\n"
declToDFDot :: Text -> Decl -> Text
declToDFDot :: Text -> Decl -> Text
declToDFDot Text
name (FunDecl String
_ [String]
params Expr
body) =
Text -> Text -> Text
node (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_inctag") Text
"inctag"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
[Text] -> Text
T.concat
[ Text -> Text -> Text
node Text
inN (Text
"in:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
p)
| String
p <- [String]
params
, let inN :: Text
inN = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_in_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
p
]
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text -> Expr -> Text
exprToDFDot Text
name Expr
body
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
let out :: Text
out = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out" in
Text -> Text -> Text
node (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_retsnd") Text
"retsnd"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge Text
out (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_retsnd")
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_ret") Text
"ret"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_retsnd") (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_ret")
exprToDFDot :: Text -> Expr -> Text
exprToDFDot :: Text -> Expr -> Text
exprToDFDot Text
prefix Expr
expr =
case Expr
expr of
Var String
x ->
let out :: Text
out = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out" in
Text -> Text -> Text
node Text
out (Text
"var:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
x)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_in_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
x) Text
out
Lit Literal
lit ->
let out :: Text
out = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out" in
Text -> Text -> Text
node Text
out (Text
"const:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Literal -> Text
litToText Literal
lit)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge Text
prefix Text
out
Lambda [String]
_ps Expr
e ->
Text -> Text -> Text
node Text
prefix Text
"super"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_tagop") Text
"tagop"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge Text
prefix (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_tagop")
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Expr -> Text
exprToDFDot (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_body") Expr
e
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_body_out") Text
prefix
If Expr
c Expr
t Expr
e ->
let cp :: Text
cp = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_c"
tp :: Text
tp = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_t"
ep :: Text
ep = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_e"
st :: Text
st = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_steer"
mg :: Text
mg = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_merge"
in Text -> Expr -> Text
exprToDFDot Text
cp Expr
c
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node Text
st Text
"steer"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
cp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
st
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Expr -> Text
exprToDFDot Text
tp Expr
t
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
tp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
mg
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Expr -> Text
exprToDFDot Text
ep Expr
e
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
ep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
mg
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node Text
mg Text
"merge"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge Text
st Text
mg
App Expr
f Expr
x ->
let tag :: Text
tag = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_inctag"
cg :: Text
cg = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_cg"
fp :: Text
fp = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_f"
xp :: Text
xp = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_x"
in Text -> Text -> Text
node Text
tag Text
"inctag"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Expr -> Text
exprToDFDot Text
fp Expr
f
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Expr -> Text
exprToDFDot Text
xp Expr
x
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node Text
cg Text
"callgroup"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge Text
tag Text
cg
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node (Text
cg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_snd1") Text
"callsnd"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") (Text
cg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_snd1")
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
cg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_snd1") Text
cg
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node (Text
cg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_snd2") Text
"callsnd"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
xp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") (Text
cg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_snd2")
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
cg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_snd2") Text
cg
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node (Text
cg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_retsnd") Text
"retsnd"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge Text
cg (Text
cg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_retsnd")
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
"tagop"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
cg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_retsnd") (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out")
BinOp BinOperator
op Expr
l Expr
r ->
let lp :: Text
lp = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_l"
rp :: Text
rp = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_r"
out :: Text
out = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out"
in Text -> Expr -> Text
exprToDFDot Text
lp Expr
l
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Expr -> Text
exprToDFDot Text
rp Expr
r
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node Text
out (BinOperator -> Text
binOpToInstr BinOperator
op)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
lp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
out
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
rp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
out
UnOp UnOperator
op Expr
v ->
let vp :: Text
vp = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_v"
out :: Text
out = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out"
in Text -> Expr -> Text
exprToDFDot Text
vp Expr
v
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node Text
out (UnOperator -> Text
unOpToInstr UnOperator
op)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
vp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
out
Let [Decl]
ds Expr
e ->
let lets :: Text
lets = [Text] -> Text
T.concat
[ Text -> Decl -> Text
declToDFDot (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_let" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i)) Decl
d
| (Int
i,Decl
d) <- [Int] -> [Decl] -> [(Int, Decl)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0::Int ..] [Decl]
ds
]
inN :: Text
inN = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_in"
in Text
lets
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Expr -> Text
exprToDFDot Text
inN Expr
e
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
inN Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
prefix
List [Expr]
xs ->
let names :: [Text]
names = [ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_e" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i) | Int
i <- [Int
0..[Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
xsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]
out :: Text
out = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out"
in [Text] -> Text
T.concat ((Text -> Expr -> Text) -> [Text] -> [Expr] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Expr -> Text
exprToDFDot [Text]
names [Expr]
xs)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node Text
out Text
"split"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat [ Text -> Text -> Text
edge (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
out | Text
n <- [Text]
names ]
Tuple [Expr]
xs ->
let names :: [Text]
names = [ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_e" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i) | Int
i <- [Int
0..[Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
xsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]
out :: Text
out = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out"
in [Text] -> Text
T.concat ((Text -> Expr -> Text) -> [Text] -> [Expr] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Expr -> Text
exprToDFDot [Text]
names [Expr]
xs)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node Text
out Text
"split"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat [ Text -> Text -> Text
edge (Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
out | Text
n <- [Text]
names ]
Case Expr
s [(Pattern, Expr)]
alts ->
let sp :: Text
sp = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_scrut"
scrut :: Text
scrut = Text -> Expr -> Text
exprToDFDot Text
sp Expr
s
brs :: Text
brs = [Text] -> Text
T.concat
[ let bd :: Text
bd = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_bd" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show Integer
i)
st :: Text
st = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_steer" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show Integer
i)
in Text -> Expr -> Text
exprToDFDot Text
bd Expr
bdExpr
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
node Text
st Text
"steer"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
sp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
st
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
edge (Text
bd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out") Text
st
| (Integer
i,(Pattern
_, Expr
bdExpr)) <- [Integer] -> [(Pattern, Expr)] -> [(Integer, (Pattern, Expr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [(Pattern, Expr)]
alts
]
in Text
scrut Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
brs
where
outName :: Text
outName = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_out"
litToText :: Literal -> Text
litToText :: Literal -> Text
litToText Literal
lit =
case Literal
lit of
LInt Int
n -> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)
LFloat Double
f -> String -> Text
T.pack (Double -> String
forall a. Show a => a -> String
show Double
f)
LChar Char
c -> Char -> Text
T.singleton Char
c
LString String
s -> Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
LBool Bool
b -> if Bool
b then Text
"true" else Text
"false"
binOpToInstr :: BinOperator -> Text
binOpToInstr :: BinOperator -> Text
binOpToInstr BinOperator
op =
case BinOperator
op of
BinOperator
Add -> Text
"add"
BinOperator
Sub -> Text
"sub"
BinOperator
Mul -> Text
"mul"
BinOperator
Mod -> Text
"mod"
BinOperator
Div -> Text
"div"
BinOperator
Eq -> Text
"eq"
BinOperator
Neq -> Text
"neq"
BinOperator
Lt -> Text
"lt"
BinOperator
Le -> Text
"leq"
BinOperator
Gt -> Text
"gt"
BinOperator
Ge -> Text
"geq"
BinOperator
And -> Text
"and"
BinOperator
Or -> Text
"or"
unOpToInstr :: UnOperator -> Text
unOpToInstr :: UnOperator -> Text
unOpToInstr UnOperator
op =
case UnOperator
op of
UnOperator
Neg -> Text
"subi"
UnOperator
Not -> Text
"not"
escape :: Text -> Text
escape :: Text -> Text
escape = (Char -> Text) -> Text -> Text
T.concatMap ((Char -> Text) -> Text -> Text) -> (Char -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ \Char
c ->
case Char
c of
Char
'"' -> Text
"\\\""
Char
'\\' -> Text
"\\\\"
Char
x -> Char -> Text
T.singleton Char
x
node :: Text -> Text -> Text
node :: Text -> Text -> Text
node Text
n Text
l = Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [label=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escape Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"];\n"
edge :: Text -> Text -> Text
edge :: Text -> Text -> Text
edge Text
a Text
b = Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";\n"