{-| Module      :  Parser
    License     :  GPL

    Maintainer  :  helium@cs.uu.nl
    Stability   :  experimental
    Portability :  portable
-}

module Helium.Parser.Parser
    ( module_, exp_, exp0, type_, atype, contextAndType
    , parseOnlyImports
    ) where

{-
Absent:
- records
- classes (class, instance, default...)
- "newtype"
- strictness annotations
- n+k patterns
- [] and (,) and (,,,) etc as (type) constructor
- empty declarations, qualifiers, alternatives or statements
- "qualified", "as" in imports
- import and export lists

Simplified:
- funlhs 
    For example   x:xs +++ ys = ...  is not allowed, parentheses around x:xs necessary
- pattern binding met pat10 i.p.v. pat0 
    For example   (x:xs) = [1..] (parenthesis are obligatory)
- sections: (fexp op) and (op fexp)
    For example   (+2*3)   is not allowed, should be (+(2*3)) 
- fixity declarations only at top-level
-}

import Control.Monad
import qualified Control.Exception as CE (catch, IOException)
import Helium.Parser.ParseLibrary hiding (satisfy)
import Data.Functor.Identity (Identity)
import Text.ParserCombinators.Parsec
import Text.Parsec.Prim (ParsecT)
import Helium.Parser.Lexer
import Helium.Parser.LayoutRule
import qualified Helium.Utils.Texts as Texts

import Helium.Syntax.UHA_Syntax
import Helium.Syntax.UHA_Utils
import Helium.Syntax.UHA_Range

import qualified Helium.Parser.CollectFunctionBindings as CollectFunctionBindings
import Helium.Utils.Utils

parseOnlyImports :: String -> IO [String]
parseOnlyImports fullName = do
    contents <- CE.catch (readFile fullName)
        (\ioErr -> 
            let message = "Unable to read file " ++ show fullName 
                       ++ " (" ++ show (ioErr :: CE.IOException) ++ ")"
            in throw message)
    
    return $ case lexer [] fullName contents of
        Left _ -> []
        Right (toks, _) ->
            case runHParser onlyImports fullName (layout toks) False {- no EOF -} of
                Left _ -> []
                Right imports -> 
                    map stringFromImportDeclaration imports

{-
module  
    ->  "module" modid exports? "where" body  
--      |  body  
-}

module_ :: HParser Module
module_ = addRange $
    do
        lexMODULE
        n <- modid
        let mes = MaybeExports_Nothing
        lexWHERE
        b <- body
        return (\r -> Module_Module r (MaybeName_Just n) mes b)
    <|>
    do 
        b <- body
        return (\r ->
            Module_Module r MaybeName_Nothing MaybeExports_Nothing b)


onlyImports :: HParser [ImportDeclaration]
onlyImports = 
    do
        lexMODULE
        _ <- modid
        let _ = MaybeExports_Nothing
        lexWHERE
        lexLBRACE <|> lexINSERTED_LBRACE
        many (do { i <- impdecl; semicolon; return i })
    <|>
    do
        lexLBRACE <|> lexINSERTED_LBRACE
        many (do { i <- impdecl; semicolon; return i })
  where
    semicolon = lexSEMI <|> lexINSERTED_SEMI <|> lexINSERTED_RBRACE
    -- the last of the three is a hack to support files that
    -- only contain imports
    
{-
body  ->  "{" topdecls "}"
topdecls  ->  topdecl1 ";" ... ";" topdecln    (n>=0)  
-}

body :: HParser Body
body = addRange $
      withBraces' $ \explicit -> 
        do
          lexHOLE
          return (\r -> Body_Hole r 0)
        <|>
        do 
          (is, ds) <- importsThenTopdecls explicit
          let groupedDecls = CollectFunctionBindings.decls ds
          return $ \r -> Body_Body r is groupedDecls

importsThenTopdecls :: Bool -> 
  ParsecT [Token] SourcePos Identity ([ImportDeclaration], [Declaration])
importsThenTopdecls explicit =
    do
        is <- many (do { i <- impdecl
                       ; if explicit then lexSEMI else lexSEMI <|> lexINSERTED_SEMI 
                       ; return i
                       } )
        ds <- topdeclCombinator topdecl
        return (is, ds)
        
  where
    topdeclCombinator = if explicit then semiSepTerm else semiOrInsertedSemiSepTerm

        
    
