-- | Generates a full parser from a language and offers some utility functions for immediate evaluation.
module Language.GroteTrap.Parser (

  -- * Parsing and reading
  parseSentence, readParseTree, readExpression
  
  ) where

import Language.GroteTrap.Lexer
import Language.GroteTrap.Language
import Language.GroteTrap.ParseTree
import Language.GroteTrap.Range

import Data.List (groupBy, sortBy)
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos (newPos)
import qualified Text.ParserCombinators.Parsec.Expr as P

resultOf :: Show a => Either ParseError a -> a
resultOf x = case x of
  Left err -> error $ "parse error at " ++ show err
  Right y  -> y

withEOF :: Show tok => GenParser tok st t -> GenParser tok st t
withEOF p = do v <- p; eof; return v

-- | Given a language and a string, yields the parse tree or a parse error.
parseSentence :: Language a -> String -> Either ParseError ParseTree
parseSentence lang = combine (tokenize lang) (withEOF $ pTree lang)

-- | Given a language and a string, yields the parse tree or throws an error.
readParseTree :: Language a -> String -> ParseTree
readParseTree lang = resultOf . parseSentence lang

-- | Given a language and a string, parses and evaluates the string.
readExpression :: Language a -> String -> a
readExpression lang = evaluate lang . readParseTree lang

combine :: Parser [TokenPos] -> GenParser TokenPos () c -> String -> Either ParseError c
combine p1 p2 input = case runParser p1 () "characters" input of
  Left e        -> Left e
  Right output  -> runParser p2 () "tokens" (filter (\(_, t) -> not . isWhite $ t) output)

pTree :: Language a -> GenParser TokenPos () ParseTree
pTree lang = P.buildExpressionParser (buildOperatorTable $ operators lang) (pUnit lang)

pUnit :: Language a -> GenParser TokenPos () ParseTree
pUnit lang = choice [pCall lang, pId, pInt, pParens lang]

pId :: GenParser TokenPos () ParseTree
pId = tok f where
  f (pos, TId name) = Just $ PId pos name
  f _ = Nothing

pInt :: GenParser TokenPos () ParseTree
pInt = tok f where
  f (pos, TInt v) = Just $ PInt pos v
  f _ = Nothing

pCall :: Language a -> GenParser TokenPos () ParseTree
pCall lang = do
  (begin,name) <- tok f
  static TOpen
  args <- sepBy (pTree lang) (static TComma)
  (end,_) <- static TClose
  return $ PCall (begin,end) name args
  where f (pos, TFunction name) = Just (pos, name)
        f _ = Nothing

pParens :: Language a -> GenParser TokenPos () ParseTree
pParens lang = do
  (begin,_) <- static TOpen
  v <- pTree lang
  (end,_)   <- static TClose
  return $ PParens (begin, end + 1) v

buildOperatorTable :: [Operator a] -> P.OperatorTable TokenPos () ParseTree
buildOperatorTable = map (map buildOperator) . orderedOperators

buildOperator :: Operator a -> P.Operator TokenPos () ParseTree
buildOperator (Unary _ fix _ tok) = xFix fix (pUna tok)
buildOperator (Binary _ fix _ tok) = P.Infix (pBin tok) (infixX fix)
buildOperator (Nary _ a _ tok) = P.Infix (pList a tok) P.AssocLeft

xFix :: Fixity1 -> GenParser t st (a -> a) -> P.Operator t st a
xFix Prefix  = P.Prefix
xFix Postfix = P.Postfix

infixX :: Fixity2 -> P.Assoc
infixX InfixL = P.AssocLeft
infixX InfixR = P.AssocRight

orderedOperators :: [Operator a] -> [[Operator a]]
orderedOperators = groupBy equalPriority . sortBy orderPriority where
  equalPriority a1 a2 = opPrio a1 == opPrio a2
  orderPriority a1 a2 = opPrio a1 `compare` opPrio a2

pList :: Bool -> String -> GenParser TokenPos () (ParseTree -> ParseTree -> ParseTree)
pList allow token = do
  (pos, _) <- static $ TOperator token
  return $ assimilate allow token (pos, pos + length token)

assimilate :: Bool -> String -> Range -> ParseTree -> ParseTree -> ParseTree
assimilate allow token range pt1@(PList _ rs tok ps) pt2
  | token == tok  = PList allow (rs ++ [range]) token (ps ++ [pt2])
  | otherwise     = PList allow [range] token [pt1,pt2]
assimilate allow token range pt1 pt2
  = PList allow [range] token [pt1,pt2]


pBin :: String -> GenParser TokenPos () (ParseTree -> ParseTree -> ParseTree)
pBin token = do
  (pos, _) <- static $ TOperator token
  return $ PBinary (pos, pos + length token) token

pUna :: String -> GenParser TokenPos () (ParseTree -> ParseTree)
pUna token = do
  (pos, _) <- static $ TOperator token
  return $ PUnary (pos, pos + length token) token

tok :: (TokenPos -> Maybe a) -> GenParser TokenPos st a
tok = token show (newPos "tokens" 1 . fst)

static :: Token -> GenParser TokenPos () TokenPos
static t = tok (\tp@(_,x) -> if x == t then Just tp else Nothing)