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

module Text.GrammarCombinators.Test.Lexer where

import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Transform.FoldLoops
import Text.GrammarCombinators.Transform.UnfoldLoops
import Text.GrammarCombinators.Transform.UnfoldRecursion
import Text.GrammarCombinators.Transform.UniformPaull
import Text.GrammarCombinators.Parser.RecursiveDescent
import Text.GrammarCombinators.Parser.Packrat
import Text.GrammarCombinators.Utils.PrintGrammar
import Text.GrammarCombinators.Utils.EnumerateGrammar
import Text.GrammarCombinators.Utils.ToGraph
import Text.GrammarCombinators.Utils.IsReachable

import Data.Enumerable

import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Graphviz
import Data.GraphViz hiding (K)

import Generics.MultiRec.FoldAlg

import Control.Concurrent (forkIO)

import Language.Haskell.TH.Syntax (Lift,lift)

data CalcTokenT = INT_T | PLUS_T | MINUS_T | OPAREN_T | CPAREN_T | TIMES_T | DIVIDE_T deriving (Show, Eq, Ord, Enum)

instance Lift (CalcTokenT) where
  lift INT_T = [| INT_T |]
  lift PLUS_T = [| PLUS_T |]
  lift MINUS_T = [| MINUS_T |]
  lift OPAREN_T = [| OPAREN_T |]
  lift CPAREN_T = [| CPAREN_T |]
  lift TIMES_T = [| TIMES_T |]
  lift DIVIDE_T = [| DIVIDE_T |]

data CalcToken =
  INTEGER Integer |
  PLUS |
  MINUS |
  OPAREN |
  CPAREN |
  TIMES |
  DIVIDE
  deriving (Show, Eq)

instance Enumerable CalcTokenT where
  enumerate = [INT_T, PLUS_T, MINUS_T, OPAREN_T, CPAREN_T, TIMES_T, DIVIDE_T]

instance Token CalcTokenT where
  type ConcreteToken CalcTokenT = CalcToken
  classify (INTEGER _) = INT_T
  classify PLUS = PLUS_T
  classify MINUS = MINUS_T
  classify OPAREN = OPAREN_T
  classify CPAREN = CPAREN_T
  classify TIMES = TIMES_T
  classify DIVIDE = DIVIDE_T
  enumConcreteTokens PLUS_T = [PLUS]
  enumConcreteTokens MINUS_T = [MINUS]
  enumConcreteTokens OPAREN_T = [OPAREN]
  enumConcreteTokens CPAREN_T = [CPAREN]
  enumConcreteTokens TIMES_T = [TIMES]
  enumConcreteTokens DIVIDE_T = [DIVIDE]
  enumConcreteTokens INT_T = map INTEGER $ enumFrom 0

data Digit
data CalcTokenList

data CalcTokenDomain :: * -> * where
  CalcTokenList :: CalcTokenDomain CalcTokenList
  CalcToken :: CalcTokenDomain CalcToken
  Digit :: CalcTokenDomain Digit

instance FoldFam CalcTokenDomain where
  foldFam f n =
    f Digit $
    f CalcToken $
    f CalcTokenList n

instance ShowFam CalcTokenDomain where
  showIdx CalcTokenList = "CalcTokenList"
  showIdx CalcToken = "CalcToken"
  showIdx Digit = "Digit"
  
instance EqFam CalcTokenDomain where
  overrideIdx f Digit v Digit = v
  overrideIdx f CalcToken v CalcToken = v
  overrideIdx f CalcTokenList v CalcTokenList = v
  overrideIdx f _ _ idx = f idx

instance El CalcTokenDomain CalcToken where proof = CalcToken
instance El CalcTokenDomain CalcTokenList where proof = CalcTokenList
instance El CalcTokenDomain Digit where proof = Digit

instance MemoFam CalcTokenDomain where
  data Memo CalcTokenDomain v = CTLDMemo (v CalcToken) (v Digit) (v CalcTokenList)
  toMemo f = CTLDMemo (f CalcToken) (f Digit) (f CalcTokenList)
  fromMemo (CTLDMemo v _ _) CalcToken = v
  fromMemo (CTLDMemo _ v _) Digit = v
  fromMemo (CTLDMemo _ _ v) CalcTokenList = v

