AST.hs

module AST where

type Name = String

data Op = Plus | Mult | IntEq | IntLess

data LS = Lazy | Strict deriving Eq

data E
  = Var Name
  | App E E
  | Abs [P] E
  | Let [D] E
  | Case E [(P,B,[D])]
  | TupleExp [E]
  | Const Integer
  | ConApp Name [(E,LS)]
  | NewApp Name E
  | Boom
  | Undefined
--- Above is the "core", below various extras
  | Bin Op E E
  | Cond E E E
  | Tconst 
  | Fconst

-- Declarations
data D = Fun Name [([P],B,[D])] | Val P B [D]

-- Bodies
data B = Guarded [(E,E)] | Normal E

--- Nested Patterns
data P = Pconst Integer
       | Pvar Name
       | Ptuple [P]
       | Pcondata Name [P]  
       | Pnewdata Name P
       | Ptilde P



showB :: B -> String
showB (Normal e) = showE e
showB (Guarded ps) = foldr f "\n" ps
   where f (e1,e2) ans = "| "++(showE e1) ++ " = " ++(showE e2)++ ans

showD :: D -> String
showD (Val p body ds) =  " " ++ showP p ++ "=" ++ (showB body) ++ "\n" ++
                         "   where " ++ (showDs ds)
showD (Fun nm xs) = foldr (++) "" (map f xs)
   where f (ps,body,ds) = 
           nm ++ " " ++(showPs ps) ++ " = " ++(showB body) ++ "\n" ++
           "   where " ++ (showDs ds)
   

showDs dcls = foldr (++) "" (map showD dcls)


showOp :: Op -> String
showOp Plus = "+"
showOp Mult = "*"
showOp IntEq = "=="
showOp IntLess = "<"

showP (Pconst i) = show i
showP (Pvar n) = n
showP (Pcondata n ns) = 
                "(" ++ n ++ " " ++ 
                (foldr (\ s t -> if t/="" then (showP s) ++ "," ++ t
                                     else (showP s)) 
                        "" ns)
                ++ ")"
showP (Pnewdata n x) = "(" ++ n ++ " " ++ (showP x) ++ ")"              
showP (Ptilde p) = "~" ++ (showP p)

showPs [] = ""
showPs (p:ps) = (showP p)++" "++(showPs ps)

showE :: E -> String
showE (Const i) = show i
showE Tconst = "True"
showE Fconst = "False"
showE (Var nm) = nm
showE (Abs p d) = "(\\" ++ (foldr (++) " " (map showP p)) ++ " -> " ++ showE d ++ ")"
showE (App d d') = "(" ++ showE d ++ " " ++ showE d' ++ ")"
showE (Let dcls d) = "let " ++ 
                          foldr (++) "" (map showD dcls)
                            ++ 
                        " in " ++ showE d
showE (ConApp n l) =  "(" ++ n ++ " " ++  
                (foldr (\ (s,ls) t -> 
                            let sa = if (ls == Strict) then "!" else "" 
                            in
                                 if t/="" then sa ++ (showE s) ++ "," ++ t
                                     else sa ++ (showE s)) 
                        "" l)
                      ++ ")"
showE (NewApp n x) = "(" ++ n ++ " " ++  (showE x) ++ ")"                     
showE (Bin op d d') = "(" ++ showE d ++ " " ++ showOp op ++ " " ++ 
                               showE d' ++ ")"
showE Tconst = "true"
showE Fconst = "false"
showE (Case e ms) =
      "(case " ++ showE e ++ " of " ++ 
           (foldr (++) "" (map (\ alt -> "[" ++ (showAlt alt) ++ "]") ms)) ++ ")"
   where showAlt (p,b,ds) = show p ++ " -> " ++ show b ++ "\n" ++ showDs ds


instance Show E where
  show = showE

instance Show P where
  show = showP

instance Show B where
  show = showB