--
-- file:    Expr.lhs
--
-- created: 3/12/96 by Andrew Rock.
--
-- purpose: This defines the type Expr to store an expression as a tree
--          and functions to pretty print and parse expressions.
--

> module Expr (Expr (Undef, Const, Name, Func1, Func2, Lambda, Chunk, If,
>                    List, (:+:), (:-:), (:*:), (:/:), (:%:), (:$:),
>                    (:<:), (:<=:), (:>:), (:>=:), (:==:), (:/=:),
>                    (:&&:), (:||:)),
>              Elist ((:#:), LEmpty, DotDot),
>              EFunc1 (Negate, Not, Head, Tail, Abs, Signum),
>              EFunc2 (Div, Mod),
>              EConst (Int, Bool),
>              int, bool, true, false, empty, (#::), dotdot,
>              exprP, nameP, showExpr, makeFunction) where

> import Parser


============================================
The internal representation of an expression
============================================

> data Expr
>    =   Undef
>      | Const EConst
>      | Name String
>      | Expr :+: Expr
>      | Expr :-: Expr
>      | Expr :*: Expr
>      | Expr :/: Expr
>      | Expr :%: Expr
>      | Lambda String Expr
>      | Expr :$: Expr
>      | Expr :<: Expr
>      | Expr :<=: Expr
>      | Expr :>: Expr
>      | Expr :>=: Expr
>      | Expr :==: Expr
>      | Expr :/=: Expr
>      | Expr :||: Expr
>      | Expr :&&: Expr
>      | If Expr Expr Expr
>      | List Elist
>      | Func1 EFunc1
>      | Func2 EFunc2
>      | Chunk Expr
>      deriving (Eq, Ord)

> data EConst
>    =   Int Integer
>      | Bool Bool
>      deriving (Eq, Ord)

> data Elist
>    =   LEmpty
>      | Expr :#: Expr
>      | DotDot Expr Expr Expr -- [e1, e2 .. e3]
>      deriving (Eq, Ord)

> data EFunc1
>    =   Negate
>      | Not
>      | Head
>      | Tail
>      | Abs
>      | Signum
>      deriving (Eq, Ord)

> data EFunc2
>    =   Div
>      | Mod
>      deriving (Eq, Ord)


========================
Shorthand "Constructors"
========================

> int :: Integer -> Expr
> int i = Const (Int i)

> bool :: Bool -> Expr
> bool p = Const (Bool p)

> true :: Expr
> true = bool True

> false :: Expr
> false = bool False

> empty :: Expr
> empty = List LEmpty

> (#::) :: Expr -> Expr -> Expr
> e1 #:: e2 = List (e1 :#: e2)

> dotdot :: Expr -> Expr -> Expr -> Expr
> dotdot e1 e2 e3 = List (DotDot e1 e2 e3)


=============================
Pretty printing an expression
=============================

showExpr e returns the textual representation of expression e.

> showExpr :: Expr -> String
> showExpr e
>    = case e of
>         Undef            -> "Undefined"
>         Name n           -> n
>         Const c          -> showEConst c
>         List xs          -> showEList (List xs)
>         Func1 f          -> showEFunc1 f
>         Func2 f          -> showEFunc2 f
>         e1 :$: e2        -> showBinaryLeft "" 10 e1 e2
>         e1 :*: e2        -> showBinaryLeft "* " 7 e1 e2
>         e1 :/: e2        -> showBinaryLeft "`div` " 7 e1 e2
>         e1 :%: e2        -> showBinaryLeft "`mod` " 7 e1 e2
>         e1 :+: e2        -> showBinaryLeft "+ " 6 e1 e2
>         e1 :-: e2        -> showBinaryLeft "- " 6 e1 e2
>         e1 :<: e2        -> showBinaryLeft "< " 4 e1 e2
>         e1 :<=: e2       -> showBinaryLeft "<= " 4 e1 e2
>         e1 :>: e2        -> showBinaryLeft "> " 4 e1 e2
>         e1 :>=: e2       -> showBinaryLeft ">= " 4 e1 e2
>         e1 :==: e2       -> showBinaryLeft "== " 4 e1 e2
>         e1 :/=: e2       -> showBinaryLeft "/= " 4 e1 e2
>         e1 :&&: e2       -> showBinaryLeft "&& " 3 e1 e2
>         e1 :||: e2       -> showBinaryLeft "|| " 2 e1 e2
>         If e1 e2 e3      -> showIf e1 e2 e3
>         Lambda p e       -> "\\" ++ showLambda p e
>         Chunk e          -> showExpr e


The following functions deal with the cases above.

> showEConst :: EConst -> String
> showEConst c 
>    = case c of
>         Int i  -> show i
>         Bool p -> show p


> showEFunc1 :: EFunc1 -> String
> showEFunc1 f 
>    = case f of
>         Negate -> "negate"
>         Not    -> "not"
>         Head   -> "head"
>         Tail   -> "tail"
>         Abs    -> "abs"
>         Signum -> "signum"


> showEFunc2 :: EFunc2 -> String
> showEFunc2 f 
>    = case f of
>         Div -> "div"
>         Mod -> "mod"


> showEList :: Expr -> String
> showEList (List xs)
>    = case xs of
>         LEmpty          -> "[]"
>         e1 :#: e2       ->
>            if isNiceList e2
>               then '[' : niceList (List (e1 :#: e2))
>               else showBinaryRight ": " 5 e1 e2
>         DotDot e1 e2 e3 -> 
>            "[" ++ showExpr e1 ++ ", " ++ showExpr e2 ++ " .. "
>            ++ showExpr e3 ++ "]"
>      where
>      niceList (List (e1 :#: (List LEmpty)))
>         = showExpr e1 ++ "]"
>      niceList (List (e1 :#: e2))
>         = showExpr e1 ++ ", " ++ niceList e2


> showIf :: Expr -> Expr -> Expr -> String
> showIf e1 e2 e3
>    = "if " ++ showExpr e1 ++ " then " ++ showExpr e2 
>      ++ " else " ++ showExpr e3


> showLambda :: String -> Expr -> String
> showLambda p (Lambda p' e')
>    = p ++ " " ++ showLambda p' e'
> showLambda p e
>    = p ++ " -> " ++ showExpr e 


> showBinaryLeft :: String -> Int -> Expr -> Expr -> String
> showBinaryLeft symbol power e1 e2    
>    | bindPow e1 < power && bindPow e2 <= power 
>       = "(" ++ showExpr e1 ++ ") " ++ symbol ++ "(" ++ showExpr e2 ++ ")"
>    | bindPow e1 < power  
>       = "(" ++ showExpr e1 ++ ") " ++ symbol ++ showExpr e2
>    | bindPow e2 <= power 
>       = showExpr e1 ++ " " ++ symbol ++ "(" ++ showExpr e2 ++ ")"
>    | otherwise
>       = showExpr e1 ++ " " ++ symbol ++ showExpr e2


> showBinaryRight :: String -> Int -> Expr -> Expr -> String
> showBinaryRight symbol power e1 e2    
>    | bindPow e1 <= power && bindPow e2 < power 
>       = "(" ++ showExpr e1 ++ ") " ++ symbol ++ "(" ++ showExpr e2 ++ ")"
>    | bindPow e1 <= power  
>       = "(" ++ showExpr e1 ++ ") " ++ symbol ++ showExpr e2
>    | bindPow e2 < power 
>       = showExpr e1 ++ " " ++ symbol ++ "(" ++ showExpr e2 ++ ")"
>    | otherwise
>       = showExpr e1 ++ " " ++ symbol ++ showExpr e2


isNiceList e returns True iff e is a list that should be printed in
[,,,] form.

> isNiceList :: Expr -> Bool
> isNiceList (List LEmpty)     = True
> isNiceList (List (_ :#: e2)) = isNiceList e2
> isNiceList _                 = False


> bindPow :: Expr -> Int
> bindPow e
>    = case e of
>         Undef               -> 11
>         Name _              -> 11
>         Const _             -> 11
>         List LEmpty         -> 11
>         List (DotDot _ _ _) -> 11
>         List (e1 :#: e2)    -> if isNiceList (e1 #:: e2) then 11 else 5 
>         Func1 _             -> 11
>         Func2 _             -> 11
>         _ :$: _             -> 10
>         _ :*: _             -> 7 
>         _ :/: _             -> 7 
>         _ :%: _             -> 7 
>         _ :+: _             -> 6 
>         _ :-: _             -> 6 
>         _ :<: _             -> 4 
>         _ :<=: _            -> 4 
>         _ :>: _             -> 4 
>         _ :>=: _            -> 4 
>         _ :==: _            -> 4 
>         _ :/=: _            -> 4 
>         _ :&&: _            -> 3 
>         _ :||: _            -> 2 
>         If _ _ _            -> -1
>         Lambda _ _          -> -2
>         Chunk e'            -> bindPow e'
   

======
Parser
======

expr  ::= expr || disj | disj

expr  ::= disj expr'
expr' ::= || disj expr' | epsilon

> exprP :: Parser Expr
> exprP = (disjP <*> expr'P @> (\(e,f) -> f e))
>         where
>         expr'P :: Parser (Expr -> Expr)
>         expr'P =     literalP "symbol" "||" 
>                      *> nofail' "disjunct expected" (disjP <*> expr'P) 
>                      @> (\ (x,f) -> f.(:||: x))
>                  <|> succeedA id

disj     ::= disj && conj | conj

disj     ::= conj disj'
disj'    ::= && conj disj' | epsilon

> disjP :: Parser Expr
> disjP = conjP <*> disj'P @> (\(e,f) -> f e)
>         where
>         disj'P :: Parser (Expr -> Expr)
>         disj'P =     literalP "symbol" "&&"
>                      *> nofail' "conjunct expected" (conjP <*> disj'P)
>                      @> (\ (x,f) -> f.(:&&: x))
>                  <|> succeedA id

conj  ::= conj < lcomp | conj <= lcomp | conj > lcomp | conj >= lcomp
          | conj == lcomp | conj /= lcomp | lcomp

conj  ::= lcomp conj'
conj' ::= < lcomp conj' | <= lcomp conj' | > lcomp conj' | >= lcomp conj'
          | == lcomp conj' | /= lcomp conj' | epsilon

> conjP :: Parser Expr
> conjP = lcompP <*> conj'P @> (\(e,f) -> f e)
>         where
>         conj'P :: Parser (Expr -> Expr)
>         conj'P =     literalP "symbol" "<" 
>                      *> nofail' "comparisand expected" (lcompP <*> conj'P)
>                      @> (\ (x,f) -> f.(:<: x))
>                  <|> literalP "symbol" "<="
>                      *> nofail' "comparisand expected" (lcompP <*> conj'P)
>                      @> (\ (x,f) -> f.(:<=: x))
>                  <|> literalP "symbol" ">"
>                      *> nofail' "comparisand expected" (lcompP <*> conj'P)
>                      @> (\ (x,f) -> f.(:>: x))
>                  <|> literalP "symbol" ">="
>                      *> nofail' "comparisand expected" (lcompP <*> conj'P)
>                      @> (\ (x,f) -> f.(:>=: x))
>                  <|> literalP "symbol" "=="
>                      *> nofail' "comparisand expected" (lcompP <*> conj'P)
>                      @> (\ (x,f) -> f.(:==: x))
>                  <|> literalP "symbol" "/="
>                      *> nofail' "comparisand expected" (lcompP <*> conj'P)
>                      @> (\ (x,f) -> f.(:/=: x))
>                  <|> succeedA id

lcomp ::= comp : lcomp | comp

> lcompP :: Parser Expr
> lcompP =     compP <*> literalP "symbol" ":" *> nofail' "list expected" lcompP
>              @> (\ (x,y) -> List (x :#: y))
>          <|> compP

comp     ::= comp + sterm | comp - sterm | sterm

comp     ::= sterm comp'
comp'    ::= + sterm comp' | - sterm comp' | epsilon

> compP :: Parser Expr
> compP = stermP <*> comp'P @> (\(e,f) -> f e)
>         where
>         comp'P :: Parser (Expr -> Expr)
>         comp'P =     literalP "symbol" "+" 
>                      *> nofail' "term expected" (stermP <*> comp'P)
>                      @> (\ (x,f) -> f.(:+: x))
>                  <|> literalP "symbol" "-" 
>                      *> nofail' "term expected" (stermP <*> comp'P)
>                      @> (\ (x,f) -> f.(:-: x))
>                  <|> succeedA id

sterm ::= - sterm | term

> stermP :: Parser Expr
> stermP =     literalP "symbol" "-" 
>                 *> nofail' "term expected" stermP
>                 @> (\e -> Func1 Negate :$: e)
>          <|> termP

term     ::= term * afactor | term `div` afactor | term `mod` afactor | afactor

term     ::= afactor term'
term'    ::= * afactor term' | `div` afactor term' | `mod` afactor term' 
             | epsilon
 
> termP :: Parser Expr
> termP = afactorP <*> term'P @> (\(e,f) -> f e)
>         where
>         term'P :: Parser (Expr -> Expr)
>         term'P =     literalP "symbol" "*" 
>                      *> nofail' "factor expected" (afactorP <*> term'P)
>                      @> (\ (x,f) -> f.(:*: x))
>                  <|> literalP "symbol" "`div`" 
>                      *> nofail' "divisor expected" (afactorP <*> term'P) 
>                      @> (\ (x,f) -> f.(:/: x))
>                  <|> literalP "symbol" "`mod`" 
>                      *> nofail' "divisor expected" (afactorP <*> term'P) 
>                      @> (\ (x,f) -> f.(:%: x))
>                  <|> succeedA id

afactor  ::= afactor factor | factor

afactor  ::= factor afactor'
afactor' ::= factor afactor' | epsilon

> afactorP :: Parser Expr
> afactorP = factorP <*> afactor'P @> (\(e,f) -> f e)
>            where
>            afactor'P :: Parser (Expr -> Expr)
>            afactor'P =     (factorP <*> afactor'P)
>                               @> (\ (x,f) -> f.(:$: x))
>                        <|> succeedA id

factor   ::= bool | unsigned | name | built_in | ( expr ) | lambda | if | list

> factorP :: Parser Expr
> factorP =     boolP
>           <|> unsignedP 
>           <|> nameP
>           <|> built_inP
>           <|> literalP "symbol" "(" *> nofail' "expression expected" exprP 
>               <* nofail (literalP "symbol" ")")
>           <|> lambdaP
>           <|> ifP
>           <|> listP

lambda ::= \ {name}+ -> expr

> lambdaP :: Parser Expr
> lambdaP = literalP "symbol" "\\" *> nofail (some nameP) 
>           <*> nofail (literalP "symbol" "->")
>           *> nofail' "expression expected" exprP 
>           @> (\(ns, e) -> makeFunction ns e)

if ::= if expr then expr else expr

> ifP :: Parser Expr
> ifP =     literalP "keyword" "if"  
>       <*> nofail' "boolean expression expected" exprP 
>       <*> nofail (literalP "keyword" "then") 
>       <*> nofail' "expression expected" exprP 
>       <*> nofail (literalP "keyword" "else")
>       <*> nofail' "expression expected" exprP 
>       @> (\(_,(e1,(_,(e2,(_,e3))))) -> If e1 e2 e3)

bool ::= True | False

> boolP :: Parser Expr
> boolP =     literalP "boolean" "True"  #> (bool True)
>         <|> literalP "boolean" "False" #> (Const (Bool False))

name ::= lower {letter | digit | ' | _ }

> nameP :: Parser Expr
> nameP = tagP "name" @> (\(_,cs,_) -> Name cs)

built_in ::= negate | not | head | tail | abs | signum | div | mod

> built_inP :: Parser Expr
> built_inP =     literalP "keyword" "negate"  #> (Func1 Negate)
>             <|> literalP "keyword" "not"     #> (Func1 Not)
>             <|> literalP "keyword" "head"    #> (Func1 Head)
>             <|> literalP "keyword" "tail"    #> (Func1 Tail)
>             <|> literalP "keyword" "abs"     #> (Func1 Abs)
>             <|> literalP "keyword" "signum"  #> (Func1 Signum)
>             <|> literalP "keyword" "div"     #> (Func2 Div)
>             <|> literalP "keyword" "mod"     #> (Func2 Mod)

unsigned ::= {digit}+
 
> unsignedP :: Parser Expr
> unsignedP = tagP "cardinal" @> (\(_,cs,_) -> Const (Int (read cs)))

list ::= [ ( ] | expr [,expr] .. expr | expr {, expr} ] )

> listP :: Parser Expr
> listP =  literalP "symbol" "[" *> (
>                 literalP "symbol" "]" #> makeEList []
>             <|> exprP
>                 <*> optional (literalP "symbol" "," 
>                               *> nofail' "expression expected" exprP)
>                 <*> literalP "symbol" ".."
>                 <*> nofail' "expression expected" exprP
>                 <* nofail (literalP "symbol" "]")
>                 @> (\(e1,(e2s,(_,(e3)))) -> 
>                       case e2s of
>                          []   -> List (DotDot e1 (e1 :+: (Const (Int 1))) e3)
>                          [e2] -> List (DotDot e1 e2 e3))
>             <|> nofail' "expression expected" exprP 
>                 <*> many (literalP "symbol" ","
>                           *> nofail' "expression expected" exprP)
>                 <* nofail (literalP "symbol" "]")
>                 @> (\(e,es) -> makeEList (e:es))
>          )
           

=============
Making ELists
=============

makeEList es makes an Expr out of a list of expressions.

> makeEList :: [Expr] -> Expr
> makeEList []     = List LEmpty
> makeEList (e:es) = List (e :#: (makeEList es)) 


======================================
Making Functions out of Haskell syntax
======================================

If a function syntax like

   f arg1 arg2 ... = expr
   
or

   \arg1 arg2 ... ->
	
is used this function will be useful for making the right sort of function
Expr.

> makeFunction :: [Expr] -> Expr -> Expr
> makeFunction [] e
>    = e
> makeFunction ((Name a):as) e
>    = Lambda a (makeFunction as e)