content: module Syntax.Parser
      ( pDefs, pExpr
      , fixFixity, fixFixityDef
      ) where
  
  import Data.Maybe
  import Control.Monad.State
  import qualified Data.ByteString as B
  
  import Syntax
  import Syntax.ErrorDoc
  import Syntax.Parser.Lexer
  import qualified Syntax.Parser.Parser as P
  import TypeChecking.Monad.Warn
  import TypeChecking.Expressions.Utils
  
  pDefs :: Monad m => B.ByteString -> WarnT [Error] m [Def]
  pDefs = liftM reverse . runParser P.pDefs
  
  pExpr :: Monad m => [(Name,Fixity)] -> B.ByteString -> WarnT [Error] m RawExpr
  pExpr tab str = runParser P.pExpr str >>= fixFixity tab
  
  runParser :: Monad m => Parser a -> B.ByteString -> WarnT [Error] m a
  runParser p s = case evalState (runWarnT $ p ((1, 1), s)) [Layout 1] of
      (errs, Nothing) -> throwError (mapErrs errs)
      (errs, Just a)  -> warn (mapErrs errs) >> return a
    where
      mapErrs = map $ \(pos, err) -> Error Other $ emsgLC pos err enull
  
  data Tree p a = Branch Fixity Name Syntax (Tree p a) (Tree p a) | Leaf (Term (p, Syntax) a)
  
  fixFixity :: Monad m => [(Name,Fixity)] -> Term (Posn, Syntax) a -> WarnT [Error] m (Term (Posn, Syntax) a)
  fixFixity tab = go
    where
      go :: Monad m => Term (Posn, Syntax) a -> WarnT [Error] m (Term (Posn, Syntax) a)
      go = liftM treeToExpr . exprToTree
      
      exprToTree :: Monad m => Term (Posn, Syntax) a -> WarnT [Error] m (Tree Posn a)
      exprToTree (Var a ts) = liftM (Leaf . Var a) (mapM go ts)
      exprToTree (Lambda t) = liftM (Leaf . Lambda) (go t)
      exprToTree (Apply (_, Name Infix{} s) [t1, t2]) = do
          t1' <- exprToTree t1
          t2' <- go t2
          let ft = fromMaybe (Infix InfixL 90) (lookup s tab)
          branch ft s (Name ft s) t1' (Leaf t2')
      exprToTree (Apply (_, At) [t1,t2]) = do
          t1' <- exprToTree t1
          t2' <- go t2
          branch (Infix InfixL 90) (Operator "@") At t1' (Leaf t2')
      exprToTree (Apply (_, Null) (t:ts)) = liftM Leaf $ go (apps t ts)
      exprToTree (Apply s ts) = liftM (Leaf . Apply s) (mapM go ts)
      
      treeToExpr :: Tree Posn a -> Term (Posn, Syntax) a
      treeToExpr (Leaf t) = t
      treeToExpr (Branch ft _ s t1 t2) =
          let t1' = treeToExpr t1
          in Apply (termPos t1', s) [t1', treeToExpr t2]
      
      branch :: Monad m => Fixity -> Name -> Syntax -> Tree Posn a -> Tree Posn a -> WarnT [Error] m (Tree Posn a)
      branch ft@(Infix ia p) n s (Branch ft'@(Infix ia' p') n' s' a1 a2) b | p' < p || p == p' && ia == InfixR && ia' == InfixR = do
          a2' <- branch ft n s a2 b
          return (Branch ft' n' s' a1 a2')
      branch ft@(Infix ia p) n s a@(Branch ft'@(Infix ia' p') n' _ _ _) b | p == p' && not (ia == InfixL && ia' == InfixL) = do
          let showOp ft'' s'' = nameToInfix s'' ++ " [" ++ show ft'' ++ "]"
              msg = "Precedence parsing error: cannot mix " ++ showOp ft  n ++
                                                    " and " ++ showOp ft' n' ++ " in the same infix expression"
          warn [Error Other $ emsgLC (termPos $ treeToExpr a) msg enull]
          return (Branch ft n s a b)
      branch ft name syn a b = return (Branch ft name syn a b)
  
  fixFixityDef :: Monad m => [(Name,Fixity)] -> Def -> WarnT [Error] m Def
  fixFixityDef tab (DefType name expr) = liftM (DefType name) (fixFixity tab expr)
  fixFixityDef tab (DefFun name pats (Just expr)) = liftM (DefFun name pats . Just) (fixFixity tab expr)
  fixFixityDef _ d@DefFun{} = return d
  fixFixityDef tab (DefData name params cons clauses) = do
      params' <- forM params (fixFixityTele tab)
      cons' <- forM cons $ \(ConDef con teles) -> liftM (ConDef con) $ forM teles (fixFixityTele tab)
      clauses' <- forM clauses $ \(Clause name pats expr) -> liftM (Clause name pats) (fixFixity tab expr)
      return (DefData name params' cons' clauses')
  fixFixityDef tab (DefRecord name params mcon fields clauses) = do
      params' <- forM params (fixFixityTele tab)
      fields' <- forM fields $ \(Field name expr) -> liftM (Field name) (fixFixity tab expr)
      clauses' <- forM clauses $ \(Clause name pats expr) -> liftM (Clause name pats) (fixFixity tab expr)
      return (DefRecord name params' mcon fields' clauses')
  fixFixityDef _ d@DefImport{} = return d
  fixFixityDef _ d@DefFixity{} = return d
  
  fixFixityTele :: Monad m => [(Name,Fixity)] -> Tele -> WarnT [Error] m Tele
  fixFixityTele tab (VarsTele e vars expr) = liftM (VarsTele e vars) (fixFixity tab expr)
  fixFixityTele tab (TypeTele e      expr) = liftM (TypeTele e     ) (fixFixity tab expr)
  