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 qualified Data.Map.Strict as Map
  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) . lazy_share)
  39 instance Monad lam => Sym_Bool (Repr_Host lam) where
  40         bool = return
  41         not  = Prelude.fmap Bool.not
  42         (&&) = liftM2 (Prelude.&&)
  43         (||) = liftM2 (Prelude.||)
  44 instance Monad lam => Sym_Int (Repr_Host lam) where
  45         int    = return
  46         abs    = Prelude.fmap Prelude.abs
  47         negate = Prelude.fmap Prelude.negate
  48         (+)    = liftM2 (Prelude.+)
  49         (-)    = liftM2 (Prelude.-)
  50         (*)    = liftM2 (Prelude.*)
  51         mod    = liftM2 Prelude.mod
  52 instance Monad lam => Sym_Maybe (Repr_Host lam) where
  53         nothing = return Nothing
  54         just    = liftMJoin $ return . Just
  55 instance MonadIO lam => Sym_Maybe_Lam lam (Repr_Host lam) where
  56         maybe n j m = do
  57                 mm <- m
  58                 Maybe.maybe n (\a -> j `app` return a) mm
  59 instance Monad lam => Sym_If (Repr_Host lam) where
  60         if_ m ok ko = do
  61                 m' <- m
  62                 if m' then ok else ko
  63 instance Monad lam => Sym_When (Repr_Host lam) where
  64         when m ok = do
  65                 m' <- m
  66                 Monad.when m' ok
  67 instance Monad lam => Sym_Eq (Repr_Host lam) where
  68         (==) = liftM2 (Prelude.==)
  69 instance Monad lam => Sym_Ord (Repr_Host lam) where
  70         compare = liftM2 Prelude.compare
  71 instance Monad lam => Sym_List (Repr_Host lam) where
  72         list_empty = return []
  73         list_cons  = liftM2 (:)
  74         list       = sequence
  75 instance MonadIO lam => Sym_List_Lam lam (Repr_Host lam) where
  76         list_filter f = liftMJoin go
  77                 where
  78                 go [] = return []
  79                 go (x:xs) = do
  80                         b <- f `app` return x
  81                         (if b then ((x :) <$>) else id)
  82                          (go xs)
  83 instance Monad lam => Sym_Tuple2 (Repr_Host lam) where
  84         tuple2 = liftM2 (,)
  85 instance Monad lam => Sym_Map (Repr_Host lam) where
  86         map_from_list = Prelude.fmap Map.fromList
  87 instance MonadIO lam => Sym_Map_Lam lam (Repr_Host lam) where
  88         map_map f = liftMJoin $ sequence . ((\a -> f `app` return a) <$>)
  89 instance MonadIO lam => Sym_Functor lam (Repr_Host lam) where
  90         fmap f = liftMJoin $ sequence . ((\a -> f `app` return a) <$>)
  91
  92 -- | Helper to store arguments of 'lazy' into an 'IORef'.
  93 lazy_share :: MonadIO m => m a -> m (m a)
  94 lazy_share m = do
  95         r <- liftIO $ newIORef (False, m)
  96         return $ do
  97                 (already_evaluated, m') <- liftIO $ readIORef r
  98                 if already_evaluated
  99                         then m'
 100                         else do
 101                                 v <- m'
 102                                 liftIO $ writeIORef r (True, return v)
 103                                 return v