{-  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 FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}

module Main where

import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances
import Control.Applicative
import Control.Monad
import Generics.MultiRec.Base
import Data.Time.Clock
import System.Environment

import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Transform.UniformPaull
import Text.GrammarCombinators.Transform.FoldLoops
import Text.GrammarCombinators.Transform.UnfoldLoops
import Text.GrammarCombinators.Test.Paper.PaperExample
import Text.GrammarCombinators.Test.Paper.PaperExampleLift
import Text.GrammarCombinators.Parser.UUParse
import Text.GrammarCombinators.Parser.Packrat
import Text.GrammarCombinators.Transform.IntroduceBias
import Text.GrammarCombinators.Parser.Parsec
import Text.GrammarCombinators.Utils.PrintGrammar
import Text.GrammarCombinators.Utils.MemoizeGrammar

teststring 0 = "15"
teststring n = "9*(" ++ teststring (n-1) ++ "+3)+" ++ teststring (n-1)

calcGrammarArith'' :: ProcessingExtendedContextFreeGrammar (UPDomain ArithDomain) Char (UPValue (ArithValue))
calcGrammarArith'' = memoizeGrammarE calcGrammarArith'

parseUUGood test = case unUPBV $ parseUUE calcGrammarArith' (UPBase Line) test of ArithValueL v -> v
parseUUBad test = parse uuline (createStr 0 test)
parseUUCT test = case unUPBV $ parseUUR ctGrammar (UPBase Line) test of ArithValueL v -> v
parsePsCT test = case parseParsecR ctGrammar (UPBase Line) "" test of Right (UPBV (ArithValueL v)) -> v
parsePr test = case parsePackrat (foldAndProcessLoops calcGrammarArith'') (FLBase $ UPBase Line) test of Parsed (FLBV (UPBV (ArithValueL v))) _ -> v
parsePs test = case parseParsec (unfoldLoops calcGrammarArith') (UPBase Line) "" test of Right (UPBV (ArithValueL v)) -> v
parsePsB test = case parseParsecBiased (unfoldLoops calcGrammarArith') (UPBase Line) "" test of Right (UPBV (ArithValueL v)) -> v
parsePsBCT test = case parseParsecR ctGrammarBias (UPBase Line) "" test of Right (UPBV (ArithValueL v)) -> v
parseViaTree test = evalLine $ parse uulineA (createStr 0 test) 

uuline :: P (Str Char [Char] Int) Int
uuline        =    uuexpr <* pEnd
uuexpr        =    foldr ($) <$> uuterm <*> many uuexprTail
uuexprTail    =    (+) <$ pSym '+' <*> uuterm
uuterm        =    foldr ($) <$> uufactor <*> many uutermTail
uutermTail    =    (*) <$ pSym '*' <*> uufactor
uufactor      =    read <$> some uudigit
              <|>  pSym '(' *> uuexpr <* pSym ')'
uudigit :: P (Str Char [Char] Int) Char
uudigit       =    foldr (<|>) empty $ map pSym ['0'..'9']

uulineA :: P (Str Char [Char] Int) Line
uulineA        =    SExpr <$> uuexprA <* pEnd
uuexprA        =    foldr ($) <$> STerm <$> uutermA <*> many uuexprTailA
uuexprTailA    =    flip Sum <$ pSym '+' <*> uutermA
uutermA        =    foldr ($) <$> SFactor <$> uufactorA <*> many uutermTailA
uutermTailA    =    flip Product <$ pSym '*' <*> uufactorA
uufactorA      =    LiteralNumber <$> some uudigitA
               <|>  Paren <$> (pSym '(' *> uuexprA <* pSym ')')
uudigitA :: P (Str Char [Char] Int) Digit
uudigitA       =    MkDigit <$> (foldr (<|>) empty $ map pSym ['0'..'9'])

evalLine :: Line -> Int
evalLine (SExpr expr) = evalExpr expr
evalExpr :: Expr -> Int
evalExpr (Sum expr term) = evalExpr expr + evalTerm term
evalExpr (STerm term) = evalTerm term
evalTerm :: Term -> Int
evalTerm (Product term factor) = evalTerm term * evalFactor factor
evalTerm (SFactor factor) = evalFactor factor
evalFactor :: Factor -> Int
evalFactor (Paren expr) = evalExpr expr
evalFactor (LiteralNumber ds) = read $ map evalDigit ds
evalDigit :: Digit -> Char
evalDigit (MkDigit c) = c

time :: IO a -> IO NominalDiffTime
time cmd = do t1 <- getCurrentTime
              cmd
              t2 <- getCurrentTime
              return $ diffUTCTime t2 t1

timeAndPrint s cmd = do cmd
                        t <- time $ cmd
                        putStr $ s ++ ": " ++ show t ++ "\n"

printRes f s = do putStr $ show $ f s
                  putStr "\n"


main = do args <- getArgs
          let algo = args !! 0
          putStrLn algo
          if algo == "all"
            then testmain
            else do let pa = case algo of
                          "UUGood" -> parseUUGood
                          "UUBad" -> parseUUBad
                          "UUViaTree" -> parseViaTree
                          "Packrat" -> parsePr
                          "Parsec" -> parsePs
                          "ParsecCT" -> parsePs
                          "ParsecBias" -> parsePsB
                          "ParsecBiasCT" -> parsePsBCT
                          "UUCT" -> parseUUCT
                    timeAndPrint algo $ printRes pa $ teststring 10
                    timeAndPrint algo $ interact $ show . pa 

testmain = do args <- getArgs
              putStrLn $ args !! 1
              let n = read $ args !! 1
              testmainN n

testmainN n = do timeAndPrint "UU Bad" $ printRes parseUUBad $ teststring n 
                 timeAndPrint "UU Bad ViaTree" $ printRes parseViaTree $ teststring n 
                 timeAndPrint "Packrat" $ printRes parsePr $ teststring n 
                 timeAndPrint "UU Good" $ printRes parseUUGood $ teststring n 
                 timeAndPrint "UU CT" $ printRes parseUUCT $ teststring n 
                 timeAndPrint "Parsec" $ printRes parsePs $ teststring n 
                 timeAndPrint "Parsec CT" $ printRes parsePsCT $ teststring n 
                 timeAndPrint "Parsec Biased" $ printRes parsePsB $ teststring n 
                 timeAndPrint "Parsec Biased CT" $ printRes parsePsBCT $ teststring n