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