-- GRIN-like backend for Yhc Core
-- Pretty-printer for GRIN

module Language.GRIN.Pretty (prettyPrint) where

import Data.Maybe
import Text.PrettyPrint.HughesPJ
import Yhc.Core.GRIN

-- |Pretty-print a GRIN module in Haskell monadic style.

prettyPrint :: GRIN -> String

prettyPrint = render . prGRIN

-- Convert a whole GRIN module to Doc

prGRIN g = vcat (map prFunc (gFuncs g))

prFunc gf = vcat [hang (text (gFuncName gf) <+> 
                        foldr (<+>) empty (map text (gFuncArgs gf)) <+>
                        text "=") 2 (prBlock (gFuncBody gf)), text ""]

-- Convert a block of bindings

prBlock [ex] = prExpr ex

prBlock bl = text "do" <+> nest 2 (vcat (map prExpr bl))

-- Convert an expression

prExpr (GBind se v) = prVal v <+> text "<-" <+> prSexpr se

prExpr (GCase cv pats) = hang (text "case" <+> prVal cv <+> text "of") 2 (vcat (map prPat pats))

prExpr (GSimple se) = prSexpr se

prExpr (GNop) = text "NOP"

prExpr (GError err) = hang (text "*ERROR*") 2 
  (vcat $ [text "<<<<<<"] ++ map text (lines err) ++ [text ">>>>>>"])

-- Convert a value

prVal (GVal sv) = prSval sv

prVal (GTagged n vs) = lparen <> text n <+> hsep (map prSval vs) <> rparen

prVal (GTag n) = text n

prVal (GEmpty) = lparen <> rparen

-- Convert a simple expression

prSexpr (GEval n) = text "eval" <+> text n

prSexpr (GApply f v) = text "apply" <+> text f <+> prVal v

prSexpr (GUnit uv) = text "return" <+> prVal uv

prSexpr (GCall fn vs) = text fn <+> hsep (map prVal vs)

prSexpr (GStore v) = text "store" <+> prVal v

prSexpr (GFetch n "" mbi) = text "fetch" <+> text n <+> int (fromMaybe 0 mbi)

prSexpr (GFetch n t mbi) = text "fetch" <+> text n <+> text ("{-" ++ t ++ "-}") <+> 
                           int (fromMaybe 0 mbi)

prSexpr (GUpdate n v) = text "update" <+> text n <+> prVal v

prSexpr (GInline bl) = nest 2 (prBlock bl)

-- Convert a simple value

prSval (GVar n) = text n

prSval (GLitVal x) = prLit x

-- These three really should not occur in the pretty print

prSval  GTInteger  = text "<integer>"
prSval  GTInt      = text "<int>"
prSval  GTChar     = text "<char>"
prSval  GTFloat    = text "<float>"
prSval  GTDouble   = text "<double>"
prSval  GTAny      = text "<any>"

-- Convert a case pattern

prPat (GPatTag n, bl) = hang (text n <+> text "->") 2 (prBlock bl)

prPat (GPatLit x, bl) = hang (prLit x <+> text "->") 2 (prBlock bl)

prPat (GPatDefault, bl) = hang (text "_" <+> text "->") 2 (prBlock bl)

-- Convert a literal

prLit (GInt i) = lparen <> int i <+> text ":: Int" <> rparen

prLit (GInteger i) = lparen <> integer i <+> text ":: Integer" <> rparen

prLit (GFloat d) = lparen <> float d <+> text ":: Float" <> rparen

prLit (GDouble d) = lparen <> double d <+> text ":: Double" <> rparen

prLit (GChar c) = text (show c)