content: {-# 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)
  