--------------------------------------------------------------------------------
--                                                                            --
-- interpreter building block for numeric expressions                         --
--                                                                            --
--------------------------------------------------------------------------------

-- N

data N x = Num Int
         | x `Add` x
         | x `Sub` x
         | x `Mul` x
         | x `Dvd` x
           
instance Functor N where
  map g (Num n) = Num n
  map g (x `Add` y) = g x `Add` g y 
  map g (x `Sub` y) = g x `Sub` g y
  map g (x `Mul` y) = g x `Mul` g y
  map g (x `Dvd` y) = g x `Dvd` g y
  
-- parse

instance Parser m x => Parser m (N x) where
  parser =   pNum parser'
          ++ pAdd parser'
          ++ pSub parser'
          ++ pMul parser'
          ++ pDvd parser'

   where

    parser' = parser :: Parser m x => m x

    pNum _      
      = do { n <- pInt ; result (Num n) } 
    pAdd parser 
      = do { pLit "(" ; x <- parser ; pLit "+" ; y <- parser ; pLit ")" ;
            result (x `Add` y) }
    pSub parser 
      = do { pLit "(" ; x <- parser ; pLit "-" ; y <- parser ; pLit ")" ;
            result (x `Sub` y) }
    pMul parser 
      = do { pLit "(" ; x <- parser ; pLit "*" ; y <- parser ; pLit ")" ;
            result (x `Mul` y) }
    pDvd parser 
      = do { pLit "(" ; x <- parser ; pLit "/" ; y <- parser ; pLit ")" ;
            result (x `Dvd` y) }

-- unparse
   
instance Algebra N (IO ()) where
  phi (Num n)   
    = uInt n
  phi (x `Add` y) 
    = do { uLit "(" ; x ; uLit "+" ; y  ; uLit ")" }
  phi (x `Sub` y) 
    = do { uLit "(" ; x ; uLit "-" ; y ; uLit ")" }
  phi (x `Mul` y) 
    = do { uLit "(" ; x ; uLit "*" ; y ; uLit ")" }
  phi (x `Dvd` y) 
    = do { uLit "(" ; x ; uLit "/" ; y ; uLit ")" }

-- interpret
             
instance (ErrMonad m, SubType Int v) => Algebra N (m v) where
  phi (Num n) 
    = result (inj n)
  phi (mx `Add` my) 
    = do { x <- mx ; y <- my ; 
           resultInj (prj x `add` prj y) }
     where
      add = (+) :: Int -> Int -> Int
  phi (mx `Sub` my) 
    = do { x <- mx ; y <- my ; 
           resultInj (prj x `sub` prj y) }
     where
      sub = (-) :: Int -> Int -> Int
  phi (mx `Mul` my) 
    = do { x <- mx ; y <- my ; 
           resultInj (prj x `mul` prj y) }
     where 
      mul = (*) :: Int -> Int -> Int
  phi (mx `Dvd` my) 
    = do { x <- mx ; y <- my ; 
           let py = prj y 
           in if (py == 0) 
               then err (show' (prj x) ++ "/" ++ show' 0) 
               else resultInj (prj x `dvd` py) }
      where 
       dvd = (/) :: Int -> Int -> Int 
       show' = show :: Int -> String

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