{-
topdecl  
    ->  impdecl  
     |  "data" simpletype "=" constrs derivings?
     |  "type" simpletype "=" type
     |  infixdecl
     |  decl  

derivings
    -> "deriving" derivings'

derivings'
    -> tycon 
     | "(" ")"
     | "(" tycon ( "," tycon )* ")"

simpletype  
    ->  tycon tyvar1 ... tyvark  (k>=0)  
-}

{-
    | Data                            
        range                    : Range
        context                  : ContextItems
        simpletype               : SimpleType
        constructors             : Constructors
        derivings                : Names
-}

topdecl :: HParser Declaration
topdecl = addRange (
    do
        lexDATA
        st <- simpleType
        lexASG
        cs <- constrs
        ds <- option [] derivings
        return (\r -> Declaration_Data r [] st cs ds)
    <|>
    do
        lexTYPE
        st <- simpleType
        lexASG
        t <- type_
        return $ \r -> Declaration_Type r st t
    <|>
    infixdecl
    ) 
    <|> addRange (
      do
         lexHOLE
         jb <- optionMaybe normalRhs
         case jb  of
            Just b ->  return $ \r -> Declaration_PatternBinding r (Pattern_Hole r (-1)) b
            Nothing -> return $ \r -> Declaration_Hole r (-1)
      )
    <|>
    decl
    <?> Texts.parserDeclaration

derivings :: HParser [Name]
derivings = 
    do  lexDERIVING
        ( do cls <- tycls
             return [cls] )
          <|> (
          do lexLPAREN           
             clss <- tycls `sepBy` lexCOMMA
             lexRPAREN
             return clss )
    
simpleType :: HParser SimpleType
simpleType =
    addRange (
        do
            c  <- tycon
            vs <- many tyvar
            return $ \r -> SimpleType_SimpleType r c vs
    )
    
{-
infixdecl   ->  fixity [digit] ops  (fixity declaration)  
fixity      ->  "infixl" | "infixr" | "infix"  
ops         ->  op1 "," ... "," opn    (n>=1)  
-}

infixdecl :: HParser (Range -> Declaration)
infixdecl = 
    do
        f <- fixity
        p <- fmap fromInteger (option 9 (fmap read lexInt)) :: HParser Int
        when (p < 0 || p > 9) (fail Texts.parserSingleDigitPriority)
        os <- ops
        return $ \r -> Declaration_Fixity r f (MaybeInt_Just p) os

ops :: HParser Names
ops = commas1 op

fixity :: HParser Fixity
fixity = addRange $ 
    do
        lexINFIXL 
        return $ \r -> Fixity_Infixl r
    <|>
    do
        lexINFIXR 
        return $ \r -> Fixity_Infixr r
    <|>
    do
        lexINFIX 
        return $ \r -> Fixity_Infix r
    
{-
constrs  ->  constr1 "|" ... "|" constrn  (n>=1)  
-}

constrs :: HParser Constructors
constrs = constr `sepBy1` lexBAR

{-
constr  ->  btype conop btype  (infix conop)  
         |  con atype1 ... atypek  (arity con = k, k>=0)  
-}

constr :: HParser Constructor
constr = addRange $
    do 
        (t1, n) <- try $ do 
            t1 <- annotatedType btype 
            n <- conop
            return (t1, n)
        t2 <- annotatedType btype
        return (\r -> Constructor_Infix r t1 n t2)
    <|>
    do 
        n <- con 
        ts <- many (annotatedType atype)
        return (\r -> Constructor_Constructor r n ts)
        

{-
Simplified import:
impdecl -> "import" modid impspec?
impspec -> "hiding" "(" import "," ... ")"
import  -> var
-}

impdecl :: HParser ImportDeclaration
impdecl = addRange (
    do
        lexIMPORT
        let q = False
        m <- modid
        let a = MaybeName_Nothing
        i <- option MaybeImportSpecification_Nothing $
                do{ is <- impspec
                  ; return (MaybeImportSpecification_Just is)
                  }
        return $ \r -> ImportDeclaration_Import r q m a i
    ) <?> Texts.parserImportDeclaration

