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