--
-- TestParsers.hs
--
-- Author: Yoshikuni Jujo <PAF01143@nifty.ne.jp>
--
-- This file is part of mtlparse library
--
-- mtlparse 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 any later version.
--
-- mtlparse is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANGY; 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 this program. If not, see
-- <http://www.gnu.org/licenses/>.

module TestParsers (

  parseA
, parseBegin
, parseEnd
, calc

, runParse
, runParseT

) where

import Text.ParserCombinators.MTLParse
import Data.Char  ( isDigit, isSpace )
import Data.Maybe ( fromMaybe        )

type CharParse   = Parse Char

parseA, parseBegin, parseEnd :: CharParse Char
parseA     = token 'a'
parseBegin = beginningOfInput () >> token 'a'
parseEnd   = token 'a' >>= endOfInput 

-- calculator example

data CalcToken = TkDigit Double | OpStr ( Double -> Double -> Double )
                                | OpWk  ( Double -> Double -> Double )
instance Show CalcToken where
  show ( TkDigit d ) = "TkDigit " ++ show d
  show ( OpStr   _ ) = "OpStr"
  show ( OpWk    _ ) = "OpWk"

isTkDigit, isOpStr, isOpWk :: CalcToken -> Bool
getTkDigit                 :: CalcToken -> Double
isTkDigit  ( TkDigit _ ) = True
isTkDigit            _   = False
isOpStr    ( OpStr   _ ) = True
isOpStr              _   = False
isOpWk     ( OpWk    _ ) = True
isOpWk               _   = False
getTkDigit ( TkDigit d ) = d
getTkDigit           _   = error "This CalcToken is not TkDigit"

opTable :: [ ( Char, Double -> Double -> Double ) ]
opTable =  [ ( '+', (+) ) , ( '-', (-) ) , ( '*', (*) ) , ( '/', (/) ) ]

digitLex :: CharParse CalcToken
digitLex = do
  sign     <- optional                $ token '-' `mplus` token '+'
  digits   <- neList                  $ spot isDigit
  decPlace <- liftM concat . optional $ token '.' >:> list (spot isDigit)
  parseNot () $ spot isDigit `mplus` token '.'
  return . TkDigit . read $ sign ++ digits ++ decPlace

operatorLex :: CharParse CalcToken
operatorLex = liftM (OpWk  . getFun) (spot $ flip elem "+-") `mplus`
              liftM (OpStr . getFun) (spot $ flip elem "*/")
  where
  getFun   c = fromMaybe (notOpErr c) $ lookup c opTable
  notOpErr c = error $ "Operators are `+', `-', `*' or `/': `" ++ [ c ] ++
                       "is not."

calcLex :: CharParse [ CalcToken ]
calcLex = neList ( list (spot isSpace) >> digitLex `mplus` operatorLex )
            >>= endOfInput
  
digitP :: Parse CalcToken Double
digitP = spot isTkDigit `build` getTkDigit

calcP :: Parse CalcToken Double
calcP = apply2M ( flip ($) ) strongOpP calcPTail

calcPTail :: Parse CalcToken (Double -> Double)
calcPTail = return id `mplus` ( do
  OpWk op <- spot isOpWk
  d       <- strongOpP
  f       <- calcPTail
  return $ f . (`op` d) )

strongOpP :: Parse CalcToken Double
strongOpP = apply2M ( flip ($) ) digitP strongOpPTail

strongOpPTail :: Parse CalcToken (Double -> Double)
strongOpPTail = return id `mplus` ( do
  OpStr op <- spot isOpStr
  d        <- digitP
  f        <- strongOpPTail
  return $ f . (`op` d) )

calc :: String -> Double
calc = fst . head . runParse (calcP >>= endOfInput) . (,) [] .
       fst . head . runParse calcLex                . (,) ""