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

module Text.GrammarCombinators.Test.LL1Grammar where

import Generics.MultiRec.FoldAlg
import Language.Haskell.TH.Syntax

import Text.GrammarCombinators.Base

data S = S1 F |
         S2 S S
data F = F3 Char

data SFNode :: * -> * where
  S :: SFNode S
  F :: SFNode F

instance El SFNode S where proof = S
instance El SFNode F where proof = F
                           
instance MemoFam SFNode where
  data Memo SFNode v = MemoPerSFNode (v S) (v F)
  toMemo f = MemoPerSFNode (f S) (f F)
  fromMemo (MemoPerSFNode a b) idx =
    case idx of
      S -> a
      F -> b

instance FoldFam SFNode where
  foldFam f n = f S $ f F n

instance EqFam SFNode where
  overrideIdx f S v S = v
  overrideIdx f F v F = v
  overrideIdx f _ _ idx = f idx

instance ShowFam SFNode where
  showIdx S = "S"
  showIdx F = "F"

instance Domain SFNode

instance (Lift (v S), Lift (v F)) => Lift (Memo SFNode v) where
  lift (MemoPerSFNode a b) = [|MemoPerSFNode $(lift a) $(lift b)|] 

data PFSF r ix where
  PFS1F :: r F -> PFSF r S
  PFS2S :: r S -> r S -> PFSF r S
  PFF :: Char -> PFSF r F

type instance PF SFNode = PFSF

grammar :: ContextFreeGrammar SFNode Char
grammar S =
      epsilon PFS1F >>> ref F
  ||| epsilon PFS2S >>>*
      token '(' >>> ref S >>>* token '+' >>> ref S >>>* token ')'
grammar F = epsilon PFF >>>
            tokenRange ['0'..'9']

data family NodeResult ix
data instance NodeResult S = NRS String
data instance NodeResult F = NRF String

printer :: Processor SFNode NodeResult
printer S (PFS1F (NRF v)) = NRS v
printer S (PFS2S (NRS va) (NRS vb)) = NRS $ "(" ++ va ++ "+" ++ vb ++ ")"
printer F (PFF c) = NRF $ show c