module Feldspar.Core.Show where
import Control.Monad
import Data.List
import Feldspar.Core.Types
import Feldspar.Core.Haskell
import Feldspar.Core.Graph
instance HaskellValue Variable
where
haskellValue (i,path) = "v" ++ intercalate "_" (map show (i:path))
instance HaskellValue Source
where
haskellValue (Constant a) = haskellValue a
haskellValue (Variable v) = haskellValue v
tupPatt :: Tuple StorableType -> NodeId -> Tuple Variable
tupPatt tup i = fmap (\path -> (i,path)) (tuplePath tup)
viewBinOp :: String -> Maybe String
viewBinOp "" = Nothing
viewBinOp op
| length op < 2 = Nothing
| (head op == '(') && (last op == ')') = Just $ tail $ init op
| otherwise = Nothing
showNode :: Node -> [Hierarchy] -> String
showNode (Node i fun inp inType outType) subHiers = showNd fun
where
outp = tupPatt outType i
showNd Input = ""
showNd (Array a) = ((i,[])::Variable) -=- a
showNd (Function fun)
| Just op <- viewBinOp fun = outp -=- opApp op a b
where
Tup [a,b] = inp
showNd (Function fun) = outp -=- fun -$- inp
showNd (NoInline fun iface) =
outp -=- fun -$- inp
`local`
showSF (head subHiers) fun subInp subOutp
where
subInp = tupPatt inType $ interfaceInput iface
subOutp = interfaceOutput iface
showNd (IfThenElse ifaceThen ifaceElse) =
outp -=- ifExpr
`local`
(thenBranch ++ newline ++ elseBranch)
where
Tup [One cond, a] = inp
Tup [_, aType] = inType
[thenHier,elseHier] = subHiers
ifExpr = ifThenElse cond
("thenBranch" -$- a)
("elseBranch" -$- a)
subInpThen = tupPatt aType $ interfaceInput ifaceThen
subInpElse = tupPatt aType $ interfaceInput ifaceElse
subOutpThen = interfaceOutput ifaceThen
subOutpElse = interfaceOutput ifaceElse
thenBranch = showSF thenHier "thenBranch" subInpThen subOutpThen
elseBranch = showSF elseHier "elseBranch" subInpElse subOutpElse
showNd (While ifaceCont ifaceBody) =
outp -=- "while" -$- "cont" -$- "body" -$- inp
`local`
(contBranch ++ newline ++ bodyBranch)
where
[contHier,bodyHier] = subHiers
subInpCont = tupPatt inType $ interfaceInput ifaceCont
subInpBody = tupPatt inType $ interfaceInput ifaceBody
subOutpCont = interfaceOutput ifaceCont
subOutpBody = interfaceOutput ifaceBody
contBranch = showSF contHier "cont" subInpCont subOutpCont
bodyBranch = showSF bodyHier "body" subInpBody subOutpBody
showNd (Parallel szs iface) =
outp -=- "parallel" -$- szs -$- inp -$- "ixf"
`local`
showSF (head subHiers) "ixf" subInp subOutp
where
subInp = tupPatt inType $ interfaceInput iface
subOutp = interfaceOutput iface
showSubFun
:: (HaskellValue inp, HaskellValue outp)
=> Hierarchy
-> String
-> Maybe inp
-> outp
-> String
showSubFun (Hierarchy nodes) name inp outp =
funHead inp -=- outp
`local`
unlinesNoTrail (filter (not.null) $ map (uncurry showNode) nodes)
where
funHead Nothing = name
funHead (Just inp) = name -$- inp
showSF
:: (HaskellValue inp, HaskellValue outp)
=> Hierarchy
-> String
-> inp
-> outp
-> String
showSF hier name inp = showSubFun hier name (Just inp)
showGraph :: String -> Bool -> Graph -> String
showGraph name hasArg graph@(Graph nodes iface) = showSubFun hier name inp' outp
where
hier = graphHierarchy $ makeHierarchical graph
inp = tupPatt (interfaceInputType iface) (interfaceInput iface)
inp' = guard hasArg >> Just inp
outp = interfaceOutput iface