{-# Language FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}
module Test.Examples where
import Control.Applicative (empty, (<|>))
import Data.Functor.Compose (Compose(..))
import Data.Monoid (Monoid(..), (<>))
import Data.Monoid.Textual (TextualMonoid)
import Text.Parser.Combinators (choice)
import Control.Enumerable (share)
import Test.Feat (Enumerable(..), Enumerate, c0, c1, c2, c3, uniform)
import Test.Feat.Enumerate (pay)
import Test.Feat.Modifiers (Nat(..))
import Test.Tasty.QuickCheck (Arbitrary(..), Gen, Positive(..), Property, testProperty, (===), (==>), (.&&.),
forAll, mapSize, oneof, resize, sized, whenFail)
import Data.Word (Word8)
import qualified Rank2
import Text.Grampa
import Text.Grampa.ContextFree.LeftRecursive (Parser)
import qualified Arithmetic
import qualified Comparisons
import qualified Boolean
import qualified Conditionals
parseArithmetical :: String -> Either String ArithmeticTree
parseArithmetical = uniqueParse (fixGrammar Arithmetic.arithmetic) Arithmetic.expr
parseBoolean :: String -> Either String BooleanTree
parseBoolean = uniqueParse (fixGrammar boolean) (Boolean.expr . Rank2.snd)
comparisons :: (Rank2.Functor g, Lexical g, LexicalConstraint Parser g String) =>
GrammarBuilder ArithmeticComparisons g Parser String
comparisons (Rank2.Pair a c) =
Rank2.Pair (Arithmetic.arithmetic a) (Comparisons.comparisons c){Comparisons.term= Arithmetic.expr a}
boolean :: (Rank2.Functor g, Lexical g, LexicalConstraint Parser g String) =>
GrammarBuilder ArithmeticComparisonsBoolean g Parser String
boolean (Rank2.Pair ac b) = Rank2.Pair (comparisons ac) (Boolean.boolean (Comparisons.test $ Rank2.snd ac) b)
parseConditional :: String -> Either String (ConditionalTree ArithmeticTree)
parseConditional = uniqueParse (fixGrammar conditionals) (Conditionals.expr . Rank2.snd)
conditionals :: (Rank2.Functor g, Lexical g, LexicalConstraint Parser g String) => GrammarBuilder ACBC g Parser String
conditionals (Rank2.Pair acb c) =
boolean acb `Rank2.Pair`
Conditionals.conditionals c{Conditionals.test= Boolean.expr (Rank2.snd acb),
Conditionals.term= Unconditional <$> Arithmetic.expr (Rank2.fst $ Rank2.fst acb)}
type ArithmeticComparisons = Rank2.Product (Arithmetic.Arithmetic ArithmeticTree) (Comparisons.Comparisons ArithmeticTree BooleanTree)
type ArithmeticComparisonsBoolean = Rank2.Product ArithmeticComparisons (Boolean.Boolean BooleanTree)
type ACBC = Rank2.Product ArithmeticComparisonsBoolean (Conditionals.Conditionals BooleanTree
(ConditionalTree ArithmeticTree))
data ArithmeticTree = Number (Nat Int)
| Add ArithmeticTree ArithmeticTree
| Multiply ArithmeticTree ArithmeticTree
| Negate ArithmeticTree
| Subtract ArithmeticTree ArithmeticTree
| Divide ArithmeticTree ArithmeticTree
deriving Eq
data BooleanTree = BooleanConstant Bool
| Comparison ArithmeticTree Relation ArithmeticTree
| Not BooleanTree
| And BooleanTree BooleanTree
| Or BooleanTree BooleanTree
deriving Eq
data ConditionalTree a = If BooleanTree (ConditionalTree a) (ConditionalTree a)
| Unconditional a
deriving Eq
newtype Relation = Relation String deriving Eq
instance Show ArithmeticTree where
showsPrec p (Add l r) rest | p < 1 = showsPrec 0 l (" + " <> showsPrec 1 r rest)
showsPrec p (Subtract l r) rest | p < 1 = showsPrec 0 l (" - " <> showsPrec 1 r rest)
showsPrec p (Negate e) rest | p < 1 = "- " <> showsPrec 1 e rest
showsPrec p (Multiply l r) rest | p < 2 = showsPrec 1 l (" * " <> showsPrec 2 r rest)
showsPrec p (Divide l r) rest | p < 2 = showsPrec 1 l (" / " <> showsPrec 2 r rest)
showsPrec _ (Number (Nat n)) rest = shows n rest
showsPrec p e rest = "(" <> showsPrec 0 e (")" <> rest)
instance Show BooleanTree where
showsPrec p (Or l r) rest | p < 1 = showsPrec 1 l (" || " <> showsPrec 0 r rest)
showsPrec p (And l r) rest | p < 2 = showsPrec 2 l (" && " <> showsPrec 1 r rest)
showsPrec p (Not e) rest | p < 3 = "not " <> showsPrec 3 e rest
showsPrec p (Comparison l rel r) rest | p < 3 = showsPrec 0 l (" " <> show rel <> " " <> showsPrec 0 r rest)
showsPrec _ (BooleanConstant b) rest = shows b rest
showsPrec p e rest = "(" <> showsPrec 0 e (")" <> rest)
instance Show a => Show (ConditionalTree a) where
show (Unconditional a) = show a
show (If test true false) = "if " <> show test <> " then " <> show true <> " else " <> show false
instance Show Relation where
show (Relation rel) = rel
instance Arithmetic.ArithmeticDomain ArithmeticTree where
number = Number . Nat
add = Add
multiply = Multiply
negate = Negate
subtract = Subtract
divide = Divide
instance Boolean.BooleanDomain BooleanTree where
true = BooleanConstant True
false = BooleanConstant False
and = And
or = Or
not = Not
instance Comparisons.ComparisonDomain ArithmeticTree BooleanTree where
lessThan = flip Comparison (Relation "<")
lessOrEqual = flip Comparison (Relation "<=")
equal = flip Comparison (Relation "==")
greaterOrEqual = flip Comparison (Relation ">=")
greaterThan = flip Comparison (Relation ">")
instance Conditionals.ConditionalDomain BooleanTree (ConditionalTree ArithmeticTree) where
ifThenElse = If
instance Arbitrary ArithmeticTree where
arbitrary = sized uniform
instance Arbitrary BooleanTree where
arbitrary = sized uniform
instance Arbitrary (ConditionalTree ArithmeticTree) where
arbitrary = sized uniform
instance Enumerable ArithmeticTree where
enumerate = share (choice $ pay <$> [c1 (Number . (Nat . fromIntegral . nat :: Nat Integer -> Nat Int)),
c2 Add, c2 Multiply, c1 Negate, c2 Subtract, c2 Divide])
instance Enumerable BooleanTree where
enumerate = share $ choice $ pay <$> [c1 BooleanConstant, c3 Comparison, c2 And, c2 Or]
instance Enumerable a => Enumerable (ConditionalTree a) where
enumerate = share (pay $ c3 $ \test true false-> If test (Unconditional true) (Unconditional false))
instance Enumerable Relation where
enumerate = share (choice $ pay . pure . Relation <$> ["<", "<=", "==", ">=", ">"])
uniqueParse :: (Eq s, TextualMonoid s, Rank2.Apply g, Rank2.Traversable g, Rank2.Distributive g) =>
Grammar g Parser s -> (forall f. g f -> f r) -> s -> Either String r
uniqueParse g p s = case getCompose (p $ parseComplete g s)
of Right [r] -> Right r
Right [] -> Left "Unparseable"
Right _ -> Left "Ambiguous"
Left err -> Left (showFailure s err 3)
instance Lexical ArithmeticComparisons
instance Lexical ArithmeticComparisonsBoolean
instance Lexical ACBC