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 Data.Functor as Functor
   9 import Data.Functor.Identity
  10 import Control.Applicative as Applicative
  11 import Control.Monad as Monad
  12 import Control.Monad.IO.Class (MonadIO(..))
  13 import Data.IORef
  14 import qualified Data.Bool as Bool
  15 import qualified Data.Maybe as Maybe
  16 import qualified Data.Map.Strict as Map
  17
  18 import Language.Symantic.Lib.Control.Monad
  19 import Language.Symantic.Type
  20 import Language.Symantic.Expr
  21
  22 -- * Type 'Repr_Host'
  23
  24 -- | Interpreter's data.
  25 --
  26 -- NOTE: the host-type @h@ is wrapped inside @lam@ to let 'Sym_Lambda'
  27 -- control its callings (see 'inline', 'val', and 'lazy').
  28 newtype Repr_Host lam h
  29  =      Repr_Host
  30  {    unRepr_Host :: lam h }
  31  deriving (Applicative, Functor, Monad, MonadIO)
  32
  33 -- | Interpreter.
  34 host_from_expr :: Repr_Host lam h -> lam h
  35 host_from_expr = unRepr_Host
  36
  37 type instance Lambda_from_Repr (Repr_Host lam) = lam
  38 instance Monad lam => Sym_Lambda_App lam (Repr_Host lam) where
  39         app      = liftM2Join $ \(Lambda f) a -> Repr_Host $ f $ return a
  40 instance Monad lam => Sym_Lambda_Inline lam (Repr_Host lam) where
  41         inline f = return $ Lambda $ unRepr_Host . f . Repr_Host
  42 instance Monad lam => Sym_Lambda_Val lam (Repr_Host lam) where
  43         val    f = return $ Lambda $ (>>= unRepr_Host . f . Repr_Host  . return)
  44 instance MonadIO lam => Sym_Lambda_Lazy lam (Repr_Host lam) where
  45         lazy   f = return $ Lambda $ ((>>= unRepr_Host . f . Repr_Host) . lazy_share)
  46 instance Monad lam => Sym_Bool (Repr_Host lam) where
  47         bool = return
  48         not  = Functor.fmap Bool.not
  49         (&&) = liftM2 (Prelude.&&)
  50         (||) = liftM2 (Prelude.||)
  51 instance Monad lam => Sym_Int (Repr_Host lam) where
  52         int    = return
  53         abs    = Functor.fmap Prelude.abs
  54         negate = Functor.fmap Prelude.negate
  55         (+)    = liftM2 (Prelude.+)
  56         (-)    = liftM2 (Prelude.-)
  57         (*)    = liftM2 (Prelude.*)
  58         mod    = liftM2 Prelude.mod
  59 instance Monad lam => Sym_Maybe (Repr_Host lam) where
  60         nothing = return Nothing
  61         just    = liftMJoin $ return . Just
  62 instance Monad lam => Sym_Maybe_Lam lam (Repr_Host lam) where
  63         maybe n j m = do
  64                 mm <- m
  65                 Maybe.maybe n (\a -> j `app` return a) mm
  66 instance Monad lam => Sym_If (Repr_Host lam) where
  67         if_ m ok ko = do
  68                 m' <- m
  69                 if m' then ok else ko
  70 instance Monad lam => Sym_When (Repr_Host lam) where
  71         when m ok = do
  72                 m' <- m
  73                 Monad.when m' ok
  74 instance Monad lam => Sym_Eq (Repr_Host lam) where
  75         (==) = liftM2 (Prelude.==)
  76 instance Monad lam => Sym_Ord (Repr_Host lam) where
  77         compare = liftM2 Prelude.compare
  78 instance Monad lam => Sym_List (Repr_Host lam) where
  79         list_empty = return []
  80         list_cons  = liftM2 (:)
  81         list       = sequence
  82 instance Monad lam => Sym_List_Lam lam (Repr_Host lam) where
  83         list_filter f = liftMJoin go
  84                 where
  85                 go [] = return []
  86                 go (x:xs) = do
  87                         b <- f `app` return x
  88                         (if b then ((x :) Prelude.<$>) else id)
  89                          (go xs)
  90 instance Monad lam => Sym_Tuple2 (Repr_Host lam) where
  91         tuple2 = liftM2 (,)
  92 instance Monad lam => Sym_Map (Repr_Host lam) where
  93         map_from_list = Functor.fmap Map.fromList
  94 instance Monad lam => Sym_Map_Lam lam (Repr_Host lam) where
  95         map_map f = liftMJoin $ sequence . ((\a -> f `app` return a) Prelude.<$>)
  96 instance Sym_Functor Identity (Repr_Host Identity) where
  97         fmap f m = (a2b Functor.<$>) Functor.<$> m
  98                 where a2b a = runIdentity $ unRepr_Host $ f `app` return a
  99         {- NOTE: need Traversable
 100         fmap f = liftMJoin $ sequence . ((\a -> f `app` return a) Functor.<$>)
 101         -}
 102 instance Monad lam => Sym_Applicative (Repr_Host lam) where
 103         pure = Functor.fmap Applicative.pure
 104 instance Sym_Applicative_Lam Identity (Repr_Host Identity) where
 105         (<*>) = liftM2Join $ \fg ->
 106                 return . (Applicative.<*>)
 107                  ((\(Lambda g) -> runIdentity . g . Identity) Functor.<$> fg)
 108         {- NOTE: need Traversable
 109         (<*>) = liftM2Join $ \fg fa ->
 110                 Repr_Host $ sequence $
 111                  (unLambda Functor.<$> fg)
 112                  Applicative.<*>
 113                  (return Functor.<$> fa)
 114         -}
 115
 116 -- | Helper to store arguments of 'lazy' into an 'IORef'.
 117 lazy_share :: MonadIO m => m a -> m (m a)
 118 lazy_share m = do
 119         r <- liftIO $ newIORef (False, m)
 120         return $ do
 121                 (already_evaluated, m') <- liftIO $ readIORef r
 122                 if already_evaluated
 123                         then m'
 124                         else do
 125                                 v <- m'
 126                                 liftIO $ writeIORef r (True, return v)
 127                                 return v