-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me project team. This file is distributed under 
-- the terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- This module defines the parsing (2nd) phase of the assessment pipeline.
-- The only function you should need is `parseMath`.
--
-----------------------------------------------------------------------------

module Recognize.Parsing.MathParser 
   ( MParser, parseMath, parseSimple', expr
   ) where

import Control.Monad
import Data.Char
import Data.Either
import Data.List
import Data.Maybe
import Domain.Math.Data.Relation
import Domain.Math.Expr.Data
import Domain.Math.Expr.Symbols
import Ideas.Common.Rewriting
import Ideas.Common.View
import Ideas.Utils.Parsing
import Prelude hiding ((^))
import Recognize.Data.Math
import Recognize.Data.MathParserOptions
import Recognize.Expr.Functions
import Recognize.Expr.Normalform
import Text.Parsec (Parsec)
import Util.String

type MParser = Parsec String MathParserOptions

-- | Parses a string and return a list of `Math` objects together with a boolean denoting the usage of chained equations.
parseMath :: MathParserOptions -> String -> (Bool, [Math])
parseMath opts s =
   case parseSimple' opts (many1 chainedEquations) s of
      Left msg -> (False, [ M s (Left (MathParseError msg)) ])
      Right xs -> let (bs,ys) = unzip xs
                  in (or bs, [ M s (Right x) | x <- concat ys ])

-- | Attempts to parse a set of expressions that form a chained equation (x = y = z = ..)
--
-- If successful, True is returned together with the list of parsed expressions

-- Otherwise, False is returned with an empty list.
chainedEquations :: MParser (Bool, [Expr])
chainedEquations = expr >>= chainedEquations' False

