]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Repr/Host.hs
init
[haskell/symantic.git] / Language / 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.Symantic.Repr.Host where
7
8 import Control.Monad as Monad
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.Symantic.Lib.Control.Monad
16 import Language.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 = fmap Bool.not
42 and = liftM2 (&&)
43 or = liftM2 (||)
44 instance Monad lam => Sym_Int (Repr_Host lam) where
45 int = return
46 neg = fmap negate
47 add = liftM2 (+)
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 instance Monad lam => Sym_Eq (Repr_Host lam) where
64 eq = liftM2 (==)
65
66 --instance Monad lam => Sym_Eq (Repr_Host lam) where
67 -- eq = liftM2Join $ \x y -> return $ x == y
68
69 -- | Helper to store arguments of 'lazy' into an 'IORef'.
70 expr_lambda_lazy_share :: MonadIO m => m a -> m (m a)
71 expr_lambda_lazy_share m = do
72 r <- liftIO $ newIORef (False, m)
73 return $ do
74 (already_evaluated, m') <- liftIO $ readIORef r
75 if already_evaluated
76 then m'
77 else do
78 v <- m'
79 liftIO $ writeIORef r (True, return v)
80 return v