Language/Symantic/Repr/Host.hs

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