]> Git — Sourcephile - haskell/symantic.git/blob - Language/LOL/Symantic/Repr/Host.hs
init
[haskell/symantic.git] / 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 (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 when_ m ok = do
60 m' <- m
61 when m' ok
62
63 --instance Monad lam => Sym_Eq (Repr_Host lam) where
64 -- eq = liftM2Join $ \x y -> return $ x == y
65
66 -- | Helper to store arguments of 'lazy' into an 'IORef'.
67 expr_lambda_lazy_share :: MonadIO m => m a -> m (m a)
68 expr_lambda_lazy_share m = do
69 r <- liftIO $ newIORef (False, m)
70 return $ do
71 (already_evaluated, m') <- liftIO $ readIORef r
72 if already_evaluated
73 then m'
74 else do
75 v <- m'
76 liftIO $ writeIORef r (True, return v)
77 return v