-----------------------------------------------------------------------------
-- Copyright 2019, Ideas 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)
--
-----------------------------------------------------------------------------

{-# LANGUAGE FlexibleContexts #-}

module Domain.Math.Expr.Parser
   ( parseExpr, parseExprM, pExpr, pRelExpr
   , parseEqExpr, parseBoolEqExpr, parseRelExpr
   , parseOrsEqExpr, parseOrsRelExpr
   , parseLogicRelExpr
   , parseExprTuple
   ) where

import Control.Monad
import Data.Monoid
import Domain.Logic.Formula (Logic, catLogic)
import Domain.Math.Data.OrList
import Domain.Math.Data.Relation
import Domain.Math.Data.WithBool
import Domain.Math.Expr.Data
import Domain.Math.Expr.Symbols
import Ideas.Common.Library hiding (many, many1, try, ors, choice)
import Ideas.Utils.Parsing
import Prelude hiding ((^))
import qualified Text.ParserCombinators.Parsec.Token as P

pExpr :: Parser Expr
pExpr = expr

pRelExpr :: Parser (Relation Expr)
pRelExpr = relation expr

parseExpr :: String -> Either String Expr
parseExpr = parseSimple expr

parseExprM :: Monad m => String -> m Expr
parseExprM = either fail return . parseExpr

parseEqExpr :: String -> Either String (Equation Expr)
parseEqExpr = parseSimple (equation expr)

parseBoolEqExpr :: String -> Either String (WithBool (Equation Expr))
parseBoolEqExpr = parseSimple (boolAtom (equation expr))

parseRelExpr :: String -> Either String (Relation Expr)
parseRelExpr = parseSimple (relation expr)

parseOrsEqExpr :: String -> Either String (OrList (Equation Expr))
parseOrsEqExpr = parseSimple (ors (equation expr))

parseOrsRelExpr :: String -> Either String (OrList (Relation Expr))
parseOrsRelExpr = parseSimple (ors (relation expr))

parseLogicRelExpr :: String -> Either String (Logic (Relation Expr))
parseLogicRelExpr = parseSimple (catLogic <$> logic (relationChain expr))

parseExprTuple :: String -> Either String [Expr]
parseExprTuple = parseSimple (tuple expr)

ors :: Parser a -> Parser (OrList a)
ors p = mconcat <$> sepBy1 (boolAtom p) (reserved "or")

logic :: Parser a -> Parser (Logic a)
logic p = buildExpressionParser table (boolAtom p)
 where
   table =
      [ [Infix ((<&&>) <$ reservedOp "and") AssocRight]
      , [Infix ((<||>) <$ reservedOp "or" ) AssocRight]
      ]

boolAtom :: (Container f, BoolValue (f a)) => Parser a -> Parser (f a)
boolAtom p = choice
   [ true      <$  reserved "true"
   , false     <$  reserved "false"
   , singleton <$> p
   ]

equation :: Parser a -> Parser (Equation a)
equation p = (:==:) <$> p <* reservedOp "==" <*> p

relation :: Parser a -> Parser (Relation a)
relation p = p <**> relType <*> p

relationChain :: Parser a -> Parser (Logic (Relation a))
relationChain p = (\x -> ands . make x) <$> p <*> many1 ((,) <$> relType <*> p)
 where
   make _ []             = []
   make a ((f, b): rest) = singleton (f a b) : make b rest

relType :: Parser (a -> a -> Relation a)
relType = choice (map make table)
 where
   make (s, f) = f <$ reservedOp s
   table =
      [ ("==", (.==.)), ("/=", (./=.))
      , ("<=", (.<=.)), (">=", (.>=.))
      , ("<", (.<.)), (">", (.>.)), ("~=", (.~=.))
      ]

tuple :: Parser a -> Parser [a]
tuple p = parens (sepBy p comma)

expr :: Parser Expr
expr = buildExpressionParser exprTable term

term :: Parser Expr
term = choice
   [ sqrt <$ reserved "sqrt" <*> atom
   , binary rootSymbol <$ reserved "root" <*> atom <*> atom
   , binary logSymbol  <$ reserved "log"  <*> atom <*> atom
   , unary  sinSymbol  <$ reserved "sin"  <*> atom
   , unary  cosSymbol  <$ reserved "cos"  <*> atom
   , do reserved "D"
        x <- identifier <|> parens identifier
        a <- atom
        return $ unary diffSymbol (binary lambdaSymbol (Var x) a)
   , do a  <- qualId
        as <- many atom
        return (function (newSymbol a) as)
   , atom
   ]

pmixed :: Parser Expr
pmixed = do
   a      <- natural
   P.brackets lexer $ do
      b <- natural
      reservedOp "/"
      c <- natural
      return $ mixed a b c

atom :: Parser Expr
atom = choice
   [ try pmixed
   , do notFollowedBy (char '-')
        either fromInteger fromDouble <$> naturalOrFloat
   , variable <$> identifier
   , pi <$ reserved "pi"
   , parens expr
   ]

exprTable :: [[Operator Char () Expr]]
exprTable =
   [ -- precedence level 7
     [ Infix ((^) <$ reservedOp "^") AssocRight
     ]
     -- precedence level 7
   , [ Infix ((*) <$ reservedOp "*") AssocLeft
     , Infix ((/) <$ reservedOp "/") AssocLeft
     ]
     -- precedence level 6+
   , [ Prefix (negate <$ reservedOp "-")
     ]
     -- precedence level 6
   , [ Infix ((+) <$ reservedOp "+") AssocLeft
     , Infix ((-) <$ reservedOp "-") AssocLeft
     ]
   ]

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

lexer :: P.TokenParser a
lexer = P.makeTokenParser $ emptyDef
   { reservedNames   = [ "sqrt", "root", "log", "and", "or", "true", "false", "D"
                       , "sin", "cos", "pi" ]
   , reservedOpNames = ["==", "/=", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"]
   , opStart         =  oneOf ":!#$%&*+./<=>?@\\^|-~"
   , opLetter        =  oneOf ":!#$%&*+./<=>?@\\^|-~"
   }

identifier :: Parser String
identifier = P.identifier lexer

qualId :: CharParser st Id
qualId = try (P.lexeme lexer (do
   xs <- idPart `sepBy1` char '.'
   guard (length xs > 1)
   return (mconcat (map newId xs)))
 <?> "qualified identifier")
 where
   idPart   = (:) <$> letter <*> many idLetter
   idLetter = alphaNum <|> oneOf "-_"

natural :: Parser Integer
natural = P.natural lexer

reserved :: String -> Parser ()
reserved = P.reserved lexer

reservedOp :: String -> Parser ()
reservedOp = P.reservedOp lexer

comma :: Parser String
comma = P.comma lexer

parens :: Parser a -> Parser a
parens = P.parens lexer

-----------------------------------------------------------------------
-- Argument descriptor (for parameterized rules)

instance Read Expr where
   readsPrec _ input =
      case parseExpr input of
         Left _  -> []
         Right a -> [(a, "")]

instance Reference Expr