--------------------------------------------------------------------------------
--                                                                            --
-- interpreter building block for definitions                                 --
--                                                                            --
--------------------------------------------------------------------------------

-- D

data D x = LetV Name x x
         | LetN Name x x
         | LetL Name x x

instance Functor D where
  map g (LetV n x y) = LetV n (g x) (g y)
  map g (LetN n x y) = LetN n (g x) (g y)
  map g (LetL n x y) = LetL n (g x) (g y)
 
-- parse

instance Parser m x => Parser m (D x) where
  parser =   pLetV parser'
          ++ pLetN parser' 
          ++ pLetL parser'
   where
       
    parser' = parser :: Parser m x => m x

    pLetV parser 
      = do { pLit "LETV" ; n <- pLow ; pLit "=" ; 
             x <- parser ; pLit "IN" ; y <- parser ;
             result (LetV n x y) } 
    pLetN parser 
      = do { pLit "LETN" ; n <- pLow ; pLit "=" ;
             x <- parser ; pLit "IN" ; y <- parser ; 
             result (LetN n x y) } 
    pLetL parser 
      = do { pLit "LETL" ; n <- pLow ; pLit "=" ; 
             x <- parser ; pLit "IN" ; y <- parser ;
             result (LetL n x y) } 

-- unparse

instance Algebra D (IO ()) where
  phi (LetV n x y) 
    = do { uLit "LETV " ; uLow n ; uLit " = " ; x ; uLow " IN " ; y } 
  phi (LetN n x y) 
    = do { uLit "LETN " ; uLow n ; uLit " = " ; x ; uLow " IN " ; y }  
  phi (LetL n x y) 
   = do { uLit "LETL " ; uLow n ; uLit " = " ; x ; uLow " IN " ; y } 
  
-- interpret

instance (EnvMonad (Table (m v)) m, StateMonad (Heap (m v)) m)
        => Algebra D (m v) where
  phi (LetV x md mb) 
     = do
        heap@(loc,_) <- allocHeap
        tab <- read
        let 
          md' = do
                 newtab <- updateT (x,lookupHeap loc) tab
                 withT newtab md
          mb' = do
                 newtab <- updateT (x,lookupHeap loc) tab
                 withT newtab mb
        v <- md'  
        updateHeap (heap,result v)
        mb' 
       where
        withT = with :: EnvMonad (Table (m v)) m => Table (m v) -> m v -> m v
  phi (LetN x md mb) 
    = do
       heap@(loc,_) <- allocHeap
       tab <- read
       let 
         md' = do
                newtab <- updateT (x,lookupHeap loc) tab
                withT newtab md
         mb' = do
                newtab <- updateT (x,lookupHeap loc) tab
                withT newtab mb
       updateHeap (heap,md')
       mb'
      where
       withT = with :: EnvMonad (Table (m v)) m => Table (m v) -> m v -> m v
  phi (LetL x md mb) 
    = do
       heap@(loc,_) <- allocHeap
       tab <- read
       let 
         md' = do
                newtab <- updateT (x,lookupHeap loc) tab
                withT newtab md
         mb' = do
                newtab <- updateT (x,lookupHeap loc) tab
                withT newtab mb
         updateThunk = do
                        v <- md'
                        updateHeap (heap, result v)
                        result v
       updateHeap (heap,updateThunk)
       mb'
      where
       withT = with :: EnvMonad (Table (m v)) m => Table (m v) -> m v -> m v

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