{-
 - The grammar accepted here is a subset of the Prolog language.  Specifically, the following:
 -
 - program -> statements? End                                       -- the program itself is a series of statements
 - statements -> statement Dot statements?                          -- a statement ends in Dot
 - statement -> structure (ImpliedBy requisites)?                   -- a statement is either in the form of x(...) or x(...) :- y = z, ...
 -            | Query requisites                                    -- or x(...) :- y(...) or ?- x = y, ... etc
 - structure -> Atom (ParenOpen terms ParenClose)?                  -- a structure is either just an Atom, or an Atom with comma separated
 -                                                                  -- terms as arguments
 - requisites -> or_requisites (Comma requisites)?                  -- requisites or a set of Comma-separated or_requisites
 - or_requisites -> requisite (Or or_requisites)?                   -- or_requisites are a set of Or-separated requisites
 - requisite -> term (Equal term)?                                  -- a requisite is a term, unification between a term and another,
 -               | ParenOpen requisites ParenClose                  -- or a parentheses-enclosed set of requisites
 - term -> structure | Variable | WildCard | list                   -- a term is either a structure, a variable, an unnamed variable,
 -                                                                  -- or a list of things.  Note: infix operators are not supported
 -                                                                  -- since they complicate things with respect to priorities.  I could
 -                                                                  -- parse some operations, such as , (good for making tuples) etc,
 -                                                                  -- but in the end the solution is not generic.  Either way, infix
 -                                                                  -- operators are just syntactic sugar.  Parenthese are therefore
 -                                                                  -- not used with terms since they are only meaningful with infix
 -                                                                  -- operators which are not supported.
 - terms -> term (Comma terms)?                                     -- terms are Comm-separated terms
 - list -> BracketOpen (terms (Bar term)?)? BracketClose            -- a list is generally in the form [], [a, b, c], [a, b, c | X] or [a, b, c | [...]]
 -
 - As a guideline, the following clauses are accepted:
 -
 - fact.
 - fact(x).
 - fact(x, y).
 - +(z, X, X).
 - +(s(Y), X, s(R)) :- +(Y, X, R).
 - *(z, _, z).
 - *(s(X), Y, R) :- *(X, Y, XY), +(Y, XY, R).
 - goal(X, Y, Z) :- (X = Y, Z = z) ; X = z ; Y = x.
 - ?- +(s(s(z)), s(z), AddResult).
 - plus([X, Y], R) :- +(X, Y, R).
 - ?- X = s(z), Y = s(s(z)), plus([X|[Y]], R).
 -}

module Text.Pit.Parser (
        parse
        ) where

import Data.List (intercalate)
import Control.Monad.Writer
import Text.Pit.Types

