module Feldspar.Core.Show where
import Control.Monad
import Data.List
import Feldspar.Utils
import Feldspar.Haskell
import Feldspar.Core.Types
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
sizeComment :: Tuple StorableType -> String
sizeComment typ = case size of
"" -> ""
_ -> " -- Size: " ++ size
where
size = showTuple (fmap showStorableSize typ)
showNode :: Bool -> Node -> [Hierarchy] -> String
showNode _ (Node i Input inp inType outType) subHiers = ""
showNode showSize (Node i fun inp inType outType) subHiers
| showSize = appendFirstLine (sizeComment outType) (showNd fun)
| otherwise = showNd fun
where
outp = tupPatt outType i
showSF' = showSF showSize
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 iface) =
outp -=- "parallel" -$- inp -$- "ixf"
`local`
showSF' (head subHiers) "ixf" subInp subOutp
where
subInp = tupPatt inType $ interfaceInput iface
subOutp = interfaceOutput iface
showSubFun
:: (HaskellValue inp, HaskellValue outp)
=> Bool
-> Hierarchy
-> String
-> Maybe inp
-> outp
-> String
showSubFun showSize (Hierarchy nodes) name inp outp =
funHead inp -=- outp
`local`
unlinesNoTrail (filter (not.null) $ map (uncurry (showNode showSize)) nodes)
where
funHead Nothing = name
funHead (Just inp) = name -$- inp
showSF
:: (HaskellValue inp, HaskellValue outp)
=> Bool
-> Hierarchy
-> String
-> inp
-> outp
-> String
showSF showSize hier name inp = showSubFun showSize hier name (Just inp)
showGraph :: Bool -> String -> Bool -> Graph -> String
showGraph showSize name hasArg graph@(Graph nodes iface) =
showSubFun showSize hier name inp' outp
where
hier = graphHierarchy $ makeHierarchical graph
inp = tupPatt (interfaceInputType iface) (interfaceInput iface)
inp' = guard hasArg >> Just inp
outp = interfaceOutput iface