TFHOE/Repr/Host.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module TFHOE.Repr.Host where
   6
   7 import Control.Monad.IO.Class (MonadIO(..))
   8 import Data.IORef
   9
  10 import TFHOE.Lib.Control.Monad
  11 import TFHOE.Expr
  12
  13 -- * Type 'Repr_Host'
  14
  15 -- | Host-circular interpreter,
  16 -- producing a host-term of host-type @h@,
  17 -- wrapped inside @fun@ because of 'Expr_Fun'
  18 -- ability to control its callings ('inline', 'val', and 'lazy').
  19 newtype Repr_Host fun h
  20  =      Repr_Host
  21  {    unRepr_Host :: fun h }
  22  deriving (Applicative, Functor, Monad, MonadIO)
  23
  24 instance MonadIO fun => Expr_Fun fun (Repr_Host fun) where
  25         type Fun_from_Repr (Repr_Host fun) = fun
  26         app = liftM2Join $ \f a -> Repr_Host $ f $ return a
  27         inline f = return $ unRepr_Host . f . Repr_Host
  28         val    f = return $ (>>= unRepr_Host . f . Repr_Host . return)
  29         lazy   f = return $ ((>>= unRepr_Host . f . Repr_Host) . expr_fun_lazy_share)
  30 instance Monad repr => Expr_Bool (Repr_Host repr) where
  31         bool = return
  32         neg  = liftMJoin  $ return . not
  33         and  = liftM2Join $ \x y -> return $ x && y
  34         or   = liftM2Join $ \x y -> return $ x || y
  35 instance Monad repr => Expr_Int (Repr_Host repr) where
  36         int = return
  37         add = liftM2Join $ \x y -> return $ x + y
  38 --instance Monad m => Expr_Eq (Host m) where
  39 --      eq = liftM2Join $ \x y -> return $ x == y
  40
  41 host_repr :: Repr_Host repr h -> repr h
  42 host_repr = unRepr_Host
  43
  44 -- | Utility for storing arguments of 'lazy' into an 'IORef'.
  45 expr_fun_lazy_share :: MonadIO m => m a -> m (m a)
  46 expr_fun_lazy_share m = do
  47         r <- liftIO $ newIORef (False, m)
  48         return $ do
  49                 (already_evaluated, m') <- liftIO $ readIORef r
  50                 if already_evaluated
  51                         then m'
  52                         else do
  53                                 v <- m'
  54                                 liftIO $ writeIORef r (True, return v)
  55                                 return v