-- Copyright (c) 2009-2010, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
-- * Redistributions of source code must retain the above copyright notice,
-- this list of conditions and the following disclaimer.
-- * Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in the
-- documentation and/or other materials provided with the distribution.
-- * Neither the name of the ERICSSON AB nor the names of its contributors
-- may be used to endorse or promote products derived from this software
-- without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- | Defines a function 'showGraph' for showing core language graphs as Haskell
-- code.
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
-- | Creates a tuple pattern of the given type, for the output of the given
-- node.
tupPatt :: Tuple StorableType -> NodeId -> Tuple Variable
tupPatt tup i = fmap (\path -> (i,path)) (tuplePath tup)
-- | Matches the string against @\"(...)\"@, and returns @Just ...@ if possible,
-- otherwise @Nothing@.
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)
-- | Shows a single node.
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 showSize hier name inp outp@:
--
-- Shows a sub-function named @name@ represented by the hierarchy @hier@. If
-- @inp@ is @Nothing@, it will be shown as a definition without an argument.
-- @showSize@ decides whether or not to show size comments.
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 showSize hier name inp = showSubFun showSize hier name (Just inp)@
showSF
:: (HaskellValue inp, HaskellValue outp)
=> Bool
-> Hierarchy
-> String
-> inp
-> outp
-> String
showSF showSize hier name inp = showSubFun showSize hier name (Just inp)
-- | Shows a graph. The given string is the name of the top-level function. The
-- Boolean tells whether the graph has a real or a dummy argument. A graphs with
-- that has a dummy argument will be shown as a definition without an argument.
-- Of course, this assumes that a dummy argument is not used within the graph.
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