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.Foldable as Foldable
  14 import Data.Functor as Functor
  15 import Data.Functor.Identity
  16 import Data.IORef
  17 import Data.Monoid as Monoid
  18 import Data.Traversable as Traversable
  19 import qualified Data.Bool as Bool
  20 import qualified Data.Map.Strict as Map
  21 import qualified Data.Maybe as Maybe
  22 import qualified System.IO as IO
  23
  24 import Language.Symantic.Lib.Control.Monad
  25 import Language.Symantic.Type
  26 import Language.Symantic.Expr hiding (Sym_Monad(..), Sym_Monad_Lam(..))
  27 import qualified Language.Symantic.Expr as Expr
  28
  29 -- * Type 'Repr_Host'
  30
  31 -- | Interpreter's data.
  32 --
  33 -- NOTE: the host-type @h@ is wrapped inside @lam@ to let 'Sym_Lambda'
  34 -- control its callings (see 'inline', 'val', and 'lazy').
  35 newtype Repr_Host lam h
  36  =      Repr_Host
  37  {    unRepr_Host :: lam h }
  38  deriving (Applicative, Functor, Monad, MonadIO)
  39
  40 -- | Interpreter.
  41 host_from_expr :: Repr_Host lam h -> lam h
  42 host_from_expr = unRepr_Host
  43
  44 type instance Lambda_from_Repr (Repr_Host lam) = lam
  45 instance Monad lam => Sym_Lambda_App lam (Repr_Host lam) where
  46         app      = liftM2Join $ \(Lambda f) a -> Repr_Host $ f $ return a
  47 instance Monad lam => Sym_Lambda_Inline lam (Repr_Host lam) where
  48         inline f = return $ Lambda $ unRepr_Host . f . Repr_Host
  49 instance Monad lam => Sym_Lambda_Val lam (Repr_Host lam) where
  50         val    f = return $ Lambda $ (>>= unRepr_Host . f . Repr_Host  . return)
  51 instance MonadIO lam => Sym_Lambda_Lazy lam (Repr_Host lam) where
  52         lazy   f = return $ Lambda $ ((>>= unRepr_Host . f . Repr_Host) . lazy_share)
  53 instance Monad lam => Sym_Bool (Repr_Host lam) where
  54         bool = return
  55         not  = Functor.fmap Bool.not
  56         (&&) = liftM2 (Prelude.&&)
  57         (||) = liftM2 (Prelude.||)
  58 instance Monad lam => Sym_Int (Repr_Host lam) where
  59         int    = return
  60         abs    = Functor.fmap Prelude.abs
  61         negate = Functor.fmap Prelude.negate
  62         (+)    = liftM2 (Prelude.+)
  63         (-)    = liftM2 (Prelude.-)
  64         (*)    = liftM2 (Prelude.*)
  65         mod    = liftM2 Prelude.mod
  66 instance Monad lam => Sym_Text (Repr_Host lam) where
  67         text = return
  68 instance Monad lam => Sym_Maybe (Repr_Host lam) where
  69         nothing = return Nothing
  70         just    = liftMJoin $ return . Just
  71 instance Monad lam => Sym_Maybe_Lam lam (Repr_Host lam) where
  72         maybe n j m = do
  73                 mm <- m
  74                 Maybe.maybe n (\a -> j `app` return a) mm
  75 instance Monad lam => Sym_IO (Repr_Host lam) where
  76         io_hClose   = (IO.hClose Functor.<$>)
  77         io_openFile = liftM2Join $ \f m -> return $ IO.openFile f m
  78 instance Monad lam => Sym_If (Repr_Host lam) where
  79         if_ m ok ko = do
  80                 m' <- m
  81                 if m' then ok else ko
  82 instance Monad lam => Sym_When (Repr_Host lam) where
  83         when m ok = do
  84                 m' <- m
  85                 Monad.when m' ok
  86 instance Monad lam => Sym_Eq (Repr_Host lam) where
  87         (==) = liftM2 (Prelude.==)
  88 instance Monad lam => Sym_Ord (Repr_Host lam) where
  89         compare = liftM2 Prelude.compare
  90 instance Monad lam => Sym_List (Repr_Host lam) where
  91         list_empty = return []
  92         list_cons  = liftM2 (:)
  93         list       = sequence
  94 instance Monad lam => Sym_List_Lam lam (Repr_Host lam) where
  95         list_filter f = liftMJoin go
  96                 where
  97                 go [] = return []
  98                 go (x:xs) = do
  99                         b <- f `app` return x
 100                         (if b then ((x :) Prelude.<$>) else id)
 101                          (go xs)
 102 instance Monad lam => Sym_Tuple2 (Repr_Host lam) where
 103         tuple2 = liftM2 (,)
 104 instance Monad lam => Sym_Map (Repr_Host lam) where
 105         map_from_list = Functor.fmap Map.fromList
 106 instance Monad lam => Sym_Map_Lam lam (Repr_Host lam) where
 107         map_map f = liftMJoin $ sequence . ((\a -> f `app` return a) Prelude.<$>)
 108 instance Sym_Functor Identity (Repr_Host Identity) where
 109         fmap f m = (a2b Functor.<$>) Functor.<$> m
 110                 where a2b a = runIdentity $ unRepr_Host $ f `app` return a
 111         {- NOTE: need Traversable
 112         fmap f = liftMJoin $ sequence . ((\a -> f `app` return a) Functor.<$>)
 113         -}
 114 instance
 115  ( Sym_Applicative_Lam lam (Repr_Host lam)
 116  , Applicative lam
 117  ) => Sym_Applicative (Repr_Host lam) where
 118         pure = Functor.fmap Applicative.pure
 119 instance Sym_Applicative_Lam Identity (Repr_Host Identity) where
 120         (<*>) = liftM2Join $ \fg ->
 121                 return . (Applicative.<*>)
 122                  ((\(Lambda g) -> runIdentity . g . Identity) Functor.<$> fg)
 123         {- NOTE: need Traversable
 124         (<*>) = liftM2Join $ \fg fa ->
 125                 Repr_Host $ sequence $
 126                  (unLambda Functor.<$> fg)
 127                  Applicative.<*>
 128                  (return Functor.<$> fa)
 129         -}
 130 instance Sym_Traversable Identity (Repr_Host Identity) where
 131         traverse ra2fb = liftMJoin $
 132                 return . Traversable.traverse a2fb
 133                 where a2fb a = runIdentity $ unRepr_Host $ ra2fb `app` return a
 134 instance
 135  ( Expr.Sym_Monad_Lam lam (Repr_Host lam)
 136  , Monad lam
 137  ) => Expr.Sym_Monad (Repr_Host lam) where
 138         return = Functor.fmap Monad.return
 139 instance Expr.Sym_Monad_Lam Identity (Repr_Host Identity) where
 140         (>>=) rma ra2mb = do
 141                 ma <- rma
 142                 return $ (Monad.>>=) ma a2mb
 143                 where a2mb a = runIdentity $ unRepr_Host $ ra2mb `app` return a
 144 instance Monad lam => Sym_Either (Repr_Host lam) where
 145         right = Functor.fmap Right
 146         left  = Functor.fmap Left
 147 instance Sym_Monoid (Repr_Host Identity) where
 148         mempty  = return Monoid.mempty
 149         mappend = liftM2Join $ \x y -> return $ Monoid.mappend x y
 150 instance Sym_Foldable (Repr_Host Identity) where
 151         null    = (Foldable.null Functor.<$>)
 152         length  = (Foldable.length Functor.<$>)
 153         minimum = (Foldable.minimum Functor.<$>)
 154         maximum = (Foldable.maximum Functor.<$>)
 155         elem    = liftM2Join $ \a ta -> return $ Foldable.elem a ta
 156 instance Sym_Foldable_Lam Identity (Repr_Host Identity) where
 157         foldMap f = liftMJoin $ return . Foldable.foldMap a2m
 158                 where a2m a = runIdentity $ unRepr_Host $ f `app` return a
 159
 160 -- | Helper to store arguments of 'lazy' into an 'IORef'.
 161 lazy_share :: MonadIO m => m a -> m (m a)
 162 lazy_share m = do
 163         r <- liftIO $ newIORef (False, m)
 164         return $ do
 165                 (already_evaluated, m') <- liftIO $ readIORef r
 166                 if already_evaluated
 167                         then m'
 168                         else do
 169                                 v <- m'
 170                                 liftIO $ writeIORef r (True, return v)
 171                                 return v