--------------------------------------------------------------------------------
--                                                                            --
-- interpreter building block for lambda expressions                          --
--                                                                            --
--------------------------------------------------------------------------------

-- F

data F x = LamN Name x
         | LamV Name x
         | LamL Name x
         | App x x

instance Functor F where
  map g (LamV s b) = LamV s (g b)
  map g (LamN s b) = LamN s (g b)
  map g (LamL s b) = LamL s (g b) 
  map g (App f a) = App (g f) (g a)

-- parse

instance Parser m x => Parser m (F x) where
  parser =  pLamV parser'
         ++ pLamN parser'
         ++ pLamL parser'
         ++ pApp parser' 
   where
    parser' = parser :: Parser m x => m x

    pLamV parser 
      = do { pLit "\\V" ; x <- pLow ; pLit "->" ; b <- parser ;
             result (LamV x b) }
    pLamN parser 
      = do { pLit "\\N" ; x <- pLow ; pLit "->" ; b <- parser ;
             result (LamN x b) }
    pLamL parser 
      = do { pLit "\\L" ; x <- pLow ; pLit "->" ; b <- parser ;
             result (LamL x b) }
    pApp parser  
      = do { pLit "(" ; f <- parser ; a <- parser ; pLit ")" ;
             result (App f a) }
                             
-- unparse

instance Algebra F (IO ()) where
  phi (LamV x b) 
    = do { uLit "\\V " ; uLow x ; uLit " -> " ; b } 
  phi (LamN x b) 
    = do { uLit "\\N " ; uLow x ; uLit " -> " ; b }
  phi (LamL x b) 
    = do { uLit "\\L " ; uLow x ; uLit " -> " ; b }
  phi (App f a) 
    = do { uLit "(" ; f ; uLit " " ; a ; uLit ")" }

-- interpret

instance (EnvMonad (Table (m v)) m, StateMonad (Heap (m v)) m, Reflexive m v)
        => Algebra F (m v) where

  phi (LamV x mb) 
    = do { tab <- read ;
           resultInj (\m -> do { v <- m ;
                                 newtab <- updateT (x,result v) tab ;
                                 withT newtab mb }
                     ) }
      where
       withT = with :: EnvMonad (Table (m v)) m => Table (m v) -> m v -> m v
  phi (LamN x mb) 
    = do { tab <- read ;
           resultInj (\m -> do { newtab <- updateT (x,m) tab ;
                                 withT newtab mb } 
                     ) }
     where
      withT = with :: EnvMonad (Table (m v)) m => Table (m v) -> m v -> m v
  phi (LamL x mb) 
    = do { tab <- read ;
           resultInjF 
            (\m -> do { heap@(loc,_) <- allocHeap ;
                        let updateThunk = do { v <- m ;
                                               updateHeap (heap, result v) ;
                                               result v }
                        in do { updateHeap (heap,updateThunk) ; 
                                newtab <- updateT (x,lookupHeap loc) tab ;  
                                withT newtab mb }}           
            )}
     where
      withT = with :: EnvMonad (Table (m v)) m => Table (m v) -> m v -> m v
      resultInjF = resultInj :: (Monad m, Reflexive m v) => (m v -> m v) -> m v
  phi (App mf ma) 
    = do { f <- mf ; tab <- read ; prj f (withT tab ma) }
      where
       withT = with :: EnvMonad (Table (m v)) m => Table (m v) -> m v -> m v

--------------------------------------------------------------------------------   





