instance Domain CalcTokenDomain

instance (Lift (v CalcToken), Lift (v Digit), Lift (v CalcTokenList)) => Lift (Memo CalcTokenDomain v) where
  lift (CTLDMemo v1 v2 v3) = [|CTLDMemo $(lift v1) $(lift v2) $(lift v3)|]

type PFCTL = K CalcToken :>: CalcToken :+: -- basic token
             IL Digit :>: CalcToken :+: -- integer token
             K Char :>: Digit :+:
             IL CalcToken :>: CalcTokenList

type instance PF CalcTokenDomain = PFCTL

ctgram :: ExtendedContextFreeGrammar CalcTokenDomain Char 
ctgram Digit = epsilon (R . R . L . Tag . K) >>> tokenRange ['0'..'9']
ctgram CalcTokenList = epsilon (R . R . R . Tag . IL) >>> manyRef CalcToken >>>* endOfInput
ctgram CalcToken =
  let
    plusToken = epsilon PLUS >>>* token '+'
    minusToken = epsilon MINUS >>>* token '-'
    timesToken = epsilon TIMES >>>* token '*'
    divideToken = epsilon DIVIDE >>>* token '/'
    oparenToken = epsilon OPAREN >>>* token '('
    cparenToken = epsilon CPAREN >>>* token ')'
  in     epsilon (R . L . Tag . IL) >>>
         many1Ref Digit
     ||| epsilon (L . Tag . K) >>>
         (plusToken |||
          minusToken |||
          timesToken |||
          divideToken |||
          oparenToken |||
          cparenToken)

data family CTV ix
data instance CTV CalcToken = CTVC { unCTVC :: CalcToken } deriving (Show)
data instance CTV Digit = CTVD { unCTVD :: Char } deriving (Show)
data instance CTV CalcTokenList = CTVL { unCTVL :: [CalcToken] } deriving (Show)

ctproc :: GProcessor CalcTokenDomain CTV (PFCTL CTV)
ctproc CalcToken (L (Tag (K t))) = CTVC t
ctproc CalcToken (R (L (Tag (IL is)))) = CTVC $ INTEGER $ read $ map unCTVD is
ctproc Digit (R (R (L (Tag (K c))))) = CTVD c
ctproc CalcTokenList (R (R (R (Tag (IL l))))) = CTVL $ map unCTVC l


lg :: GContextFreeGrammar (FoldLoopsDomain CalcTokenDomain) Char (FoldLoopsValue r) (FoldLoopsResultValue r (PF CalcTokenDomain r))
lg = foldLoops ctgram

plg :: ProcessingContextFreeGrammar (FoldLoopsDomain CalcTokenDomain) Char (FoldLoopsValue CTV) 
plg = applyProcessor lg (processFoldLoops ctproc)

prLex :: String -> Result (FoldLoopsDomain CalcTokenDomain) (FoldLoopsValue CTV) Char (FoldLoopsValue CTV (FLBaseIx CalcTokenList))
prLex = parsePackrat plg $ FLBase CalcTokenList
rdLex :: String -> Maybe (FoldLoopsValue CTV (FLBaseIx CalcTokenList))
rdLex = parseRecDec plg $ FLBase CalcTokenList

grams = putStr $ printGrammar lg 
gramsReachable = putStr $ printReachableGrammar lg (FLBase CalcTokenList) 
depth = 11
gramsinf = putStr $ printGrammarInf (unfoldLoops ctgram) depth

testGraph d idx = graphToGraphviz $ ruleToGraph d lg idx
testGraphInf d idx = graphToGraphviz $ ruleToGraph d (unfoldLoops ctgram) idx
testGramGraph d = graphToGraphviz $ reachableGrammarToGraph d lg (FLBase CalcTokenList)
testTransformedGramGraph d = graphToGraphviz $ reachableGrammarToGraph d (transformUniformPaull plg) (UPBase $ FLBase CalcTokenList)