impspec :: HParser ImportSpecification
impspec = addRange $
    do  
        h <- do { lexHIDING; return True }
        is <- parens (commas import_)
        return $ \r -> ImportSpecification_Import r h is

import_ :: HParser Import
import_ = addRange $
    do
        n <- var
        return $ \r -> Import_Variable r n
    
{-
decls   ->  "{" decl1 ";" ... ";" decln "}"    (n>=0)  
-}

decls :: HParser Declarations
decls =
    do
        ds <- withLayout decl
        return (CollectFunctionBindings.decls ds)

{- 
decl    ->  vars "::" type  (type signature)  
         |  ( funlhs | pat10 ) rhs          
vars    ->  var1 "," ..."," varn    (n>=1)   
funlhs  ->  var apat*
         |  pat10 varop pat10
         |  "(" funlhs ")" apat *

Rewrite to reduce backtracking:

decl    ->  [[ var ]] decl1
         |  [[ pat10 ]] decl2
         |  funlhs rhs
decl1   ->  "," vars "::" type
         |  "::" type
         |  varop pat10 rhs
         |  "@" apat decl2
         |  apat* rhs
decl2   ->  varop pat10 rhs
         |  rhs
funlhs  ->  [[ var ]] funlhs1
         |  [[ pat10 ]] varop pat10
         |  "(" funlhs ")" apat*
funlhs1 ->  varop pat10
         |  apat*
-}

decl :: HParser Declaration
decl = addRange (
    do fb <- lexCaseFeedback
       return $ \r -> Declaration_FunctionBindings r
          [FunctionBinding_Feedback r fb $ FunctionBinding_Hole r 0]
    <|>
    do
        lexHOLE
        jb <- optionMaybe normalRhs
        case jb  of
           Just b ->  return $ \r -> Declaration_PatternBinding r (Pattern_Hole r (-1)) b
           Nothing -> return $ \r -> Declaration_Hole r (-1)
    <|>
    do 
        nr <- try (withRange var)
        decl1 nr
    <|>
    do
        pr <- try (withRange pat10)
        decl2 pr
    <|>
    -- do
    --     lexHOLE
    --     return $ \r -> Declaration_Hole r (-1)
    do
        l <- funlhs
        b <- normalRhs
        return $ \r -> Declaration_FunctionBindings r
            [FunctionBinding_FunctionBinding r l b]
    ) <?> Texts.parserDeclaration

decl1 :: (Name, Range) -> HParser (Range -> Declaration)
decl1 (n, nr) =
    do
        lexCOMMA
        ns <- vars
        lexCOLCOL
        t <- contextAndType
        return $ \r -> Declaration_TypeSignature r (n:ns) t
    <|>
    do
        lexCOLCOL
        t <- contextAndType
        return $ \r -> Declaration_TypeSignature r [n] t
    <|>
    do  
        o <- varop
        (p, pr) <- withRange pat10
        b <- normalRhs
        let lr = mergeRanges nr pr
        return $ \r -> Declaration_FunctionBindings r
            [FunctionBinding_FunctionBinding r 
                (LeftHandSide_Infix lr (Pattern_Variable nr n) o p) b]
    <|>
    do
        lexAT
        (p, pr) <- withRange apat
        let completeRange = mergeRanges nr pr
            asPat = Pattern_As completeRange n p
        decl2 (asPat, completeRange)
    <|>
    do
        (ps, rs) <- fmap unzip (many (withRange apat))
        let lr = if null rs then nr else mergeRanges nr (last rs)
        b <- normalRhs
        return $ \r ->
            if null rs then
                Declaration_PatternBinding r (Pattern_Variable nr n) b
            else
                Declaration_FunctionBindings r
                    [FunctionBinding_FunctionBinding r
                        (LeftHandSide_Function lr n ps) b]

decl2 :: (Pattern, Range) -> HParser (Range -> Declaration)
decl2 (p1, p1r) = 
    do
        o <- varop
        (p2, p2r) <- withRange pat10
        b <- normalRhs
        let lr = mergeRanges p1r p2r
        return $ \r -> Declaration_FunctionBindings r
            [FunctionBinding_FunctionBinding r 
                (LeftHandSide_Infix lr p1 o p2) b]                
    <|>
    do
        b <- normalRhs
        return $ \r -> Declaration_PatternBinding r p1 b        

