1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE TypeFamilies #-}
5 module Language.LOL.Symantic.Repr.Host where
7 import Control.Monad.IO.Class (MonadIO(..))
9 import qualified Data.Bool as Bool
10 import Prelude hiding (and, not, or)
12 import Language.LOL.Symantic.Lib.Control.Monad
13 import Language.LOL.Symantic.Expr
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
23 { unRepr_Host :: lam h }
24 deriving (Applicative, Functor, Monad, MonadIO)
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
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
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
44 host_repr :: Repr_Host repr h -> repr h
45 host_repr = unRepr_Host
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)
52 (already_evaluated, m') <- liftIO $ readIORef r
57 liftIO $ writeIORef r (True, return v)