-- the parser converts the stream of Tokens to constructed statements
parse :: [Token] -> Writer [Message] [(Statement, Int, Int)]
parse = parseStatements
    where
        unexpectedMessage :: TokenType -> String -> String
        unexpectedMessage t nt = "Unexpected token '" ++ show t ++ "' while parsing '" ++ nt ++ "'"

        expectedMessage :: [String] -> String -> String
        expectedMessage t nt = "Expected a '" ++ (intercalate "' or '" t) ++ "' while parsing '" ++ nt ++ "'"

        internalError = internalError

        -- the following functions basically implement a parse table and build the AST

        parseTerm :: [Token] -> (Writer [Message] Term, [Token])
        parseTerm [] = internalError
        parseTerm allts@((cur, l, c):ts) = case cur of
            -- A term is either an atom with its arguments, a variable, a wildcard or a list.
            TAtom atom -> parseAtom atom ts
            TVariable var -> (return $ Assignable var var, ts)
            TWildCard -> (return $ Assignable "_" "_", ts)
            TBracketOpen -> parseList ts True
            _ -> (tell [(expectedMessage ["variable", "atom"] "term", l, c)] >> return (Assignable "_" "_"), allts)

        parseAtom :: String -> [Token] -> (Writer [Message] Term, [Token])
        parseAtom _ [] = internalError
        parseAtom atom allts@((cur, _, _):ts) = case cur of
            -- If ParenOpen is seen, it has arguments.  Otherwise it has arity 0.
            TParenOpen -> (args >>= return . Structure atom, rest)
                where
                    (args, rest) = parseTerms ts
            _ -> (return $ Structure atom [], allts)

        parseList :: [Token] -> Bool -> (Writer [Message] Term, [Token])
        parseList ts matchClose = case ts of
                [] -> internalError
                (TBracketClose, _, _):xs -> (return $ Structure "[" [], if matchClose then xs else ts)
                (_, l, c):_ -> (do
                        t <- term
                        r <- lrest
                        when missing $ tell [(expectedMessage [",", "]"] "list", l, c)]
                        return $ Structure "[" [t, r]
                     , rest)
            -- A list is a structure with a term and the rest of the list.
            -- If the list is in the form [A, B ...], the rest is a list without a closing bracket.
            -- If the list is in the form [A|...], the rest is another term.
            -- If CloseBracket is seen, it's consumed if matchClose is set
            where
                (term, afterTerm) = parseTerm ts
                (lrest, afterRest) = case afterTerm of
                    [] -> internalError
                    (TComma, _, _):xs -> parseList xs False
                    (TBar, _, _):xs -> parseTerm xs
                    (TBracketClose, _, _):_ -> (return $ Structure "[" [], afterTerm)
                    (_, l, c):_ -> (tell [(expectedMessage [",", "]"] "list", l, c)] >> return (Structure "[" []), afterTerm)
                -- make sure to match the closing bracket
                (rest, missing) = if not matchClose then (afterRest, False) else case afterRest of
                        [] -> internalError
                        (TBracketClose, _, _):xs -> (xs, False)
                        _ -> (afterRest, True)

        parseTerms :: [Token] -> (Writer [Message] [Term], [Token])
        parseTerms ts = (do
                            t <- term
                            tr <- trest
                            return $ t:tr
                        , rest)
            -- Terms are comma separated terms ending with a close parenthesis
            where
                (term, afterTerm) = parseTerm ts
                (trest, rest) = case afterTerm of
                    [] -> internalError
                    (TComma, _, _):xs -> parseTerms xs
                    (TParenClose, _, _):xs -> (return [], xs)
                    (_, l, c):_ -> (tell [(expectedMessage [",", ")"] "arguments", l, c)] >> return [], afterTerm)

        parseRequisites :: [Token] -> Bool -> (Writer [Message] Definition, [Token])
        parseRequisites ts matchClose = case afterAndReq of
                -- A requisite is 'or' of 'and' of either a term or a term = term.
                [] -> internalError
                (TOr, _, _):xs -> (do
                                    r <- andreq
                                    rr <- reqrest
                                    return $ Or r rr
                                  , rest)
                    where
                        (reqrest, rest) = parseRequisites xs matchClose
                (TDot, l, c):xs -> (do
                                    r <- andreq
                                    when matchClose $ tell [(expectedMessage [")"] "requisites/query", l, c)]
                                    return r
                                   , if matchClose then afterAndReq else xs)
                (TParenClose, l, c):xs -> (do
                                            r <- andreq
                                            unless matchClose $ tell [(unexpectedMessage TParenClose "requisites/query", l, c)]
                                            return r
                                           , xs)
                (_, l, c):_ -> (do
                                r <- andreq
                                tell [(expectedMessage [if matchClose then ")" else "."] "requisites/query", l, c)]
                                return r
                               , afterAndReq)
            where
                (andreq, afterAndReq) = parseAndRequisites ts

                parseAndRequisites :: [Token] -> (Writer [Message] Definition, [Token])
                parseAndRequisites ts2 = case afterReq of
                        -- An and requisite is 'and' of either a term or a term = term.
                        [] -> internalError
                        (TComma, _, _):xs -> (do
                                                r <- req
                                                rr <- reqrest
                                                return $ And r rr
                                             , rest)
                            where
                                (reqrest, rest) = parseAndRequisites xs
                        _ -> (req, afterReq)
                    where
                         (req, afterReq) = parseRequisite ts2

                parseRequisite :: [Token] -> (Writer [Message] Definition, [Token])
                parseRequisite [] = internalError
                parseRequisite allts@((cur, _, _):ts3) = case cur of
                    -- A requisite is either a term, a term = term or (requisites).
                    TParenOpen -> parseRequisites ts3 True
                    _ -> case afterTerm of
                            [] -> internalError
                            (TEqual, _, _):xs -> (do
                                                    t1 <- term
                                                    t2 <- other
                                                    return $ Unification t1 t2
                                                 , rest)
                                where
                                    (other, rest) = parseTerm xs
                            _ -> (term >>= return . Requisite, afterTerm)
                        where
                             (term, afterTerm) = parseTerm allts

        parseDefinition :: [Token] -> (Writer [Message] Definition, [Token])
        parseDefinition [] = internalError
        parseDefinition allts@((cur, l, c):ts) = case cur of
            -- if Dot is seen, it's a fact.  Otherwise an ImpliedBy is expected followed by the definition.
            TDot -> (return Fact, ts)
            TImpliedBy -> parseRequisites ts False
            _ -> (tell [(expectedMessage [".", ":-"] "definition", l, c)] >> return Fact, allts)

        parseQuery :: [Token] -> (Writer [Message] Statement, [Token])
        parseQuery ts = (reqs >>= return . Query, rest)
            -- a query is like the definition of part of a declaration
            where
                (reqs, rest) = parseRequisites ts False

        parseDeclaration :: String -> [Token] -> (Writer [Message] Statement, [Token])
        parseDeclaration atom ts = (do
                                        t <- decl
                                        d <- def
                                        return $ Declaration t d
                                    , rest)
            -- a declaration is an atom followed possibly by a declaration
            where
                (decl, afterDecl) = parseAtom atom ts
                (def, rest) = parseDefinition afterDecl

        parseStatements :: [Token] -> Writer [Message] [(Statement, Int, Int)]
        parseStatements [] = internalError
        parseStatements ((cur, l, c):ts) = case cur of
            -- if End is seen, nothing left.  Otherwise there can be either an atom, or a query
            TEnd -> return []
            TAtom atom -> do
                            s <- decl
                            ss <- parseStatements after
                            return $ (s, l, c):ss
                where
                    (decl, after) = parseDeclaration atom ts
            TQuery -> do
                        s <- query
                        ss <- parseStatements after
                        return $ (s, l, c):ss
                where
                    (query, after) = parseQuery ts
            _ -> tell [(unexpectedMessage cur "statements", l, c)] >> parseStatements ts