chainedEquations' :: Bool -> Expr -> MParser (Bool, [Expr])
chainedEquations' alreadyChained x = do
     -- decide on the relation type
     rel <- choice [notEqual, equal, lessThanOrEqualTo, lessThan, greaterThanOrEqualTo, greaterThan]
     -- parse a new expression
     y <- expr
     -- parse the rest of the chained equation
     (gotChained, eqs) <- chainedEquations' True (if isVariable x then x else y)
     -- Sometimes people write chained equations where they simplify an expression and then expand it at the same time.
     -- In that case usually the left most symbol is simplified: (5 + 8 = 13 * 3 = 39 + 4 = ..)
     let y_l = fromMaybe y (getMostLeft y)
     let y' = if nf y_l == nf x && not (isVar y_l) then y_l else y

     return (alreadyChained || gotChained, toExpr (makeType rel x y') : eqs)
    <|>
      return (False, [ x | not alreadyChained ])

equal :: MParser RelationType
equal = EqualTo <$ (
      (try (spstring "==" >> return '=') <|> try (spchar '=' <* spaces <* spchar '=') <|> spchar '=') <* spaces
    )

notEqual :: MParser RelationType
notEqual = NotEqualTo <$ (spstring "/=" <|> spstring "=/=") <* spaces

lessThan :: MParser RelationType
lessThan = LessThan <$ spchar '<' <* spaces

lessThanOrEqualTo :: MParser RelationType
lessThanOrEqualTo = LessThanOrEqualTo <$ spstring "<=" <* spaces

greaterThan :: MParser RelationType
greaterThan = GreaterThan <$ spchar '>' <* spaces

greaterThanOrEqualTo :: MParser RelationType
greaterThanOrEqualTo = GreaterThanOrEqualTo <$ spstring ">=" <* spaces

expr :: MParser Expr
expr = buildExpressionParser exprTable (term <* spaces)

term :: MParser Expr
term = foldl1 (*) <$> factor

factor :: MParser [Expr]
factor = do
   n  <- number
   mx <- optionMaybe factor2
   return (n : fromMaybe [] mx)
 <|> factor2

factor2 :: MParser [Expr]
factor2 = do
   xs <- many1 atom
   mn <- optionMaybe number
   return (xs ++ maybeToList mn)

-- | Parse a single expression
--
-- Does not actually parse every atom (numbers and perhaps more) due to legacy reasons and no time to improve.
atom :: MParser Expr
atom = getState >>= \opts ->
  choice
   [ -- Parse a function call: f(x)
     try $ Sym functionCallSymbol <$> (choice (map spchar (fcallChars opts)) *> parens ((number <|> variable <$> var) `sepBy` (spchar ',' <* spaces)))
   , (\x y -> Sym rootSymbol [x,y]) <$ spstring "root" <* spaces <*> expr <* spaces <*> expr
   , variable <$> var
   , parens (spaces *> expr <* spaces)
   , brackets (spaces *> expr <* spaces)
   , braces (spaces *> expr <* spaces)
   ]
  where
    fcallChars opts = ['f', 'g', 'h', 'F', 'G', 'H'] ++ functionCallWhitelist opts

exprTable :: [[Operator Char MathParserOptions Expr]]
exprTable =
   [ -- precedence level 9+
     [ Prefix (negate <$ spchar '-' <* spaces)
     , Prefix (id     <$ spchar '+' <* spaces)
     ]
   , [ Prefix (Sqrt <$ spstring "sqrt" <* spaces)
     ]
   , -- precedence level 7
     [ Infix ((^) <$ spchar '^' <* spaces) AssocRight
     ]
     -- precedence level 7
   , [ Infix ((*) <$ spchar '*' <* spaces) AssocLeft
  --   , Infix ((*) <$ spchar 'x' <* spaces) AssocLeft -- now done by preprocessing
    --  , Infix ((*) <$ spchar 'X' <* spaces) AssocLeft
     , Infix ((/) <$ spchar '/' <* spaces) AssocLeft
     , Infix ((/) <$ spchar ':' <* spaces) AssocLeft
     ]
     -- precedence level 6
   , [ Infix ((+) <$ spchar '+' <* spaces) AssocLeft
     , Infix ((-) <$ spchar '-' <* spaces) AssocLeft
     , Infix ((-) <$ spchar '–' <* spaces) AssocLeft  -- this is a different minus sign    ( –- )

     ]
   ]

--------------------------------------------------------------------------
-- Lexing

var :: MParser String
var = getState >>= \opts ->
  if multByConcatenation opts
  then try $ do c <- satisfy isAlpha
                when (c `elem` ("fghFGH" ++ functionCallWhitelist opts)) $ notFollowedBy (spchar '(') -- done by preprocessing
                return [c]
  else many1 letter

parens :: MParser a -> MParser a
parens = between (spchar '(') (spchar ')')

brackets :: MParser a -> MParser a
brackets = between (spchar '[') (spchar ']')

braces :: MParser a -> MParser a
braces = between (spchar '{') (spchar '}')

spchar :: Char -> MParser Char
spchar c
   | c == '/'  = try (char c <* notFollowedBy (char '='))
   | otherwise = char c

spstring :: String -> MParser String
spstring s = try (string s)

number :: MParser Expr
number = digitalNumber
     <|> specialNumber

digitalNumber  :: MParser Expr
digitalNumber = do
   xs <- many1 digit
   m  <- optionMaybe (try ((char '.' <|> char ',') *> many1 digit))
   case m of
      Just ys -> return (toExpr (read (xs ++ "." ++ ys) :: Double))
      Nothing -> return (toExpr (read xs :: Int))

specialNumber :: MParser Expr
specialNumber = (1 :/: 2) <$ string "½"
            <|> (3 :/: 4) <$ string "¾"
            <|> (1 :/: 4) <$ string "¼"

-- todo: parse a² and a³

-- | Parse until eof
complete' :: MParser a -> MParser a
complete' p = spaces *> (p <* eof)

parseSimple' :: MathParserOptions -> MParser a -> String -> Either String a
parseSimple' opts p = 
   left show . runParser (complete' p) opts "" . 
   (if convertToLowercase opts then strToLower else id)