module Parser (parseExpression) where

import Control.Applicative
import Control.Monad
import Data.Char

import AST
import Utility


parseExpression :: String -> Either String AST
parseExpression s = case parse pexpression s of
    ((node,rest):_) -> case rest of
        "" -> Right node
        _ -> Left $ "Cannot parse from '" ++ take 10 rest ++ "'"
    _ -> Left "No valid parse"


newtype Parser a = Parser (String -> [(a,String)])

parse :: Parser a -> String -> [(a,String)]
parse (Parser p) = p

instance Functor Parser where
    fmap f p = Parser (\cs -> map (\(a,s) -> (f a,s)) $ parse p cs)

instance Applicative Parser where
    pure x = Parser (\cs -> [(x,cs)])
    (<*>) f p = Parser (\cs -> concat $
        map (\(a,s) -> parse (fmap a p) s) $ parse f cs)

instance Monad Parser where
    p >>= f = Parser (\cs -> concat $
        map (\(a,s) -> parse (f a) s) $ parse p cs)

instance Alternative Parser where
    empty = Parser (\_ -> [])
    (<|>) p q = Parser (\cs -> parse p cs ++ parse q cs)

instance MonadPlus Parser


--The deterministic choice operator: choose the first possibile parse (if
--available at all) from the results given by the two parsers.
--mplus is the non-deterministic choice operator; it would give all results.
mplus1 :: Parser a -> Parser a -> Parser a
mplus1 p q = Parser $ \cs -> case parse (mplus p q) cs of
    [] -> []
    (x:_) -> [x]

--(++) = mplus
(+++) :: Parser a -> Parser a -> Parser a
(+++) = mplus1


pitem :: Parser Char
pitem = Parser $ \s -> case s of
    "" -> []
    (c:cs) -> [(c,cs)]

psat :: (Char -> Bool) -> Parser Char
psat f = do
    c <- pitem
    if f c then return c else mzero

--checks that the next char satisfies the predicate; does NOT consume characters
passert :: (Char -> Bool) -> Parser ()
passert p = Parser $ \s -> case s of
    "" -> []
    (c:_) -> if p c then [((),s)] else []

pchar :: Char -> Parser Char
pchar c = psat (==c)

pstring :: String -> Parser String
pstring "" = return ""
pstring (c:cs) = do
    void $ pchar c
    void $ pstring cs
    return (c:cs)

pmany :: Parser a -> Parser [a]
pmany p = pmany1 p +++ return []

pmany1 :: Parser a -> Parser [a]
pmany1 p = do
    a <- p
    as <- pmany p
    return (a:as)

-- pinteger :: Parser Int
-- pinteger = do
--     s <- pmany $ psat isDigit
--     return $ read s

pdouble :: Parser Double
pdouble = Parser reads

poptws :: Parser ()
poptws = void $ Parser $ pure . span isSpace

pword :: Parser String
pword = do
    c <- psat $ options [isAlpha,(=='_')]
    cs <- pmany $ psat $ options [isAlpha,isDigit,(=='_')]
    return (c:cs)


pnumber :: Parser AST
pnumber = liftM Number pdouble

pvariable :: Parser AST
pvariable = liftM Variable $ pstring "PI" +++ (liftM pure (psat isAlpha))

pinfixoperator :: (Char,Char)  -- +/- symbols
               -> Parser AST  -- term parser
               -> ([AST] -> AST)  -- Sum constructor
               -> (AST -> AST)  -- Negative constructor
               -> Bool  -- whether the plus sign is optional
               -> Bool  -- whether a negative sign cannot follow after a term
               -> Parser AST  -- Resulting parser
pinfixoperator (plus,minus) pterm sumconstr negconstr plusopt noneg = do
    term <- pterm
    pmoreterms term +++ return (sumconstr [term])
    where
        pmoreterms term = if plusopt
            then pmoretermsplus term +++ pmoretermsminus term +++ pmoretermsnothing term
            else pmoretermsplus term +++ pmoretermsminus term

        pmoretermsplus term = do
            poptws
            void $ pchar plus
            poptws
            nextterm <- pterm
            let thissum = sumconstr [term,nextterm]
            pmoreterms thissum +++ return thissum
        pmoretermsminus term = do
            poptws
            void $ pchar minus
            poptws
            nextterm <- pterm
            let thissum = sumconstr [term,negconstr nextterm]
            pmoreterms thissum +++ return thissum
        pmoretermsnothing term = do
            poptws
            if noneg then passert (/='-') else return ()
            nextterm <- pterm
            let thissum = sumconstr [term,nextterm]
            pmoreterms thissum +++ return thissum

psum :: Parser AST
psum = do
    poptws
    res <- pinfixoperator ('+','-') pproduct Sum Negative False False
    poptws
    return res

pproduct :: Parser AST
pproduct = pinfixoperator ('*','/') pfactor Product Reciprocal True True

pfactor :: Parser AST
pfactor = pnegative +++ pfactornoneg +++ pcapture +++ pcaptureterm

pnegative :: Parser AST
pnegative = (do
                void $ pchar '-'
                poptws
                f <- pfactor
                return $ Negative f)
        +++ pfactornoneg

pfactornoneg :: Parser AST
pfactornoneg = do
    fact <- pnumber +++ pparenthetical +++ pfunctioncall +++ pvariable
    ppower fact +++ pfactorial fact +++ return fact
    where
        ppower fact = do
            poptws
            void $ pchar '^'
            poptws
            fact2 <- pfactornoneg
            return $ Apply "pow" [fact,fact2]
        pfactorial fact = do
            poptws
            void $ pchar '!'
            return $ Apply "fact" [fact]


pparenthetical :: Parser AST
pparenthetical = do
    void $ pchar '('
    poptws
    s <- psum
    poptws
    void $ pchar ')'
    return s

pfunctioncall :: Parser AST
pfunctioncall = do
    name <- pword
    poptws
    void $ pchar '('
    poptws
    args <- parglist
    poptws
    void $ pchar ')'
    return $ Apply name args
    where
        parglist = do
            arg <- parg
            poptws
            pmoreargs arg +++ return [arg]
        pmoreargs arg = do
            void $ pchar ','
            poptws
            args <- parglist
            return (arg:args)
        parg = pexpression

pcapture :: Parser AST
pcapture = do
    void $ pchar '['
    name <- pmany1 $ psat (/=']')
    void $ pchar ']'
    return $ Capture name

pcaptureterm :: Parser AST
pcaptureterm = do
    void $ pchar '['
    void $ pchar '['
    name <- pmany1 $ psat (/=']')
    void $ pchar ']'
    void $ pchar ']'
    return $ CaptureTerm name

pexpression :: Parser AST
pexpression = psum