{-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}
module Test.Examples where

import Control.Applicative (empty, liftA2, liftA3, (<|>))
import Data.Functor.Compose (Compose(..))
import Data.Monoid (Monoid(..), (<>))
import Data.Monoid.Textual (TextualMonoid, toString)
import Text.Parser.Combinators (choice)

import Test.Tasty.QuickCheck (Arbitrary(..), Gen, NonNegative(..), Property, testProperty, (===), (==>), (.&&.),
                              elements, forAll, mapSize, oneof, resize, sized, whenFail)
import Data.Word (Word8)

import qualified Rank2
import Text.Grampa
import Text.Grampa.ContextFree.SortedMemoizing.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, LexicalParsing (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, LexicalParsing (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, LexicalParsing (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 (NonNegative 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 (NonNegative 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 . NonNegative
   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 tree
     where tree n | n < 1 = Number <$> arbitrary
                  | otherwise = oneof [Number <$> arbitrary,
                                       Negate <$> tree (n - 1),
                                       liftA2 Add branch branch,
                                       liftA2 Multiply branch branch,
                                       liftA2 Subtract branch branch,
                                       liftA2 Divide branch branch]
             where branch = tree (n `div` 2)

instance Arbitrary BooleanTree where
   arbitrary = sized tree
     where tree n | n < 1 = BooleanConstant <$> arbitrary
                  | otherwise = oneof [BooleanConstant <$> resize (n - 1) arbitrary,
                                       Not <$> tree (n - 1),
                                       liftA3 Comparison arbitrary' (elements relations) arbitrary',
                                       liftA2 And branch branch,
                                       liftA2 Or branch branch]
             where branch = tree (n `div` 2)
                   relations = Relation <$> ["<", ">", "==", "<=", ">="]
                   arbitrary' = resize (n `div` 2) arbitrary

instance Arbitrary (ConditionalTree ArithmeticTree) where
   arbitrary = sized tree
     where tree n = oneof [--Unconditional <$> resize (n - 1) arbitrary,
                           liftA3 If (resize (n `div` 3) arbitrary)
                                     (Unconditional <$> resize(n `div` 3) arbitrary)
                                     (Unconditional <$> resize(n `div` 3) arbitrary)]

uniqueParse :: (Ord s, TextualMonoid s, Show r, 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 rs -> Left ("Ambiguous: " ++ show rs)
                       Left err -> Left (toString mempty $ failureDescription s err 3)

instance TokenParsing (Parser ArithmeticComparisons String) where
   token = lexicalToken
instance TokenParsing (Parser ArithmeticComparisonsBoolean String) where
   token = lexicalToken
instance TokenParsing (Parser ACBC String) where
   token = lexicalToken

instance LexicalParsing (Parser ArithmeticComparisons String)
instance LexicalParsing (Parser ArithmeticComparisonsBoolean String)
instance LexicalParsing (Parser ACBC String)