funlhs :: HParser LeftHandSide
funlhs = addRange $
    do  
        nr <- try (withRange var)
        funlhs1 nr
    <|>
    do
        p1 <- try pat10
        o <- varop
        p2 <- pat10
        return $ \r -> LeftHandSide_Infix r p1 o p2
    <|>
    do
        l <- parens funlhs
        ps <- many apat
        return $ \r -> LeftHandSide_Parenthesized r l ps 

funlhs1 :: (Name, Range) -> HParser (Range -> LeftHandSide)
funlhs1 (n, nr) = 
    do
        o <- varop
        p <- pat10
        return $ \r -> LeftHandSide_Infix r
                        (Pattern_Variable nr n) o p 
    <|>
    do
        ps <- many apat
        return $ \r -> LeftHandSide_Function r n ps

vars :: HParser [Name]
vars = commas1 var

{-
rhs     ->  "=" exp rhs1
         |  gdexp+ rhs1
rhs1    -> ( "where" decls )?        
gdexp   ->  "|" exp0 "=" exp
-}

normalRhs, caseRhs :: HParser RightHandSide
normalRhs = rhs lexASG
caseRhs   = rhs lexRARROW

-- The string is "->" for a case rhs and "=" for a normal rhs
rhs :: HParser () -> HParser RightHandSide
rhs equals = addRange $
    do
        equals
        e <- exp_ 
        mds <- option MaybeDeclarations_Nothing rhs1
        return $ \r -> RightHandSide_Expression r e mds
    <|>                        
    do
        gs <- many1 (gdexp equals)
        mds <- option MaybeDeclarations_Nothing rhs1
        return $ \r -> RightHandSide_Guarded r gs mds

rhs1 :: HParser MaybeDeclarations
rhs1 =
    do 
        lexWHERE
        ds <- decls
        return (MaybeDeclarations_Just ds)
                
gdexp :: HParser () -> HParser GuardedExpression
gdexp equals = addRange $
    do
        lexBAR
        g <- exp0
        equals
        e <- exp_
        return $ \r -> GuardedExpression_GuardedExpression r g e
        

-- exp_ = addRange (
--    do
--       feedback <- option Nothing (try $ lexFeedback >>= return . Just)
--       e <- expOrg_
--       return (maybe (const e) (\s -> \r -> Expression_Feedback r s e) feedback)
--    ) <?> Texts.parserExpression

{-
exp     ->  exp0 "::" type  (expression type signature)  
         |  exp0  
-}

exp_ :: ParsecT [Token] SourcePos Identity Expression
exp_ = addRange (
    do
       e <- exp0
       option (\_ -> e) $ 
            do 
                lexCOLCOL
                t <- contextAndType
                return $ \r -> Expression_Typed r e t
    )
    <?> Texts.parserExpression        

contextAndType :: HParser Type
contextAndType = addRange $ do
    mc <- option Nothing (try $ do { c <- scontext; lexDARROW; return (Just c) })
    t <- type_
    case mc of 
        Nothing -> return $ \_ -> t
        Just c  -> return $ \r -> Type_Qualified r c t
    
{-
expi  ->  expi+1 [op(n,i) expi+1]  
 |  lexpi  
 |  rexpi  
lexpi  ->  (lexpi | expi+1) op(l,i) expi+1  
lexp6  ->  - exp7  
rexpi  ->  expi+1 op(r,i) (rexpi | expi+1)  

Simplified, post-processing 

exp0 -> ( "-" )? exp10 ( op ( "-" )? exp10 )*

See noRange in ParseCommon for an explanation of the parsing of infix expressions.
-}

exp0 :: HParser Expression
exp0 = addRange (
    do  
        u <- maybeUnaryMinus
        es <- exprChain
        return $ \_ -> Expression_List noRange (u ++ es)
    )
    <?> Texts.parserExpression        

