{-  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 RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}

module Text.GrammarCombinators.Test.Grammar where

import Text.GrammarCombinators.Base

import Data.Enumerable
import Data.Char
import Language.Haskell.TH.Syntax 

data ASTToken = DIGIT | OPAREN | CPAREN | PLUS | TIMES deriving (Show, Eq, Ord)
instance Lift ASTToken where
  lift DIGIT = [| DIGIT |]
  lift OPAREN = [| OPAREN |]
  lift CPAREN = [| CPAREN |]
  lift PLUS = [| PLUS |]
  lift TIMES = [| TIMES |]
instance Enumerable ASTToken where
  enumerate = [DIGIT, OPAREN, CPAREN, PLUS, TIMES] 
instance Token ASTToken where
  type ConcreteToken ASTToken = Char
  classify c | isDigit c = DIGIT
  classify '(' = OPAREN
  classify ')' = CPAREN
  classify '+' = PLUS
  classify '*' = TIMES
  enumConcreteTokens DIGIT = ['0'..'9']
  enumConcreteTokens OPAREN = "("
  enumConcreteTokens CPAREN = ")"
  enumConcreteTokens PLUS = "+"
  enumConcreteTokens TIMES = "*"
  

data AdditiveExpr = Addition MultiplicativeExpr AdditiveExpr |
                    SingleAddExpr MultiplicativeExpr deriving (Show, Eq)
data MultiplicativeExpr = Multiplication PrimaryExpr MultiplicativeExpr |
                          SingleMultExpr PrimaryExpr deriving (Show, Eq)
data PrimaryExpr = ParenthesizedExpr AdditiveExpr |
                   PrimaryDecimal Decimal deriving (Show, Eq)
data Decimal = MkDecimal Char deriving (Show, Eq)

data ASTNode :: * -> * where 
  AdditiveExpr :: ASTNode AdditiveExpr
  MultiplicativeExpr :: ASTNode MultiplicativeExpr
  PrimaryExpr :: ASTNode PrimaryExpr
  Decimal :: ASTNode Decimal

instance FoldFam ASTNode where
  foldFam f n = f Decimal $ f PrimaryExpr $ f MultiplicativeExpr $ f AdditiveExpr n

instance ShowFam ASTNode where
  showIdx AdditiveExpr = "AdditiveExpr"
  showIdx MultiplicativeExpr = "MultiplicativeExpr"
  showIdx PrimaryExpr = "PrimaryExpr"
  showIdx Decimal = "Decimal"

instance EqFam ASTNode where
  overrideIdx _ AdditiveExpr v AdditiveExpr = v
  overrideIdx _ MultiplicativeExpr v MultiplicativeExpr = v
  overrideIdx _ PrimaryExpr v PrimaryExpr = v
  overrideIdx _ Decimal v Decimal = v
  overrideIdx f _ _ idx = f idx

instance Domain ASTNode

instance El ASTNode AdditiveExpr where proof = AdditiveExpr
instance El ASTNode MultiplicativeExpr where proof = MultiplicativeExpr
instance El ASTNode PrimaryExpr where proof = PrimaryExpr
instance El ASTNode Decimal where proof = Decimal

type PFAST = (I MultiplicativeExpr :*: I AdditiveExpr) :>: AdditiveExpr :+: -- Addition
             I MultiplicativeExpr :>: AdditiveExpr :+: -- SingleAddExpr
             (I PrimaryExpr :*: I MultiplicativeExpr) :>: MultiplicativeExpr :+: -- Multiplication
             I PrimaryExpr :>: MultiplicativeExpr :+: -- SingleMultExpr
             I AdditiveExpr :>: PrimaryExpr :+: -- ParenthesizedExpr
             I Decimal :>: PrimaryExpr :+: -- PrimaryDecimal
             K Char :>: Decimal -- Decimal

type instance PF ASTNode = PFAST

grammar :: ContextFreeGrammar ASTNode ASTToken
grammar AdditiveExpr =
      (\vl vr -> L (Tag (I vl :*: I vr))) $>>
      ref MultiplicativeExpr >>>*
      token PLUS >>>
      ref AdditiveExpr
  ||| (R . L . Tag . I) $>>
      ref MultiplicativeExpr

grammar MultiplicativeExpr =
      (\vl vr -> R (R (L (Tag (I vl :*: I vr))))) $>>
      ref PrimaryExpr >>>*
      token TIMES >>>
      ref MultiplicativeExpr
  ||| (R . R . R . L . Tag . I) $>>
      ref PrimaryExpr

grammar PrimaryExpr =
      (R . R . R . R . L . Tag . I) $>>*
      token OPAREN >>>
      ref AdditiveExpr >>>*
      token CPAREN
  ||| (R . R . R . R . R . L . Tag . I) $>>
      ref Decimal
grammar Decimal =
  (R . R . R . R . R . R . Tag . K) $>> token DIGIT

testFun :: forall ix. ASTNode ix -> Int
testFun AdditiveExpr = 0
testFun MultiplicativeExpr = 1
testFun PrimaryExpr = 2
testFun Decimal = 3

instance MemoFam ASTNode where
  data Memo ASTNode v = MemoPerASTNode (v AdditiveExpr) (v MultiplicativeExpr) (v PrimaryExpr) (v Decimal)
  toMemo f = MemoPerASTNode (f AdditiveExpr) (f MultiplicativeExpr)
               (f PrimaryExpr) (f Decimal)
  fromMemo (MemoPerASTNode v _ _ _) AdditiveExpr = v
  fromMemo (MemoPerASTNode _ v _ _) MultiplicativeExpr = v
  fromMemo (MemoPerASTNode _ _ v _) PrimaryExpr = v
  fromMemo (MemoPerASTNode _ _ _ v) Decimal = v