Thunk.hs

{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, DeriveFunctor,
  FlexibleInstances, FlexibleContexts, UndecidableInstances, ConstraintKinds,
  CPP #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Examples.Thunk
-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
-- License     :  BSD3
-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- This example illustrates how the ''Data.Comp.Thunk'' package can be
-- used to implement a non-strict language (or a partially non-strict
-- language).
--
--------------------------------------------------------------------------------

module Examples.Thunk where

import Data.Comp
import Data.Comp.Thunk
import Data.Comp.Derive
import Data.Comp.Show()
import Examples.Common hiding (Value(..), Sig, iConst, iPair)

-- Control.Monad.Fail import is redundant since GHC 8.8.1
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail
#endif

-- Signature for values, strict pairs
data Value a = Const Int | Pair !a !a deriving Functor

-- Signature for the simple expression language
type Sig = Op :+: Value

-- Derive boilerplate code using Template Haskell
$(derive [makeTraversable, makeFoldable,
          makeEqF, makeShowF, smartConstructors, makeHaskellStrict]
         [''Value])

-- Monadic term evaluation algebra
class EvalT f m v where
  evalAlgT :: MonadFail m => AlgT m f v

$(derive [liftSum] [''EvalT])

-- Lift the monadic evaluation algebra to a monadic catamorphism
evalT :: (Traversable v, Functor f, EvalT f m v, MonadFail m) => Term f -> m (Term v)
evalT = nf . cata evalAlgT

instance (Value :<: m :+: v) => EvalT Value m v where
-- make pairs strict in both components
--  evalAlgT x@Pair{} = strict x
-- or explicitly:
--  evalAlgT (Pair x y) = thunk $ liftM2 iPair (dethunk' x) (dethunk' )y
--  evalAlgT x = inject x

-- or only partially strict
  evalAlgT = haskellStrict'

instance (Value :<: m :+: v, Value :<: v) => EvalT Op m v where
  evalAlgT (Add x y) = thunk $ do
                         Const n1 <- whnfPr x
                         Const n2 <- whnfPr y
                         return $ iConst $ n1 + n2
  evalAlgT (Mult x y) = thunk $ do
                          Const n1 <- whnfPr x
                          Const n2 <- whnfPr y
                          return $ iConst $ n1 * n2
  evalAlgT (Fst v)    = thunk $ do 
                          Pair x _  <- whnfPr v
                          return x
  evalAlgT (Snd v)    = thunk $ do 
                          Pair _ y <- whnfPr v
                          return y


instance MonadFail (Either String) where
    fail = Left

evalTEx :: Either String (Term Value)
evalTEx = evalT (iSnd (iFst (iConst 5) `iPair` iConst 4) :: Term Sig)