exprChain :: HParser [Expression]
exprChain = 
    do
        e <- exp10
        es <- fmap concat $ many $
            do
                o <- operatorAsExpression False
                u <- maybeUnaryMinus
                e' <- exp10
                return ([o] ++ u ++ [e'])
        return (e:es)

maybeUnaryMinus :: ParsecT [Token] SourcePos Identity [Expression]
maybeUnaryMinus = 
    option [] (fmap (:[]) unaryMinus)  
    <?> Texts.parserExpression

unaryMinus :: HParser Expression
unaryMinus = 
    do
        (_, r) <- withRange lexMINDOT 
        return (Expression_Variable noRange (setNameRange floatUnaryMinusName r))
    <|>
    do 
        (_, r) <- withRange lexMIN 
        return (Expression_Variable noRange (setNameRange intUnaryMinusName r))

{-       
exp10   ->  "\" apat1 ... apatn "->" exp  (lambda abstraction, n>=1)  
         |  "let" decls "in" exp  (let expression)  
         |  "if" exp "then" exp "else" exp  (conditional)  
         |  "case" exp "of" alts  (case expression)  
         |  "do" stmts (do expression)  
         |  fexp  
-}

exp10 :: HParser Expression
exp10 = addRange (
    do
        lexBSLASH
        ps <- many1 apat
        lexRARROW
        e <- exp_
        return $ \r -> Expression_Lambda r ps e
    <|>
    (do
        lexLET
        ds <- decls
        lexIN
        e <- exp_
        return $ \r -> Expression_Let r ds e)
    <|>
    do
        lexIF
        e1 <- exp_
        lexTHEN
        e2 <- exp_
        lexELSE
        e3 <- exp_
        return $ \r -> Expression_If r e1 e2 e3
    <|>
    do
        lexCASE
        e <- exp_
        lexOF
        as <- alts
        return $ \r -> Expression_Case r e as
    <|>
    do
        lexDO
        ss <- stmts
        return $ \r -> Expression_Do r ss
    ) 
    <|>
    fexp
    <?> Texts.parserExpression

{-
fexp  -> aexp+
-}

fexp :: HParser Expression    
fexp = addRange $
    do
        (e:es) <- many1 aexp
        if null es then
            return $ \_ -> e
          else
            return $ \r -> Expression_NormalApplication r e es


{-
aexp    ->  var  (variable)  
         |  con
         |  literal  

         |  "[" "]" 
         |  "[" exp1 "," ... "," expk "]"
         |  "[" exp1 ( "," exp2 )? ".." exp3? "]"
         |  "[" exp "|" qual1 "," ... "," qualn "]"

         |  () 
         |  (op fexp) (left section)
         |  (fexp op) (right section)
         |  ( exp )  (parenthesized expression)  
         |  ( exp1 , ... , expk )  (tuple, k>=2)  
         
Last cases parsed as:

    "(" "-" exprChain ( "," exp_ )* ")"
  | "(" op fexp ")"
  | "(" fexp op ")"
  | "(" ( exp_ )<sepBy ","> ")"
-}

operatorAsExpression :: Bool -> HParser Expression
operatorAsExpression storeRange = (do
    (o, r) <- withRange ( fmap Left varsym <|> fmap Right consym 
                      <|> lexBACKQUOTEs (fmap Left varid <|> fmap Right conid))
    let range = if storeRange then r else noRange                      
    return (case o of
        Left  v -> Expression_Variable    range v
        Right c -> Expression_Constructor range c
     )) <?> Texts.parserOperator
                         
aexp :: HParser Expression    
aexp = addRange (
    do 
        lexLPAREN
        ( -- dit haakje is nodig (snap niet waarom). Arjan
            try (do  -- de try vanwege (-) DEZE PARSER MOET OPNIEUW GESCHREVEN WORDEN !!!
                ue <- do
                    u <- unaryMinus
                    es <- exprChain
                    return (Expression_List noRange (u:es))
                es <- many (do { lexCOMMA; exp_ })
                lexRPAREN
                return $ 
                    if null es then
                        \r -> Expression_Parenthesized r ue
                    else 
                        \r -> Expression_Tuple r (ue:es))
            <|>                
            do      -- operator followed by optional expression
                    -- either full section (if there is no expression) or 
                    -- a left section (if there is)
                opExpr <- operatorAsExpression True
                me <- option Nothing (fmap Just fexp)
                lexRPAREN
                return $ \r -> 
                    Expression_InfixApplication r
                        MaybeExpression_Nothing
                        opExpr
                        (case me of 
                            Nothing -> MaybeExpression_Nothing
                            Just e  -> MaybeExpression_Just e) 
            <|>
            try (do -- right section, expression followed by operator
                    -- or a parenthesized expression (if no operator is found)
                e <- fexp
                mo <- option Nothing (fmap Just (operatorAsExpression True))
                lexRPAREN
                return $ \r ->
                    case mo of
                        Nothing -> Expression_Parenthesized r e
                        Just opExpr -> 
                            Expression_InfixApplication r
                                (MaybeExpression_Just e)
                                opExpr
                                MaybeExpression_Nothing
            )
            <|>
            do -- unit "()", expression between parenthesis or a tuple
                es <- commas exp_
                lexRPAREN
                return $ \r -> case es of
                    [] -> Expression_Constructor r (Name_Special r [] "()") -- !!!Name
                    [e] -> Expression_Parenthesized r e
                    _ -> Expression_Tuple r es
         )
    <|>
    do
        n <- varid
        return $ \r -> Expression_Variable r n
    <|>
    do
        n <- conid
        return $ \r -> Expression_Constructor r n
    <|>
    do 
        lexHOLE
        return $ \r -> Expression_Hole r (-1)
    <|>
    do
        feedback <- lexFeedback
        e        <- aexp
        return $ \r -> Expression_Feedback r feedback e
    <|>
    do
        lexeme LexMustUse
        e        <- aexp
        return $ \r -> Expression_MustUse r e
    <|>
    do 
        l <- literal
        return $ \r -> Expression_Literal r l
    <|>
    do
        lexLBRACKET
        aexp1
    ) <?> Texts.parserExpression

{-
Last four cases, rewritten to eliminate backtracking

aexp    -> ...
         | "[" aexp1
aexp1   -> "]" 
         | exp aexp2 "]"
aexp2   -> "|" qual1 "," ... "," qualn
         | ".." exp?
         | "," exp aexp3 
         |               (empty)
aexp3   -> ".." exp?
         | ( "," exp )* 
-}

aexp1 :: HParser (Range -> Expression)
aexp1 =
    do
        lexRBRACKET
        return $ \r -> Expression_Constructor r
                        (Name_Special r [] "[]") -- !!!Name
    <|>
    do
        e1 <- exp_
        e2 <- aexp2 e1
        lexRBRACKET
        return e2
        
aexp2 :: Expression -> HParser (Range -> Expression)    
aexp2 e1 = 
    do
        lexBAR
        qs <- commas1 qual
        return $ \r -> Expression_Comprehension r e1 qs
    <|> 
    do
        lexDOTDOT
        option (\r -> Expression_Enum r e1
                        MaybeExpression_Nothing 
                        MaybeExpression_Nothing) $
            do
                e2 <- exp_
                return $ \r -> Expression_Enum r e1
                                MaybeExpression_Nothing 
                                (MaybeExpression_Just e2) 
    <|>
    do
        lexCOMMA
        e2 <- exp_
        aexp3 e1 e2
    <|>
    return (\r -> Expression_List r [e1])

aexp3 :: Expression -> Expression -> HParser (Range -> Expression)    
aexp3 e1 e2 =
    do
        lexDOTDOT
        option (\r -> Expression_Enum r e1 
                        (MaybeExpression_Just e2)  
                        MaybeExpression_Nothing) $
            do
                e3 <- exp_
                return $ \r -> Expression_Enum r e1 
                                (MaybeExpression_Just e2)
                                (MaybeExpression_Just e3) 
    <|>
    do
        es <- many (do { lexCOMMA; exp_ })
        return $ \r -> Expression_List r (e1:e2:es)              

{-
stmts  -> "{" stmt1 ";" ... ";" stmtn "}"   (n>=0)  
-}

stmts :: HParser Statements
stmts = 
    withLayout stmt

{-
stmt    ->  "let" decls  
         |  pat "<-" exp  
         |  exp
-}

stmt :: HParser Statement
stmt = addRange $
    do
        lexLET
        ds <- decls
        option (\r -> Statement_Let r ds) $ do
            lexIN
            e <- exp_
            return (\r -> Statement_Expression r (Expression_Let r ds e))
    <|>
    do
        p <- try $
            do
                p <- pat
                lexLARROW
                return p
        e <- exp_
        return $ \r -> Statement_Generator r p e
    <|>
    do
        e <- exp_
        return $ \r -> Statement_Expression r e
        
{-
alts    ->  "{" alt1 ";" ... ";" altn "}" (n>=0)  
-}

alts :: HParser Alternatives
alts =
  do as <- withLayout alt
     return $ CollectFunctionBindings.mergeCaseFeedback as

{-
alt -> pat rhs
-}

alt :: HParser Alternative
alt = addRange $
    do fb <- lexCaseFeedback
       return $ \r -> Alternative_Feedback r fb $ Alternative_Hole r (-1)
    <|>
    do
       lexHOLE
       return $ \r -> Alternative_Hole r (-1)
    <|>
    do
        p <- pat
        b <- caseRhs
        return $ \r -> Alternative_Alternative r p b

{-
qual    ->  "let" decls  (local declaration)  
         |  pat "<-" exp  (generator)  
         |  exp  (guard)  
-}

qual :: HParser Qualifier
qual = addRange $
    do
        lexLET
        ds <- decls
        option (\r -> Qualifier_Let r ds) $ do
            lexIN
            e <- exp_
            return (\r -> Qualifier_Guard r (Expression_Let r ds e))
    <|>
    do
        p <- try $
            do
                p <- pat
                lexLARROW
                return p
        e <- exp_
        return $ \r -> Qualifier_Generator r p e
    <|>
    do
        e <- exp_
        return $ \r -> Qualifier_Guard r e

{-
pat  ->  pat0  
pati  ->  pati+1 [conop(n,i) pati+1]  
 |  lpati  
 |  rpati  
lpati  ->  (lpati | pati+1) conop(l,i) pati+1  
lpat6  ->  - (integer | float)  (negative literal)  
rpati  ->  pati+1 conop(r,i) (rpati | pati+1)  

See noRange in ParseCommon for an explanation of the parsing of infix expressions.

-}

pat :: HParser Pattern
pat = addRange $
    do  
        u <- unaryMinusPat
        ps <- fmap concat $ many $
            do
                o <- do { n <- conop; return (Pattern_Variable noRange n) }
                u' <- unaryMinusPat
                return (o : u')
        return $ \_ -> Pattern_List noRange (u ++ ps)
        
unaryMinusPat :: HParser [Pattern]
unaryMinusPat = 
    do 
        (n, mr) <- withRange (do { lexMINDOT; return floatUnaryMinusName } <|> 
                              do { lexMIN;    return intUnaryMinusName   } )
        (l, lr) <- withRange numericLiteral
        return 
            [ Pattern_Variable noRange (setNameRange n mr)
            , Pattern_Literal lr l
            ]
    <|>
    do
        p <- pat10
        return [p]
    
{-
pat10   ->  con apat*
         |  apat  
-}

pat10 :: HParser Pattern
pat10 = addRange (
    do  
        n  <- try con    
        ps <- many apat
        return $ \r -> Pattern_Constructor r n ps
    )
    <|>
    apat
    <?> Texts.parserPattern
       
{-
apat    ->  var ( "@" apat )?

         |  "(" ")"
         |  "(" pat ")"  (parenthesized pattern)  
         |  "(" pat1 "," ... "," patk ")"  (tuple pattern, k>=2)  

         |  "[" "]" 
         |  "[" pat1 "," ... "," patk "]"  (list pattern, k>=1)  

         |  "_"  (wildcard)  
         |  con  (arity con = 0)  
         |  literal  
         |  "~" apat    (irrefutable pattern)
-}

apat :: HParser Pattern
apat = addRange (
    do
        v <- try var -- because of parentheses
        option (\r -> Pattern_Variable r v) $ do
            lexAT
            p <- apat
            return $ \r -> Pattern_As r v p
    <|>
    do
        ps <- parens (commas pat)
        return $ \r -> case ps of
            [] -> Pattern_Constructor r (Name_Special r [] "()") [] -- !!!Name
            [p] -> Pattern_Parenthesized r p
            _ -> Pattern_Tuple r ps
    <|>
    do
        ps <- brackets (commas pat)
        return $ \r -> case ps of
            [] -> Pattern_Constructor r (Name_Special r [] "[]") [] -- !!!Name
            _ -> Pattern_List r ps
    <|> 
    do
        lexUNDERSCORE
        return $ \r -> Pattern_Wildcard r
    <|>
    do
        n <- con
        return $ \r -> Pattern_Constructor r n []
    <|>
    do
        l <- literal
        return $ \r -> Pattern_Literal r l
    <|>
    do  
        lexTILDE
        p <- apat
        return $ \r -> Pattern_Irrefutable r p
    ) <|> phole <?> Texts.parserPattern

phole :: HParser Pattern
phole = addRange (
    do
        lexHOLE
        return $ \r -> Pattern_Hole r (-1)
    )

{-
scontext -> class | "(" class1 "," ... "," classn ")"    (n>=0)
simpleclass -> tycls tyvar
         (other case in Haskell report at 'class' is not supported in Helium
          because we do not have type variable application)
-}

scontext :: HParser ContextItems
scontext = 
    do { c <- simpleclass; return [c] }
    <|>
    parens (commas simpleclass)

simpleclass :: HParser ContextItem
simpleclass = addRange (do
    c <- tycon
    (v, vr) <- withRange tyvar
    return $ \r -> ContextItem_ContextItem r c [Type_Variable vr v]
    )
    
{-
type  ->  btype ( "->" type )? 
-}

type_ :: HParser Type
type_ = addRange (
    do 
        left <- btype
        option (\_ -> left) $
            do
                (_, rangeArrow) <- withRange lexRARROW
                right <- type_
                return (\r -> Type_Application r False
                        (Type_Constructor rangeArrow (Name_Special rangeArrow [] "->")) [left, right]) -- !!!Name
    ) <?> Texts.parserType

{-
btype  ->  atype+
-}

btype :: HParser Type
btype = addRange (
    do
        ts <- many1 atype
        return $ \r -> case ts of
            [t] -> t
            (t:ts') -> Type_Application r True t ts'
            []  -> error "Pattern match failure in Parser.Parser.btype"
    ) <?> Texts.parserType

{-
atype   ->  tycon
         |  tyvar  
         |  "(" ")"  (unit type)  
         |  "(" type1 "," ... "," typek ")"  (tuple type, k>=2)  
         |  "(" type ")"  (parenthesized constructor)  
         |  "[" type "]"  (list type)  
-}

atype :: HParser Type
atype = addRange (
    do
        c <- tycon
        return (\r -> Type_Constructor r c)
    <|>
    do
        c <- tyvar
        return (\r -> Type_Variable r c)
    <|>
    do
        ts <- parens (commas type_)
        return (\r -> case ts of
            [] -> Type_Constructor r (Name_Special r [] "()") -- !!!Name
            [t] -> Type_Parenthesized r t
            _ -> let n = Name_Special r []  -- !!!Name
                            ( "(" ++ replicate (length ts - 1) ',' ++ ")" )
                 in Type_Application r False (Type_Constructor r n) ts
         )
    <|>
    do
        t <- brackets type_
        return $ \r ->
            let n = Name_Special r [] "[]" -- !!!Name
            in Type_Application r False (Type_Constructor r n) [t]
    ) <?> Texts.parserType

annotatedType :: HParser Type -> HParser AnnotatedType
annotatedType p = addRange $
    do
        t <- p
        return (\r -> AnnotatedType_AnnotatedType r False t)

literal :: ParsecT [Token] SourcePos Identity Literal
literal = addRange (
    do
        i <- lexInt
        return $ \r -> Literal_Int r i
    <|>
    do
        d <- lexDouble
        return $ \r -> Literal_Float r d
    <|>
    do
        c <- lexChar
        return $ \r -> Literal_Char r c
    <|>
    do
        s <- lexString
        return $ \r -> Literal_String r s
    ) <?> Texts.parserLiteral

numericLiteral :: ParsecT [Token] SourcePos Identity Literal
numericLiteral = addRange (
    do
        i <- lexInt
        return $ \r -> Literal_Int r i
    <|>
    do
        d <- lexDouble
        return $ \r -> Literal_Float r d
    ) <?> Texts.parserNumericLiteral