-- 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