-- | Abstract syntax tree and pretty-printing for Haskell 98.
-- This is only a small subset of the Haskell 98 syntax,
-- so we do not need to pull in haskell-src and all its complexity.
-- Moreover, haskell-src gives too little control over the format
-- of pretty-printed text output.

module Sifflet.Foreign.Haskell
    (HsPretty(..)
    , Module(..)
    , ExportSpec(..)
    , ImportDecl(..)
    , Decl(..)
    , operatorTable
    )

where

import Data.List (intercalate)
import qualified Data.Map as M

import Sifflet.Language.Expr
import Sifflet.Text.Pretty

class HsPretty a where

    hsPretty :: a -> String

    hsPrettyList :: String -> String -> String -> [a] -> String
    hsPrettyList pre tween post xs =
        pre ++ intercalate tween (map hsPretty xs) ++ post

instance HsPretty Symbol where
    hsPretty = pretty

instance HsPretty Operator where
    hsPretty = pretty

-- | A Haskell module; moduleDecls are functions and variables.

data Module = Module {moduleName :: String
                     , moduleExports :: Maybe ExportSpec
                     , moduleImports :: ImportDecl
                     , moduleDecls :: [Decl]
                     }
            deriving (Eq, Show)

instance HsPretty Module where
    hsPretty m = 
        let pmod = "module " ++ moduleName m
            pexports = case moduleExports m of
                         Nothing -> ""
                         Just exports -> hsPretty exports
            pimports = hsPretty (moduleImports m)
            pdecls = sepLines2 (map hsPretty (moduleDecls m))
        in unlines [pmod ++ " where",
                    pexports,
                    pimports,
                    pdecls]

-- | A Haskell module's export spec: a list of function and 
-- variable identifiers
data ExportSpec = ExportSpec [String]
                  deriving (Eq, Show)

instance HsPretty ExportSpec where
    hsPretty (ExportSpec exports) = 
        "(" ++ sepCommaSp exports ++ ")"

-- | A Haskell modules import decls: a list of module identifiers.
-- No support for "qualified" or "as" or for selecting only some
-- identifiers from the imported modules.

data ImportDecl = ImportDecl [String]
                  deriving (Eq, Show)

instance HsPretty ImportDecl where
    hsPretty (ImportDecl modnames) = 
        let idecl modname = "import " ++ modname
        in unlines (map idecl modnames)

-- | Wrap a string in parentheses
par :: String -> String
par s = "(" ++ s ++ ")"

-- | A Haskell function or variable declaration.
-- An explicit type declaration is optional.
-- Thus we have just enough for 
--    name :: type
--    name [args] = expr.
-- Of course [args] would be empty if it's just a variable.
data Decl = Decl {declIdent :: String
                 , declType :: Maybe [String]
                 , declParams :: [String]
                 , declExpr :: Expr
                 }
          deriving (Eq, Show)

instance HsPretty Decl where
    hsPretty decl =
        let ptypeDecl = "" -- to be improved **
            pparams = case declParams decl of
                        [] -> ""
                        params -> " " ++ sepSpace params
            pbody = hsPretty (declExpr decl)
        in ptypeDecl ++ 
           declIdent decl ++ pparams ++ " =\n" ++
           "    " ++ pbody

-- | HsPretty expressions.  This is going to be like in Python.hs.
instance HsPretty Expr where
    hsPretty pexpr =
        case pexpr of
          EUndefined -> "undefined"
          EChar c -> show c
          ENumber n -> show n
          EBool b -> show b
          EString s -> show s
          ESymbol sym -> hsPretty sym
          EList xs -> hsPrettyList "[" ", " "]" xs
          EIf c a b -> 
              unwords ["if", hsPretty c, "then", hsPretty a, "else", hsPretty b]
          EGroup e -> par (hsPretty e)
          ECall fexpr argExprs -> 
              hsPretty fexpr ++ " " ++ hsPrettyList "" " " "" argExprs
          EOp op left right -> 
              unwords [hsPretty left, hsPretty op, hsPretty right]

-- | The Haskell operators.
-- Now what about the associativity of (:)?
-- It really doesn't even make sense to ask if (:) is
-- associative in the usual sense, 
-- since (x1 : x2) : xs == x1 : (x2 : xs)
-- is not only untrue, but the left-hand side is
-- a type error, except maybe in some very special cases
-- (and then the right-hand side would probably be a type error).
-- Is (:) what is called a "right-associative" operator?
-- And do I need to expand my Operator type to
-- include this?  And then what about (-) and (/)???
-- Does this affect their relationship with (+) and (-)?

operatorTable :: M.Map String Operator
operatorTable = 
    M.fromList (map (\ op -> (opName op, op)) 
                    [ Operator "*" 7 True GroupLtoR -- times
                    , Operator "+" 6 True GroupLtoR -- plus
                    , Operator "-" 6 False GroupLtoR  -- minus
                    , Operator ":" 5 False GroupRtoL  -- cons
                    , Operator "==" 4 False GroupNone -- eq
                    , Operator "/=" 4 False GroupNone -- ne
                    , Operator ">" 4 False GroupNone -- gt
                    , Operator ">=" 4 False GroupNone -- ge
                    , Operator "<" 4 False GroupNone -- lt
                    , Operator "<=" 4 False GroupNone -- le
                    ])