diff --git a/.gitignore b/.gitignore index 5e66a7e..0f676ab 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ dummy.cabal *.tix *.mix hpcreport +dist-newstyle diff --git a/src/Data/Comp/Param/Thunk.hs b/src/Data/Comp/Param/Thunk.hs index b578240..b24d2b9 100644 --- a/src/Data/Comp/Param/Thunk.hs +++ b/src/Data/Comp/Param/Thunk.hs @@ -39,9 +39,10 @@ import Data.Comp.Param.Ops import Data.Comp.Param.Algebra import Data.Comp.Param.Ditraversable import Data.Comp.Param.Difunctor - +import Control.Monad.Fail (MonadFail) import Control.Monad + -- | This type represents terms with thunks. type TermT m f = Term (Thunk m :+: f) @@ -59,19 +60,19 @@ thunk = inject . Thunk -- | This function evaluates all thunks until a non-thunk node is -- found. -whnf :: Monad m => TrmT m f a -> m (Either a (f a (TrmT m f a))) +whnf :: MonadFail m => TrmT m f a -> m (Either a (f a (TrmT m f a))) whnf (In (Inl (Thunk m))) = m >>= whnf whnf (In (Inr t)) = return $ Right t whnf (Var x) = return $ Left x -whnf' :: Monad m => TrmT m f a -> m (TrmT m f a) +whnf' :: MonadFail m => TrmT m f a -> m (TrmT m f a) whnf' = liftM (either Var inject) . whnf -- | This function first evaluates the argument term into whnf via -- 'whnf' and then projects the top-level signature to the desired -- subsignature. Failure to do the projection is signalled as a -- failure in the monad. -whnfPr :: (Monad m, g :<: f) => TrmT m f a -> m (g a (TrmT m f a)) +whnfPr :: (MonadFail m, g :<: f) => TrmT m f a -> m (g a (TrmT m f a)) whnfPr t = do res <- whnf t case res of Left _ -> fail "cannot project variable" @@ -82,35 +83,35 @@ whnfPr t = do res <- whnf t -- | This function evaluates all thunks. -nfT :: (ParamFunctor m, Monad m, Ditraversable f) => TermT m f -> m (Term f) +nfT :: (ParamFunctor m, MonadFail m, Ditraversable f) => TermT m f -> m (Term f) nfT t = termM $ nf $ unTerm t -- | This function evaluates all thunks. -nf :: (Monad m, Ditraversable f) => TrmT m f a -> m (Trm f a) +nf :: (MonadFail m, Ditraversable f) => TrmT m f a -> m (Trm f a) nf = either (return . Var) (liftM In . dimapM nf) <=< whnf -- | This function evaluates all thunks while simultaneously -- projecting the term to a smaller signature. Failure to do the -- projection is signalled as a failure in the monad as in 'whnfPr'. -nfTPr :: (ParamFunctor m, Monad m, Ditraversable g, g :<: f) => TermT m f -> m (Term g) +nfTPr :: (ParamFunctor m, MonadFail m, Ditraversable g, g :<: f) => TermT m f -> m (Term g) nfTPr t = termM $ nfPr $ unTerm t -- | This function evaluates all thunks while simultaneously -- projecting the term to a smaller signature. Failure to do the -- projection is signalled as a failure in the monad as in 'whnfPr'. -nfPr :: (Monad m, Ditraversable g, g :<: f) => TrmT m f a -> m (Trm g a) +nfPr :: (MonadFail m, Ditraversable g, g :<: f) => TrmT m f a -> m (Trm g a) nfPr = liftM In . dimapM nfPr <=< whnfPr -evalStrict :: (Ditraversable g, Monad m, g :<: f) => +evalStrict :: (Ditraversable g, MonadFail m, g :<: f) => (g (TrmT m f a) (f a (TrmT m f a)) -> TrmT m f a) -> g (TrmT m f a) (TrmT m f a) -> TrmT m f a -evalStrict cont t = thunk $ do +evalStrict cont t = thunk $ do t' <- dimapM (liftM (either (const Nothing) Just) . whnf) t case disequence t' of Nothing -> return $ inject' t Just s -> return $ cont s - + -- | This type represents algebras which have terms with thunks as -- carrier. @@ -118,10 +119,10 @@ type AlgT m f g = Alg f (TermT m g) -- | This combinator makes the evaluation of the given functor -- application strict by evaluating all thunks of immediate subterms. -strict :: (f :<: g, Ditraversable f, Monad m) => f a (TrmT m g a) -> TrmT m g a +strict :: (f :<: g, Ditraversable f, MonadFail m) => f a (TrmT m g a) -> TrmT m g a strict x = thunk $ liftM inject $ dimapM whnf' x -- | This combinator makes the evaluation of the given functor -- application strict by evaluating all thunks of immediate subterms. -strict' :: (f :<: g, Ditraversable f, Monad m) => f (TrmT m g a) (TrmT m g a) -> TrmT m g a -strict' = strict . dimap Var id \ No newline at end of file +strict' :: (f :<: g, Ditraversable f, MonadFail m) => f (TrmT m g a) (TrmT m g a) -> TrmT m g a +strict' = strict . dimap Var id