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