free-applicative-t-0.1.0.0: test/Expr.hs

{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
module Expr(Expr(), genVar, appE, (|<$>|), (|<*>|)) where

import Control.Applicative (liftA2)

import Hedgehog ( Gen )
import qualified Hedgehog.Gen as Gen
import Hedgehog.Range ( exponential )

-- Expression
data E = V Int | A E E
    deriving (Eq, Ord)

newtype Expr a = MkExpr E
    deriving (Eq, Ord)

genVar :: Gen (Expr a)
genVar = MkExpr . V <$> Gen.prune (Gen.integral (exponential 0 1000000))

appE :: Expr (a -> b) -> Expr a -> Expr b
appE (MkExpr e1) (MkExpr e2) = MkExpr (A e1 e2)

infixl 9 `appE`

(|<$>|) :: Functor g => Expr (a -> b) -> g (Expr a) -> g (Expr b)
x |<$>| y = fmap (appE x) y

infixl 4 |<$>|

(|<*>|) :: Applicative g => g (Expr (a -> b)) -> g (Expr a) -> g (Expr b)
(|<*>|) = liftA2 appE

infixl 4 |<*>|

instance Show (Expr a) where
    showsPrec p (MkExpr e) = prettyE p e

prettyE :: Int -> E -> ShowS
prettyE _ (V n) = shows n
prettyE p (A e1 e2) = showParen (p > 10) (prettyE 10 e1 . (' ':) . prettyE 11 e2)