{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -- | Interpreter to compute a host-term. module Language.Symantic.Repr.Host where import Control.Monad as Monad import Control.Monad.IO.Class (MonadIO(..)) import Data.IORef import qualified Data.Bool as Bool import qualified Data.Maybe as Maybe import qualified Data.Map.Strict as Map import Language.Symantic.Lib.Control.Monad import Language.Symantic.Expr -- * Type 'Repr_Host' -- | Interpreter's data. -- -- NOTE: the host-type @h@ is wrapped inside @lam@ to let 'Sym_Lambda' -- control its callings (see 'inline', 'val', and 'lazy'). newtype Repr_Host lam h = Repr_Host { unRepr_Host :: lam h } deriving (Applicative, Functor, Monad, MonadIO) -- | Interpreter. host_from_expr :: Repr_Host lam h -> lam h host_from_expr = unRepr_Host instance MonadIO lam => Sym_Lambda lam (Repr_Host lam) where type Lambda_from_Repr (Repr_Host lam) = lam app = liftM2Join $ \f a -> Repr_Host $ f $ return a inline f = return $ unRepr_Host . f . Repr_Host val f = return $ (>>= unRepr_Host . f . Repr_Host . return) lazy f = return $ ((>>= unRepr_Host . f . Repr_Host) . lazy_share) instance Monad lam => Sym_Bool (Repr_Host lam) where bool = return not = Prelude.fmap Bool.not (&&) = liftM2 (Prelude.&&) (||) = liftM2 (Prelude.||) instance Monad lam => Sym_Int (Repr_Host lam) where int = return abs = Prelude.fmap Prelude.abs negate = Prelude.fmap Prelude.negate (+) = liftM2 (Prelude.+) (-) = liftM2 (Prelude.-) (*) = liftM2 (Prelude.*) mod = liftM2 Prelude.mod instance Monad lam => Sym_Maybe (Repr_Host lam) where nothing = return Nothing just = liftMJoin $ return . Just instance MonadIO lam => Sym_Maybe_Lam lam (Repr_Host lam) where maybe n j m = do mm <- m Maybe.maybe n (\a -> j `app` return a) mm instance Monad lam => Sym_If (Repr_Host lam) where if_ m ok ko = do m' <- m if m' then ok else ko instance Monad lam => Sym_When (Repr_Host lam) where when m ok = do m' <- m Monad.when m' ok instance Monad lam => Sym_Eq (Repr_Host lam) where (==) = liftM2 (Prelude.==) instance Monad lam => Sym_Ord (Repr_Host lam) where compare = liftM2 Prelude.compare instance Monad lam => Sym_List (Repr_Host lam) where list_empty = return [] list_cons = liftM2 (:) list = sequence instance MonadIO lam => Sym_List_Lam lam (Repr_Host lam) where list_filter f = liftMJoin go where go [] = return [] go (x:xs) = do b <- f `app` return x (if b then ((x :) <$>) else id) (go xs) instance Monad lam => Sym_Tuple2 (Repr_Host lam) where tuple2 = liftM2 (,) instance Monad lam => Sym_Map (Repr_Host lam) where map_from_list = Prelude.fmap Map.fromList instance MonadIO lam => Sym_Map_Lam lam (Repr_Host lam) where map_map f = liftMJoin $ sequence . ((\a -> f `app` return a) <$>) instance MonadIO lam => Sym_Functor lam (Repr_Host lam) where fmap f = liftMJoin $ sequence . ((\a -> f `app` return a) <$>) -- | Helper to store arguments of 'lazy' into an 'IORef'. lazy_share :: MonadIO m => m a -> m (m a) lazy_share m = do r <- liftIO $ newIORef (False, m) return $ do (already_evaluated, m') <- liftIO $ readIORef r if already_evaluated then m' else do v <- m' liftIO $ writeIORef r (True, return v) return v