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