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 Prelude hiding (and, not, or)
  12
  13 import Language.LOL.Symantic.Lib.Control.Monad
  14 import Language.LOL.Symantic.Expr
  15
  16 -- * Type 'Repr_Host'
  17
  18 -- | Interpreter's data.
  19 --
  20 -- NOTE: the host-type @h@ is wrapped inside @lam@ to let 'Sym_Lambda'
  21 -- control its callings (see 'inline', 'val', and 'lazy').
  22 newtype Repr_Host lam h
  23  =      Repr_Host
  24  {    unRepr_Host :: lam h }
  25  deriving (Applicative, Functor, Monad, MonadIO)
  26
  27 -- | Interpreter.
  28 host_from_expr :: Repr_Host repr h -> repr h
  29 host_from_expr = unRepr_Host
  30
  31 instance MonadIO lam => Sym_Lambda lam (Repr_Host lam) where
  32         type Lambda_from_Repr (Repr_Host lam) = lam
  33         app = liftM2Join $ \f a -> Repr_Host $ f $ return a
  34         inline f = return $       unRepr_Host . f . Repr_Host
  35         val    f = return $  (>>= unRepr_Host . f . Repr_Host  . return)
  36         lazy   f = return $ ((>>= unRepr_Host . f . Repr_Host) . expr_lambda_lazy_share)
  37 instance Monad repr => Sym_Bool (Repr_Host repr) where
  38         bool = return
  39         not  = liftMJoin  $ return . Bool.not
  40         and  = liftM2Join $ \x y -> return $ x && y
  41         or   = liftM2Join $ \x y -> return $ x || y
  42 instance Monad repr => Sym_Int (Repr_Host repr) where
  43         int = return
  44         neg  = liftMJoin  $ return . negate
  45         add = liftM2Join $ \x y -> return $ x + y
  46 --instance Monad repr => Sym_Eq (Repr_Host repr) where
  47 --      eq = liftM2Join $ \x y -> return $ x == y
  48
  49 -- | Helper to store arguments of 'lazy' into an 'IORef'.
  50 expr_lambda_lazy_share :: MonadIO m => m a -> m (m a)
  51 expr_lambda_lazy_share m = do
  52         r <- liftIO $ newIORef (False, m)
  53         return $ do
  54                 (already_evaluated, m') <- liftIO $ readIORef r
  55                 if already_evaluated
  56                         then m'
  57                         else do
  58                                 v <- m'
  59                                 liftIO $ writeIORef r (True, return v)
  60                                 return v