Language/LOL/Symantic/Repr/Host.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module Language.LOL.Symantic.Repr.Host where
   6
   7 import Control.Monad.IO.Class (MonadIO(..))
   8 import Data.IORef
   9 import qualified Data.Bool as Bool
  10 import Prelude hiding (and, not, or)
  11
  12 import Language.LOL.Symantic.Lib.Control.Monad
  13 import Language.LOL.Symantic.Expr
  14
  15 -- * Type 'Repr_Host'
  16
  17 -- | Host-circular interpreter,
  18 -- producing a host-term of host-type @h@,
  19 -- wrapped inside @lam@ because of 'Sym_Lambda'
  20 -- ability to control its callings (see 'inline', 'val', and 'lazy').
  21 newtype Repr_Host lam h
  22  =      Repr_Host
  23  {    unRepr_Host :: lam h }
  24  deriving (Applicative, Functor, Monad, MonadIO)
  25
  26 instance MonadIO lam => Sym_Lambda lam (Repr_Host lam) where
  27         type Lambda_from_Repr (Repr_Host lam) = lam
  28         app = liftM2Join $ \f a -> Repr_Host $ f $ return a
  29         inline f = return $ unRepr_Host . f . Repr_Host
  30         val    f = return $ (>>= unRepr_Host . f . Repr_Host . return)
  31         lazy   f = return $ ((>>= unRepr_Host . f . Repr_Host) . expr_lambda_lazy_share)
  32 instance Monad repr => Sym_Bool (Repr_Host repr) where
  33         bool = return
  34         not  = liftMJoin  $ return . Bool.not
  35         and  = liftM2Join $ \x y -> return $ x && y
  36         or   = liftM2Join $ \x y -> return $ x || y
  37 instance Monad repr => Sym_Int (Repr_Host repr) where
  38         int = return
  39         neg  = liftMJoin  $ return . negate
  40         add = liftM2Join $ \x y -> return $ x + y
  41 --instance Monad m => Sym_Eq (Host m) where
  42 --      eq = liftM2Join $ \x y -> return $ x == y
  43
  44 host_repr :: Repr_Host repr h -> repr h
  45 host_repr = unRepr_Host
  46
  47 -- | Utility for storing arguments of 'lazy' into an 'IORef'.
  48 expr_lambda_lazy_share :: MonadIO m => m a -> m (m a)
  49 expr_lambda_lazy_share m = do
  50         r <- liftIO $ newIORef (False, m)
  51         return $ do
  52                 (already_evaluated, m') <- liftIO $ readIORef r
  53                 if already_evaluated
  54                         then m'
  55                         else do
  56                                 v <- m'
  57                                 liftIO $ writeIORef r (True, return v)
  58                                 return v