Language/LOL/Symantic/Repr/Host.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 -- | Interpreter to compute a host-term.
   6 module Language.LOL.Symantic.Repr.Host where
   7
   8 import Control.Monad.IO.Class (MonadIO(..))
   9 import Data.IORef
  10 import qualified Data.Bool as Bool
  11 import qualified Data.Maybe as Maybe
  12 import Prelude hiding (and, not, or)
  13
  14 import Language.LOL.Symantic.Lib.Control.Monad
  15 import Language.LOL.Symantic.Expr
  16
  17 -- * Type 'Repr_Host'
  18
  19 -- | Interpreter's data.
  20 --
  21 -- NOTE: the host-type @h@ is wrapped inside @lam@ to let 'Sym_Lambda'
  22 -- control its callings (see 'inline', 'val', and 'lazy').
  23 newtype Repr_Host lam h
  24  =      Repr_Host
  25  {    unRepr_Host :: lam h }
  26  deriving (Applicative, Functor, Monad, MonadIO)
  27
  28 -- | Interpreter.
  29 host_from_expr :: Repr_Host lam h -> lam h
  30 host_from_expr = unRepr_Host
  31
  32 instance MonadIO lam => Sym_Lambda lam (Repr_Host lam) where
  33         type Lambda_from_Repr (Repr_Host lam) = lam
  34         app = liftM2Join $ \f a -> Repr_Host $ f $ return a
  35         inline f = return $       unRepr_Host . f . Repr_Host
  36         val    f = return $  (>>= unRepr_Host . f . Repr_Host  . return)
  37         lazy   f = return $ ((>>= unRepr_Host . f . Repr_Host) . expr_lambda_lazy_share)
  38 instance Monad lam => Sym_Bool (Repr_Host lam) where
  39         bool = return
  40         not  = liftMJoin  $ return . Bool.not
  41         and  = liftM2Join $ \x y -> return $ x && y
  42         or   = liftM2Join $ \x y -> return $ x || y
  43 instance Monad lam => Sym_Int (Repr_Host lam) where
  44         int = return
  45         neg = liftMJoin  $ return . negate
  46         add = liftM2Join $ \x y -> return $ x + y
  47 instance MonadIO lam => Sym_Maybe lam (Repr_Host lam) where
  48         maybe n j m = do
  49                 mm <- m
  50                 Maybe.maybe n (\a -> j `app` return a) mm
  51 instance Monad lam => Sym_Maybe_Cons (Repr_Host lam) where
  52         nothing = return Nothing
  53         just    = liftMJoin $ return . Just
  54 --instance Monad lam => Sym_Eq (Repr_Host lam) where
  55 --      eq = liftM2Join $ \x y -> return $ x == y
  56
  57 -- | Helper to store arguments of 'lazy' into an 'IORef'.
  58 expr_lambda_lazy_share :: MonadIO m => m a -> m (m a)
  59 expr_lambda_lazy_share m = do
  60         r <- liftIO $ newIORef (False, m)
  61         return $ do
  62                 (already_evaluated, m') <- liftIO $ readIORef r
  63                 if already_evaluated
  64                         then m'
  65                         else do
  66                                 v <- m'
  67                                 liftIO $ writeIORef r (True, return v)
  68                                 return v