content: module HaskellCoreLite1_3 where 
  
  import AST
  import Monad
  
  ------------------------------------
  -- Monadic control structures
  ------------------------------------
  
  caseM test fail successf =
    do { vbl <- test
       ; case vbl of
           Nothing -> fail
           Just x -> successf x
       }
  
  ifV test thenM elseM =
    do { BV b <- test
       ; if b then thenM else elseM
       }
       
  ----------------------------------------------------------------------
  --- these functions do matching or selection
  ----------------------------------------------------------------------
  
  proj :: Int -> M Value -> M Value
  proj n phi = do { (TupleVal mvals) <- phi ; mvals !! (n-1)  }
  
  checkTag :: Name -> M Value -> M Value
  checkTag tag arg =
      do { (Tagged t mvals) <- arg
         ; if t==tag 
              then return (TupleVal mvals)
              else raise("Tag " ++ t ++ "!="++tag)
         }
  
  
  concatM ::Monad m => [m [a]] -> m [a]
  concatM x = sequence x >>= (return . concat)
  
  match :: P -> M Value -> M (Maybe EnvFrag)
  match (Pvar x) arg = return (Just [(x,arg)])
  match (Ptilde p) arg = return (Just (lazymatch p arg))
  match (Pconst i) arg = 
      do { (Z v) <- arg
         ; if v==i 
              then return(Just [])
              else return Nothing
         }
  match (Ptuple ps) arg = 
      do { (TupleVal mvals) <- arg
         ; frags <- sequence(zipWith match ps mvals)
         ; return(concatM frags)
         }
  match (Pcondata tag ps) arg = 
      do { (Tagged t mvals) <- arg
         ; if tag==t 
           then sequence (zipWith match ps mvals) >>= (return . concatM)
           else return Nothing
         }
  match (Pnewdata n p) arg = match p arg
    
  
  
  lazymatch :: P -> M Value -> EnvFrag
  lazymatch (Pconst k) mv = []
  lazymatch (Pvar x) mv = [(x,mv)]
  lazymatch (Ptilde p) mv = lazymatch p mv
  lazymatch (Pcondata n ps) mv = concat(zipWith tagN [1..] ps)
      where tagN i p = lazymatch p (proj i (checkTag n mv))
  lazymatch (Pnewdata n p) mv = lazymatch p mv                    
  lazymatch (Ptuple ps) mvals = concat(zipWith select [1..] ps)
      where select i p = lazymatch p (proj i mvals)
  
  app :: M Value -> M Value -> M Value
  app x y = do { rho <- rdEnv ; (FV f1) <- x ; f1 (inEnv rho y) }
  
  addBindings :: Env -> EnvFrag -> Env
  addBindings rho [] = rho
  addBindings rho ((n,mv):bindings) = addBindings (xEnv rho n mv) bindings
  
  ----------------------------------------------------------
  letbind :: [D] -> M a -> M a
  letbind ds phi =
       do { rho <- rdEnv
          ; let rho' = fix (\ r -> addBindings rho (addDs ds r))
            in inEnv rho' phi
          }
                 
  addDs :: [D] -> Env -> EnvFrag
  addDs [] r = []
  addDs (d:ds) r =
    case d of
     (Val p body ds) -> lazymatch p (inEnv r (letbind ds (evalB body))) ++ (addDs ds r)
     (Fun nm cls) -> (nm,evalCls cls) : (addDs ds r)
      where evalCls :: [([P],B,[D])] -> M Value
            evalCls [] = raise "no guard matches"
            evalCls ((ps,body,ds):cls) = 
                arrow ps (inEnv r (letbind ds (evalB body)))   
  
  arrow :: [P] -> M Value -> M Value
  arrow [] b = b
  arrow (p:ps) b =
     do { rho <- rdEnv
        ; let f v = caseM (match p v) 
                         (raise "match Error in Fun")
                         (\ vl -> inEnv (addBindings rho vl) (arrow ps b))
        ; return(FV f)
        }
  
  evalB :: B -> M(Value)
  evalB (Normal e) = (eval e)
  evalB (Guarded []) = error "no guard matches"
  evalB (Guarded ((g,e):gs)) = ifV (eval g) (eval e) (evalB (Guarded gs))
        
  
  eval :: E -> M Value
  eval (Const i) = return (Z i)
  eval Tconst = return (BV True)
  eval Fconst = return (BV False)
  eval Boom = eval Boom
  eval Undefined = raise "Undefined"
  eval (Var n) = do { rho <- rdEnv ; rho n }
  eval (Abs ps l) = arrow ps (eval l)
  eval (App l1 l2) =
     do { rho <- rdEnv
        ; (FV f1) <- eval l1
        ; f1 (inEnv rho $ eval l2) }
  eval (TupleExp es) = 
     do { rho <- rdEnv ; return (TupleVal $ map (\e -> inEnv rho $ eval e) es) }
  eval (ConApp n es) = 
     do { rho <- rdEnv
        ; let f (e,Lazy) es   = do { cs <- es
                                   ; return ((inEnv rho (eval e)):cs) }
              f (e,Strict) es = do { c <- eval e; cs <- es
                                   ; return((return c):cs)}
        ; cs <- foldr f (return []) es
        ; return(Tagged n cs)
        }  
  eval (NewApp n x) = eval x
  eval (Case e ms) = evalMatchList (map evalM ms) (eval e)
  eval (Let pelist le) = letbind pelist (eval le)
  eval (Bin op l1 l2) =
     do { (Z i1) <- eval l1
        ; (Z i2) <- eval l2
        ; return(f op i1 i2)
        }
   where f Plus x y = Z(x + y)
         f Mult x y = Z(x * y)
         f IntEq x y = BV(x==y)
         f IntLess x y = BV(x < y)
  eval (Cond l1 l2 l3) = ifV (eval l1) (eval l2) (eval l3)
       
  
  -------------------------------------------------------------
  -------------- Matches and their meaning  -------------------
  -------------------------------------------------------------
  
  justify :: M Value -> M (Maybe Value)
  justify x = x >>= (return . Just)
  
  --- Probably need a new name for this:
  evalM :: (P,B,[D]) -> M Value -> M(Maybe Value)
  evalM (p,(Normal e),ds) arg = 
     caseM (match p arg) (return Nothing)
           (\frag ->  do { rho <- rdEnv
                         ; inEnv (addBindings rho frag) 
                                 $ letbind ds (justify (eval e))
                         })
  evalM (p,(Guarded guards),ds) arg =
     caseM (match p arg) (return Nothing) 
        (\frag ->  do { rho <- rdEnv
                      ; inEnv (addBindings rho frag) 
                             $ letbind ds (evalGuardedList guards) } )
      where
          evalGuardedList :: [(E,E)] -> M (Maybe Value)
          evalGuardedList [] = return Nothing
          evalGuardedList ((g,b):gs) =
                             do { v <- eval g
                                ; case v of
                                     (BV True)  -> (eval b) >>= (return . Just)
                                     (BV False) -> evalGuardedList gs
                                }
  
  evalMatchList :: [M Value -> M(Maybe Value)] -> (M Value -> M Value)
  evalMatchList [] arg = raise "Match Failure"
  evalMatchList (f:fs) arg = caseM (f arg) (evalMatchList fs arg) return
  
  --------------------------------------------------------------
  --------------------------------------------------------------
  --------------------------------------------------------------
  
  splat phi = (deM phi (\msg -> error "hey - you're applying the empty env!"))
  run le = (deM (eval le) (\msg -> error "hey - you're applying the empty env!"))
  