{-  Copyright 2010 Dominique Devriese

    This file is part of the grammar-combinators library.

    The grammar-combinators library is free software: you can
    redistribute it and/or modify it under the terms of the GNU
    Lesser General Public License as published by the Free
    Software Foundation, either version 3 of the License, or (at
    your option) any later version.

    Foobar is distributed in the hope that it will be useful, but
    WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General
    Public License along with Foobar. If not, see
    <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Text.GrammarCombinators.Test.LexedExprs where

import Generics.MultiRec.FoldAlg

import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Parser.RecursiveDescent
import Text.GrammarCombinators.Transform.FoldLoops
import Text.GrammarCombinators.Parser.Packrat
import Text.GrammarCombinators.Test.Lexer

data AdditiveExpr = Addition MultiplicativeExpr AdditiveExpr |
                    Subtraction MultiplicativeExpr AdditiveExpr | 
                    SingleAddExpr MultiplicativeExpr deriving (Show, Eq)
data MultiplicativeExpr = Multiplication PrimaryExpr MultiplicativeExpr |
                          Division PrimaryExpr MultiplicativeExpr |
                          SingleMultExpr PrimaryExpr deriving (Show, Eq)
data PrimaryExpr = ParenthesizedExpr AdditiveExpr |
                   PrimaryLiteral LiteralInteger deriving (Show, Eq)
data LiteralInteger = MkLiteralInteger Integer deriving (Show, Eq)

data LexedExpr :: * -> * where 
  AdditiveExpr :: LexedExpr AdditiveExpr
  MultiplicativeExpr :: LexedExpr MultiplicativeExpr
  PrimaryExpr :: LexedExpr PrimaryExpr
  LiteralInteger :: LexedExpr LiteralInteger

instance MemoFam LexedExpr where
  data Memo LexedExpr v = LEMemo (v AdditiveExpr) (v MultiplicativeExpr) (v PrimaryExpr) (v LiteralInteger)
  toMemo f = LEMemo (f AdditiveExpr) (f MultiplicativeExpr) (f PrimaryExpr) (f LiteralInteger)
  fromMemo (LEMemo v _ _ _) AdditiveExpr = v
  fromMemo (LEMemo _ v _ _) MultiplicativeExpr = v
  fromMemo (LEMemo _ _ v _) PrimaryExpr = v
  fromMemo (LEMemo _ _ _ v) LiteralInteger = v

instance El LexedExpr AdditiveExpr where proof = AdditiveExpr
instance El LexedExpr MultiplicativeExpr where proof = MultiplicativeExpr
instance El LexedExpr PrimaryExpr where proof = PrimaryExpr
instance El LexedExpr LiteralInteger where proof = LiteralInteger

type PFAST = (I MultiplicativeExpr :*: I AdditiveExpr) :>: AdditiveExpr :+: -- Addition
             (I MultiplicativeExpr :*: I AdditiveExpr) :>: AdditiveExpr :+: -- Subtraction            
              I MultiplicativeExpr :>: AdditiveExpr :+: -- SingleAddExpr
             (I PrimaryExpr :*: I MultiplicativeExpr) :>: MultiplicativeExpr :+: -- Multiplication
             (I PrimaryExpr :*: I MultiplicativeExpr) :>: MultiplicativeExpr :+: -- Division
             I PrimaryExpr :>: MultiplicativeExpr :+: -- SingleMultExpr
             I AdditiveExpr :>: PrimaryExpr :+: -- ParenthesizedExpr
             I LiteralInteger :>: PrimaryExpr :+: -- PrimaryLiteralInteger
             K Integer :>: LiteralInteger -- LiteralInteger

type instance PF LexedExpr = PFAST

lexedGram :: ContextFreeGrammar LexedExpr CalcTokenT
lexedGram AdditiveExpr =
      epsilon (\vl vr -> L (Tag (I vl :*: I vr))) >>>
      ref MultiplicativeExpr >>>*
      token PLUS_T >>>
      ref AdditiveExpr
  ||| epsilon (\vl vr -> R (L (Tag (I vl :*: I vr)))) >>>
      ref MultiplicativeExpr >>>*
      token MINUS_T >>>
      ref AdditiveExpr
  ||| epsilon (R . R . L . Tag . I) >>>
      ref MultiplicativeExpr

lexedGram MultiplicativeExpr =
      epsilon (\vl vr -> R (R (R (L (Tag (I vl :*: I vr)))))) >>>
      ref PrimaryExpr >>>*
      token TIMES_T >>>
      ref MultiplicativeExpr
  ||| epsilon (\vl vr -> R (R (R (R (L (Tag (I vl :*: I vr))))))) >>>
      ref PrimaryExpr >>>*
      token DIVIDE_T >>>
      ref MultiplicativeExpr
  ||| epsilon (R . R . R . R . R . L . Tag . I) >>>
      ref PrimaryExpr

lexedGram PrimaryExpr =
      epsilon (R . R . R . R . R . R . L . Tag . I) >>>*
      token OPAREN_T >>>
      ref AdditiveExpr >>>*
      token CPAREN_T
  ||| epsilon (R . R . R . R . R . R . R . L . Tag . I) >>>
      ref LiteralInteger 
lexedGram LiteralInteger =
  epsilon (\(INTEGER v) -> R (R (R (R (R (R (R (R (Tag (K v)))))))))) >>>
  token INT_T

data family NodeValue ix
data instance NodeValue AdditiveExpr = NVA Integer deriving (Show, Eq)
data instance NodeValue MultiplicativeExpr = NVM Integer deriving (Show, Eq)
data instance NodeValue PrimaryExpr = NVP Integer deriving (Show, Eq)
data instance NodeValue LiteralInteger = NVD Integer deriving (Show, Eq)

calcAlg :: Algebra LexedExpr NodeValue
calcAlg = const ( (\(NVM a) (NVA b) -> NVA (a+b))
                & (\(NVM a) (NVA b) -> NVA (a-b)) 
                & (\(NVM a) -> NVA a)
                & (\(NVP a) (NVM b) -> NVM (a*b))
                & (\(NVP a) (NVM b) -> NVM (a `div` b))
                & (\(NVP a) -> NVM a)
                & (\(NVA a) -> NVP a)
                & (\(NVD a) -> NVP a)
                & NVD)

evaluator :: LexedExpr ix -> PFAST NodeValue ix -> NodeValue ix 
evaluator = alg . calcAlg
test1 = "((22-8)/2)*(1+6)-7"

rdTokenize :: String -> [CalcToken]
rdTokenize s = case rdLex s of (Just (FLBV v)) -> unCTVL v
prTokenize :: String -> [CalcToken]
prTokenize s = case prLex s of (Parsed (FLBV v) _) -> unCTVL v

evalgram :: ProcessingContextFreeGrammar LexedExpr CalcTokenT NodeValue
evalgram = applyProcessor lexedGram evaluator

rdTest1 = parseRecDec evalgram AdditiveExpr $ rdTokenize test1
crdTest1 = parseRecDec evalgram AdditiveExpr $ prTokenize test1
prTest1 = parsePackrat evalgram AdditiveExpr $ prTokenize test1
cprTest1 = parsePackrat evalgram AdditiveExpr $ rdTokenize test1