{
#if  __GLASGOW_HASKELL__ > 800
{-# OPTIONS_GHC -Wno-error=missing-signatures #-}
#endif
{-# LANGUAGE PatternGuards #-}

{-| The parser is generated by Happy (<http://www.haskell.org/happy>).
 -
 - Ideally, ranges should be as precise as possible, to get messages that
 - emphasize precisely the faulting term(s) upon error.
 -
 - However, interactive highlighting is only applied at the end of each
 - mutual block, keywords are only highlighted once (see
 - `TypeChecking.Rules.Decl'). So if the ranges of two declarations
 - interleave, one must ensure that keyword ranges are not included in
 - the intersection. (Otherwise they are uncolored by the interactive
 - highlighting.)
 -
 -}
module Agda.Syntax.Parser.Parser (
      moduleParser
    , moduleNameParser
    , exprParser
    , exprWhereParser
    , tokensParser
    , holeContentParser
    , splitOnDots  -- only used by the internal test-suite
    ) where

import Prelude hiding ( null )

import Control.Applicative ( (<|>) )
import Control.Monad
import Control.Monad.State

import Data.Bifunctor (first, second)
import Data.Char
import Data.DList (DList)
import qualified Data.DList as DL
import qualified Data.List as List
import Data.Maybe
import Data.Semigroup ((<>), sconcat)
import qualified Data.Traversable as T

import Agda.Syntax.Position hiding (tests)
import Agda.Syntax.Parser.Monad
import Agda.Syntax.Parser.Lexer
import Agda.Syntax.Parser.Tokens
import Agda.Syntax.Concrete as C
import Agda.Syntax.Concrete.Attribute
import Agda.Syntax.Concrete.Pattern
import Agda.Syntax.Common
import Agda.Syntax.Notation
import Agda.Syntax.Literal

import Agda.TypeChecking.Positivity.Occurrence hiding (tests)

import Agda.Utils.Either hiding (tests)
import Agda.Utils.Functor
import Agda.Utils.Hash
import Agda.Utils.List ( spanJust, chopWhen )
import Agda.Utils.List1 ( List1, pattern (:|), (<|) )
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Pretty hiding ((<>))
import Agda.Utils.Singleton
import qualified Agda.Utils.Maybe.Strict as Strict
import qualified Agda.Utils.List1 as List1
import qualified Agda.Utils.List2 as List2

import Agda.Utils.Impossible

}

%name tokensParser Tokens
%name exprParser Expr
%name exprWhereParser ExprWhere
%name moduleParser File
%name moduleNameParser ModuleName
%name funclauseParser FunClause
%name holeContentParser HoleContent

%tokentype { Token }
%monad { Parser }
%lexer { lexer } { TokEOF{} }

%expect 8
-- * shift/reduce for \ x y z -> foo = bar
--   shifting means it'll parse as \ x y z -> (foo = bar) rather than
--   (\ x y z -> foo) = bar
--
-- * Telescope let and do-notation let.
--      Expr2 -> 'let' Declarations . LetBody
--      TypedBinding -> '(' 'let' Declarations . ')'
--        ')'   shift, and enter state 486
--              (reduce using rule 189)
--   A do-block cannot end in a 'let' so committing to TypedBinding with a
--   shift is the right thing to do here.
--
-- * Named implicits in TypedBinding {x = y}. When encountering the '=' shift
--   treats this as a named implicit and reducing would fail later.

-- This is a trick to get rid of shift/reduce conflicts arising because we want
-- to parse things like "m >>= \x -> k x". See the Expr rule for more
-- information.
%nonassoc LOWEST
%nonassoc '->'

%token
    'abstract'                { TokKeyword KwAbstract $$ }
    'codata'                  { TokKeyword KwCoData $$ }
    'coinductive'             { TokKeyword KwCoInductive $$ }
    'constructor'             { TokKeyword KwConstructor $$ }
    'data'                    { TokKeyword KwData $$ }
    'eta-equality'            { TokKeyword KwEta $$ }
    'field'                   { TokKeyword KwField $$ }
    'forall'                  { TokKeyword KwForall $$ }
    'variable'                { TokKeyword KwVariable $$ }
    'hiding'                  { TokKeyword KwHiding $$ }
    'import'                  { TokKeyword KwImport $$ }
    'in'                      { TokKeyword KwIn $$ }
    'inductive'               { TokKeyword KwInductive $$ }
    'infix'                   { TokKeyword KwInfix $$ }
    'infixl'                  { TokKeyword KwInfixL $$ }
    'infixr'                  { TokKeyword KwInfixR $$ }
    'instance'                { TokKeyword KwInstance $$ }
    'overlap'                 { TokKeyword KwOverlap $$ }
    'let'                     { TokKeyword KwLet $$ }
    'macro'                   { TokKeyword KwMacro $$ }
    'module'                  { TokKeyword KwModule $$ }
    'interleaved'             { TokKeyword KwInterleaved $$ }
    'mutual'                  { TokKeyword KwMutual $$ }
    'no-eta-equality'         { TokKeyword KwNoEta $$ }
    'open'                    { TokKeyword KwOpen $$ }
    'pattern'                 { TokKeyword KwPatternSyn $$ }
    'postulate'               { TokKeyword KwPostulate $$ }
    'primitive'               { TokKeyword KwPrimitive $$ }
    'private'                 { TokKeyword KwPrivate $$ }
    'public'                  { TokKeyword KwPublic $$ }
    'quote'                   { TokKeyword KwQuote $$ }
    'quoteTerm'               { TokKeyword KwQuoteTerm $$ }
    'record'                  { TokKeyword KwRecord $$ }
    'renaming'                { TokKeyword KwRenaming $$ }
    'rewrite'                 { TokKeyword KwRewrite $$ }
    'syntax'                  { TokKeyword KwSyntax $$ }
    'tactic'                  { TokKeyword KwTactic $$ }
    'to'                      { TokKeyword KwTo $$ }
    'unquote'                 { TokKeyword KwUnquote $$ }
    'unquoteDecl'             { TokKeyword KwUnquoteDecl $$ }
    'unquoteDef'              { TokKeyword KwUnquoteDef $$ }
    'using'                   { TokKeyword KwUsing $$ }
    'where'                   { TokKeyword KwWhere $$ }
    'do'                      { TokKeyword KwDo $$ }
    'with'                    { TokKeyword KwWith $$ }

    'BUILTIN'                 { TokKeyword KwBUILTIN $$ }
    'CATCHALL'                { TokKeyword KwCATCHALL $$ }
    'DISPLAY'                 { TokKeyword KwDISPLAY $$ }
    'ETA'                     { TokKeyword KwETA $$ }
    'FOREIGN'                 { TokKeyword KwFOREIGN $$ }
    'COMPILE'                 { TokKeyword KwCOMPILE $$ }
    'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $$ }
    'INJECTIVE'               { TokKeyword KwINJECTIVE $$ }
    'INLINE'                  { TokKeyword KwINLINE $$ }
    'NOINLINE'                { TokKeyword KwNOINLINE $$ }
    'MEASURE'                 { TokKeyword KwMEASURE $$ }
    'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $$ }
    'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $$ }
    'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $$ }
    'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $$ }
    'NON_COVERING'            { TokKeyword KwNON_COVERING $$ }
    'NOT_PROJECTION_LIKE'     { TokKeyword KwNOT_PROJECTION_LIKE $$ }
    'OPTIONS'                 { TokKeyword KwOPTIONS $$ }
    'POLARITY'                { TokKeyword KwPOLARITY $$ }
    'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $$ }
    'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $$ }
    'REWRITE'                 { TokKeyword KwREWRITE $$ }
    'STATIC'                  { TokKeyword KwSTATIC $$ }
    'TERMINATING'             { TokKeyword KwTERMINATING $$ }

    tex                       { TokTeX $$ }
    comment                   { TokComment $$ }

    '...'                     { TokSymbol SymEllipsis $$ }
    '..'                      { TokSymbol SymDotDot $$ }
    '.'                       { TokSymbol SymDot $$ }
    ';'                       { TokSymbol SymSemi $$ }
    ':'                       { TokSymbol SymColon $$ }
    '='                       { TokSymbol SymEqual $$ }
    '_'                       { TokSymbol SymUnderscore $$ }
    '?'                       { TokSymbol SymQuestionMark $$ }
    '->'                      { TokSymbol SymArrow $$ }
    '\\'                      { TokSymbol SymLambda $$ }
    '@'                       { TokSymbol SymAs $$ }
    '|'                       { TokSymbol SymBar $$ }
    '('                       { TokSymbol SymOpenParen $$ }
    ')'                       { TokSymbol SymCloseParen $$ }
    '(|'                      { TokSymbol SymOpenIdiomBracket $$ }
    '|)'                      { TokSymbol SymCloseIdiomBracket $$ }
    '(|)'                     { TokSymbol SymEmptyIdiomBracket $$ }
    '{{'                      { TokSymbol SymDoubleOpenBrace $$ }
    '}}'                      { TokSymbol SymDoubleCloseBrace $$ }
    '{'                       { TokSymbol SymOpenBrace $$ }
    '}'                       { TokSymbol SymCloseBrace $$ }
--    ':{'                      { TokSymbol SymColonBrace $$ }
    vopen                     { TokSymbol SymOpenVirtualBrace $$ }
    vclose                    { TokSymbol SymCloseVirtualBrace $$ }
    vsemi                     { TokSymbol SymVirtualSemi $$ }
    '{-#'                     { TokSymbol SymOpenPragma $$ }
    '#-}'                     { TokSymbol SymClosePragma $$ }

    id                        { TokId $$ }
    q_id                      { TokQId $$ }

    string                    { TokString $$ }
    literal                   { TokLiteral $$ }

%%

{--------------------------------------------------------------------------
    Parsing the token stream. Used by the TeX compiler.
 --------------------------------------------------------------------------}

-- Parse a list of tokens.
Tokens :: { [Token] }
Tokens : TokensR        { reverse $1 }

-- Happy is much better at parsing left recursive grammars (constant
-- stack size vs. linear stack size for right recursive).
TokensR :: { [Token] }
TokensR : TokensR Token { $2 : $1 }
        |               { [] }

-- Parse single token.
Token :: { Token }
Token
      -- Please keep these keywords in alphabetical order!
    : 'abstract'                { TokKeyword KwAbstract $1 }
    | 'codata'                  { TokKeyword KwCoData $1 }
    | 'coinductive'             { TokKeyword KwCoInductive $1 }
    | 'constructor'             { TokKeyword KwConstructor $1 }
    | 'data'                    { TokKeyword KwData $1 }
    | 'do'                      { TokKeyword KwDo $1 }
    | 'eta-equality'            { TokKeyword KwEta $1 }
    | 'field'                   { TokKeyword KwField $1 }
    | 'forall'                  { TokKeyword KwForall $1 }
    | 'hiding'                  { TokKeyword KwHiding $1 }
    | 'import'                  { TokKeyword KwImport $1 }
    | 'in'                      { TokKeyword KwIn $1 }
    | 'inductive'               { TokKeyword KwInductive $1 }
    | 'infix'                   { TokKeyword KwInfix $1 }
    | 'infixl'                  { TokKeyword KwInfixL $1 }
    | 'infixr'                  { TokKeyword KwInfixR $1 }
    | 'instance'                { TokKeyword KwInstance $1 }
    | 'let'                     { TokKeyword KwLet $1 }
    | 'macro'                   { TokKeyword KwMacro $1 }
    | 'module'                  { TokKeyword KwModule $1 }
    | 'interleaved'             { TokKeyword KwInterleaved $1 }
    | 'mutual'                  { TokKeyword KwMutual $1 }
    | 'no-eta-equality'         { TokKeyword KwNoEta $1 }
    | 'open'                    { TokKeyword KwOpen $1 }
    | 'overlap'                 { TokKeyword KwOverlap $1 }
    | 'pattern'                 { TokKeyword KwPatternSyn $1 }
    | 'postulate'               { TokKeyword KwPostulate $1 }
    | 'primitive'               { TokKeyword KwPrimitive $1 }
    | 'private'                 { TokKeyword KwPrivate $1 }
    | 'public'                  { TokKeyword KwPublic $1 }
    | 'quote'                   { TokKeyword KwQuote $1 }
    | 'quoteTerm'               { TokKeyword KwQuoteTerm $1 }
    | 'record'                  { TokKeyword KwRecord $1 }
    | 'renaming'                { TokKeyword KwRenaming $1 }
    | 'rewrite'                 { TokKeyword KwRewrite $1 }
    | 'syntax'                  { TokKeyword KwSyntax $1 }
    | 'tactic'                  { TokKeyword KwTactic $1 }
    | 'to'                      { TokKeyword KwTo $1 }
    | 'unquote'                 { TokKeyword KwUnquote $1 }
    | 'unquoteDecl'             { TokKeyword KwUnquoteDecl $1 }
    | 'unquoteDef'              { TokKeyword KwUnquoteDef $1 }
    | 'using'                   { TokKeyword KwUsing $1 }
    | 'variable'                { TokKeyword KwVariable $1 }
    | 'where'                   { TokKeyword KwWhere $1 }
    | 'with'                    { TokKeyword KwWith $1 }

      -- Please keep these pragmas in alphabetical order!
    | 'BUILTIN'                 { TokKeyword KwBUILTIN $1 }
    | 'CATCHALL'                { TokKeyword KwCATCHALL $1 }
    | 'COMPILE'                 { TokKeyword KwCOMPILE $1 }
    | 'DISPLAY'                 { TokKeyword KwDISPLAY $1 }
    | 'ETA'                     { TokKeyword KwETA $1 }
    | 'FOREIGN'                 { TokKeyword KwFOREIGN $1 }
    | 'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $1 }
    | 'INJECTIVE'               { TokKeyword KwINJECTIVE $1 }
    | 'INLINE'                  { TokKeyword KwINLINE $1 }
    | 'MEASURE'                 { TokKeyword KwMEASURE $1 }
    | 'NOINLINE'                { TokKeyword KwNOINLINE $1 }
    | 'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $1 }
    | 'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $1 }
    | 'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $1 }
    | 'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $1 }
    | 'NON_COVERING'            { TokKeyword KwNON_COVERING $1 }
    | 'NOT_PROJECTION_LIKE'     { TokKeyword KwNOT_PROJECTION_LIKE $1 }
    | 'OPTIONS'                 { TokKeyword KwOPTIONS $1 }
    | 'POLARITY'                { TokKeyword KwPOLARITY $1 }
    | 'REWRITE'                 { TokKeyword KwREWRITE $1 }
    | 'STATIC'                  { TokKeyword KwSTATIC $1 }
    | 'TERMINATING'             { TokKeyword KwTERMINATING $1 }
    | 'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $1 }
    | 'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $1 }

    | tex                       { TokTeX $1 }
    | comment                   { TokComment $1 }

    | '...'                     { TokSymbol SymEllipsis $1 }
    | '..'                      { TokSymbol SymDotDot $1 }
    | '.'                       { TokSymbol SymDot $1 }
    | ';'                       { TokSymbol SymSemi $1 }
    | ':'                       { TokSymbol SymColon $1 }
    | '='                       { TokSymbol SymEqual $1 }
    | '_'                       { TokSymbol SymUnderscore $1 }
    | '?'                       { TokSymbol SymQuestionMark $1 }
    | '->'                      { TokSymbol SymArrow $1 }
    | '\\'                      { TokSymbol SymLambda $1 }
    | '@'                       { TokSymbol SymAs $1 }
    | '|'                       { TokSymbol SymBar $1 }
    | '('                       { TokSymbol SymOpenParen $1 }
    | ')'                       { TokSymbol SymCloseParen $1 }
    | '(|'                      { TokSymbol SymOpenIdiomBracket $1 }
    | '|)'                      { TokSymbol SymCloseIdiomBracket $1 }
    | '(|)'                     { TokSymbol SymEmptyIdiomBracket $1 }
    | '{{'                      { TokSymbol SymDoubleOpenBrace $1 }
    | '}}'                      { TokSymbol SymDoubleCloseBrace $1 }
    | '{'                       { TokSymbol SymOpenBrace $1 }
    | '}'                       { TokSymbol SymCloseBrace $1 }
    | vopen                     { TokSymbol SymOpenVirtualBrace $1 }
    | vclose                    { TokSymbol SymCloseVirtualBrace $1 }
    | vsemi                     { TokSymbol SymVirtualSemi $1 }
    | '{-#'                     { TokSymbol SymOpenPragma $1 }
    | '#-}'                     { TokSymbol SymClosePragma $1 }

    | id                        { TokId $1 }
    | q_id                      { TokQId $1 }
    | string                    { TokString $1 }

    | literal                   { TokLiteral $1 }

{--------------------------------------------------------------------------
    Top level
 --------------------------------------------------------------------------}

File :: { Module }
File : vopen TopLevel maybe_vclose { takeOptionsPragmas $2 }

maybe_vclose :: { () }
maybe_vclose : {- empty -} { () }
             | vclose      { () }

{--------------------------------------------------------------------------
    Meta rules
 --------------------------------------------------------------------------}

{-  A layout block might have to be closed by a parse error. Example:
        let x = e in e'
    Here the 'let' starts a layout block which should end before the 'in'.  The
    problem is that the lexer doesn't know this, so there is no virtual close
    brace. However when the parser sees the 'in' there will be a parse error.
    This is our cue to close the layout block.
-}
close :: { () }
close : vclose  { () }
      | error   {% popBlock }


-- You can use concrete semi colons in a layout block started with a virtual
-- brace, so we don't have to distinguish between the two semi colons. You can't
-- use a virtual semi colon in a block started by a concrete brace, but this is
-- simply because the lexer will not generate virtual semis in this case.
semi :: { Interval }
semi : ';'    { $1 }
     | vsemi  { $1 }


-- Enter the 'imp_dir' lex state, where we can parse the keyword 'to'.
beginImpDir :: { () }
beginImpDir : {- empty -}   {% pushLexState imp_dir }

{--------------------------------------------------------------------------
    Helper rules
 --------------------------------------------------------------------------}

-- A float. Used in fixity declarations.
Float :: { Ranged Double }
Float : literal {% forM $1 $ \case
                   { LitNat   i -> return $ fromInteger i
                   ; LitFloat d -> return d
                   ; _          -> parseError $ "Expected floating point number"
                   }
                }


{--------------------------------------------------------------------------
    Names
 --------------------------------------------------------------------------}

-- A name is really a sequence of parts, but the lexer just sees it as a
-- string, so we have to do the translation here.
Id :: { Name }
Id : id     {% mkName $1 }

-- Space separated list of one or more identifiers.
SpaceIds :: { List1 Name }
SpaceIds
    : Id SpaceIds { $1 <| $2 }
    | Id          { singleton $1 }

-- When looking for a double closed brace, we accept either a single token '}}'
-- (which is what the unicode character "RIGHT WHITE CURLY BRACKET" is
-- postprocessed into in LexActions.hs), but also two consecutive tokens '}'
-- (which a string '}}' is lexed to).  This small hack allows us to keep
-- "record { a = record { }}" working. In the second case, we check that the two
-- tokens '}' are immediately consecutive.
DoubleCloseBrace :: { Range }
DoubleCloseBrace
  : '}}' { getRange $1 }
  | '}' '}' {%
      if posPos (fromJust (rEnd' (getRange $2))) -
         posPos (fromJust (rStart' (getRange $1))) > 2
      then parseErrorRange $2 "Expecting '}}', found separated '}'s."
      else return $ getRange ($1, $2)
    }

-- A possibly dotted identifier.
MaybeDottedId :: { Arg Name }
MaybeDottedId
  : '..' Id { setRelevance NonStrict $ defaultArg $2 }
  | '.'  Id { setRelevance Irrelevant $ defaultArg $2 }
  | Id      { defaultArg $1 }

-- Space separated list of one or more possibly dotted identifiers.
MaybeDottedIds :: { List1 (Arg Name) }
MaybeDottedIds
    : MaybeDottedId MaybeDottedIds { $1 <| $2 }
    | MaybeDottedId                { singleton $1 }

-- Space separated list of one or more identifiers, some of which may
-- be surrounded by braces or dotted.
ArgIds :: { List1 (Arg Name) }
ArgIds
    : MaybeDottedId ArgIds            { $1 <| $2 }
    | MaybeDottedId                   { singleton $1 }
    | '{{' MaybeDottedIds DoubleCloseBrace ArgIds { fmap makeInstance $2 <> $4 }
    | '{{' MaybeDottedIds DoubleCloseBrace        { fmap makeInstance $2 }
    | '{' MaybeDottedIds '}' ArgIds   { fmap hide $2 <> $4 }
    | '{' MaybeDottedIds '}'          { fmap hide $2 }
    | '.' '{' SpaceIds '}' ArgIds     { fmap (hide . setRelevance Irrelevant . defaultArg) $3 <> $5 }
    | '.' '{' SpaceIds '}'            { fmap (hide . setRelevance Irrelevant . defaultArg) $3 }
    | '.' '{{' SpaceIds DoubleCloseBrace ArgIds   { fmap (makeInstance . setRelevance Irrelevant . defaultArg) $3 <> $5 }
    | '.' '{{' SpaceIds DoubleCloseBrace          { fmap (makeInstance . setRelevance Irrelevant . defaultArg) $3 }
    | '..' '{' SpaceIds '}' ArgIds    { fmap (hide . setRelevance NonStrict . defaultArg) $3 <> $5 }
    | '..' '{' SpaceIds '}'           { fmap (hide . setRelevance NonStrict . defaultArg) $3 }
    | '..' '{{' SpaceIds DoubleCloseBrace ArgIds  { fmap (makeInstance . setRelevance NonStrict . defaultArg) $3 <> $5 }
    | '..' '{{' SpaceIds DoubleCloseBrace         { fmap (makeInstance . setRelevance NonStrict . defaultArg) $3 }

-- Modalities preceeding identifiers

ModalArgIds :: { ([Attr], List1 (Arg Name)) }
ModalArgIds : Attributes ArgIds  {% ($1,) `fmap` mapM (applyAttrs $1) $2 }

-- Attributes are parsed as '@' followed by an atomic expression.

Attribute :: { Attr }
Attribute : '@' ExprOrAttr  {% setRange (getRange ($1,$2)) `fmap` toAttribute $2 }

-- Parse a reverse list of modalities

Attributes :: { [Attr] }
Attributes : {- empty -}  { [] }
  | Attributes Attribute { $2 : $1 }

Attributes1 :: { List1 Attr }
Attributes1 : Attribute  { singleton $1 }
  | Attributes1 Attribute { $2 <| $1 }

QId :: { QName }
QId : q_id  {% mkQName $1 }
    | Id    { QName $1 }


-- A module name is just a qualified name
ModuleName :: { QName }
ModuleName : QId { $1 }


-- A binding variable. Can be '_'
BId :: { Name }
BId : Id    { $1 }
    | '_'   { setRange (getRange $1) simpleHole }

{- UNUSED
-- A binding variable. Can be '_'
MaybeDottedBId :: { (Relevance, Name) }
MaybeDottedBId
    : BId        { (Relevant  , $1) }
    | '.' BId    { (Irrelevant, $2) }
    | '..' BId   { (NonStrict, $2) }
-}


-- Space separated list of binding identifiers. Used in fixity
-- declarations infixl 100 + -
SpaceBIds :: { List1 Name }
SpaceBIds
    : BId SpaceBIds { $1 <| $2 }
    | BId           { singleton $1 }

{- DOES PRODUCE REDUCE/REDUCE CONFLICTS!
-- Space-separated list of binding identifiers. Used in dependent
-- function spaces: (x y z : Nat) -> ...
-- (Used to be comma-separated; hence the name)
-- QUESTION: Should this be replaced by SpaceBIds above?
--CommaBIds :: { [(Relevance,Name)] }
CommaBIds :: { [Name] }
CommaBIds
    : CommaBIds BId { $1 ++ [$2] }  -- SWITCHING DOES NOT HELP
    | BId           { [$1] }
-}

-- Space-separated list of binding identifiers. Used in dependent
-- function spaces: (x y z : Nat) -> ...
-- (Used to be comma-separated; hence the name)
-- QUESTION: Should this be replaced by SpaceBIds above?
-- Andreas, 2011-04-07 the trick avoids reduce/reduce conflicts
-- when parsing  (x y z : A) -> B
-- at point (x y  it is not clear whether x y is an application or
-- a variable list. We could be parsing (x y z) -> B
-- with ((x y) z) being a type.
CommaBIds :: { List1 (NamedArg Binder) }
CommaBIds : CommaBIdAndAbsurds {%
    case $1 of
      Left ns -> return ns
      Right _ -> parseError $ "expected sequence of bound identifiers, not absurd pattern"
    }

CommaBIdAndAbsurds :: { Either (List1 (NamedArg Binder)) (List1 Expr) }
CommaBIdAndAbsurds
  : Application {% boundNamesOrAbsurd $1 }
  | QId '=' QId {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Left $3) }
  | '_' '=' QId {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Left $3) }
  | QId '=' '_' {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Right $ getRange $3) }
  | '_' '=' '_' {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Right $ getRange $3) }

-- Parse a sequence of identifiers, including hiding info.
-- Does not include instance arguments.
-- E.g. x {y z} _ {v}
-- To be used in typed bindings, like (x {y z} _ {v} : Nat).
BIdsWithHiding :: { List1 (NamedArg Binder) }
BIdsWithHiding : Application {%
  -- interpret an expression as a name and maybe a pattern
  case mapM exprAsNameOrHiddenNames $1 of
    Nothing   -> parseError "Expected sequence of possibly hidden bound identifiers"
    Just good -> forM (sconcat good) $ updateNamedArgA $ \ (n, me) -> do
                   p <- traverse exprToPattern me
                   pure $ Binder p (mkBoundName_ n)
    }


-- Space separated list of strings in a pragma.
PragmaStrings :: { [String] }
PragmaStrings
    : {- empty -}           { [] }
    | string PragmaStrings  { snd $1 : $2 }
{- Unused
PragmaString :: { String }
PragmaString
    : string { snd $1 }
-}
Strings :: { [(Interval, String)] }
Strings : {- empty -}    { [] }
        | string Strings { $1 : $2 }

ForeignCode :: { DList (Interval, String) }
ForeignCode
  : {- empty -} { mempty }
  | string ForeignCode { $1 `DL.cons` $2 }
  | '{-#' ForeignCode '#-}' ForeignCode
    { (($1, "{-#") `DL.cons` $2) <> (($3, "#-}") `DL.cons` $4) }

PragmaName :: { Name }
PragmaName : string {% mkName $1 }

PragmaQName :: { QName }
PragmaQName : string {% pragmaQName $1 }  -- Issue 2125. WAS: string {% fmap QName (mkName $1) }

PragmaQNames :: { [QName] }
PragmaQNames : Strings {% mapM pragmaQName $1 }

{--------------------------------------------------------------------------
    Expressions (terms and types)
 --------------------------------------------------------------------------}

{-  Expressions. You might expect lambdas and lets to appear in the first
    expression category (lowest precedence). The reason they don't is that we
    want to parse things like

        m >>= \x -> k x

    This will leads to a conflict in the following case

        m >>= \x -> k x >>= \y -> k' y

    At the second '>>=' we can either shift or reduce. We solve this problem
    using Happy's precedence directives. The rule 'Expr -> Expr1' (which is the
    rule you shouldn't use to reduce when seeing '>>=') is given LOWEST
    precedence.  The terminals '->' and op (which is what you should shift)
    is given higher precedence.
-}

-- Top level: Function types.
Expr :: { Expr }
Expr
  : TeleArrow Expr                      { Pi $1 $2 }
  | Application3 '->' Expr              { Fun (getRange ($1,$2,$3))
                                              (defaultArg $ rawApp $1)
                                              $3 }
  | Attributes1 Application3 '->' Expr  {% applyAttrs1 $1 (defaultArg $ rawApp $2) <&> \ dom ->
                                             Fun (getRange ($1,$2,$3,$4)) dom $4 }
  | Expr1 %prec LOWEST                  { $1 }

-- Level 1: Application
Expr1 :: { Expr }
Expr1
  : UnnamedWithExprs
      {% case $1 of
           { e :| [] -> return e
           ; e :| es -> return $ WithApp (fuseRange e es) e es
           }
      }

WithExprs :: { List1 (Named Name Expr) }
WithExprs
  : Application3 'in' Id     '|' WithExprs { named $3  (rawApp $1) <| $5 }
  | Application3 {- empty -} '|' WithExprs { unnamed   (rawApp $1) <| $3 }
  | Application3 'in' Id                   { singleton (named $3 (rawApp $1)) }
  | Application3 {- empty -}               { singleton (unnamed  (rawApp $1)) }

UnnamedWithExprs :: { List1 Expr }
UnnamedWithExprs
  :  Application3 '|' UnnamedWithExprs { (rawApp $1) <| $3 }
  | {- empty -} Application            { singleton (rawApp $1) }

Application :: { List1 Expr }
Application
    : Expr2             { singleton $1 }
    | Expr3 Application { $1 <| $2 }

-- Level 2: Lambdas and lets
Expr2 :: { Expr }
Expr2
    : '\\' LamBindings Expr        { Lam (getRange ($1,$2,$3)) $2 $3 }
    | ExtendedOrAbsurdLam          { $1 }
    | 'forall' ForallBindings Expr { forallPi $2 $3 }
    | 'let' Declarations LetBody   { Let (getRange ($1,$2,$3)) $2 $3 }
    | 'do' vopen DoStmts close     { DoBlock (getRange ($1, $3)) $3 }
    | Expr3                        { $1 }
    | 'tactic' Application3        { Tactic (getRange ($1, $2)) (rawApp $2) }

LetBody :: { Maybe Expr }
LetBody : 'in' Expr   { Just $2 }
        | {- empty -} { Nothing }

ExtendedOrAbsurdLam :: { Expr }
ExtendedOrAbsurdLam
    : '\\'             '{' LamClauses '}'                  {% extLam (getRange ($1, $2, $4))     []                $3 }
    | '\\' Attributes1 '{' LamClauses '}'                  {% extLam (getRange ($1, $3, $5))     (List1.toList $2) $4 }
    | '\\'             'where' vopen LamWhereClauses close {% extLam (getRange ($1, $2, $3, $5)) []                $4 }
    | '\\' Attributes1 'where' vopen LamWhereClauses close {% extLam (getRange ($1, $3, $4, $6)) (List1.toList $2) $5 }
    | '\\'             AbsurdLamBindings                   {% extOrAbsLam (getRange $1) []                $2 }
    | '\\' Attributes1 AbsurdLamBindings                   {% extOrAbsLam (getRange $1) (List1.toList $2) $3 }

Application3 :: { List1 Expr }
Application3
    : Expr3              { singleton $1 }
    | Expr3 Application3 { $1 <| $2 }

-- Christian Sattler, 2017-08-04, issue #2671
-- We allow empty lists of expressions for the LHS of extended lambda clauses.
-- I am not sure what Application3 is otherwise used for, so I keep the
-- original type and create this copy solely for extended lambda clauses.
Application3PossiblyEmpty :: { [Expr] }
Application3PossiblyEmpty
    :                                 { [] }
    | Expr3 Application3PossiblyEmpty { $1 : $2 }

-- Level 3: Atoms
Expr3Curly :: { Expr }
Expr3Curly
    : '{' Expr4 '}'               {% HiddenArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }
    | '{' '}'                     { let r = fuseRange $1 $2 in HiddenArg r $ unnamed $ Absurd r }
    | '{{' Expr4 DoubleCloseBrace {% InstanceArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }
    | '{{' DoubleCloseBrace       { let r = fuseRange $1 $2 in InstanceArg r $ unnamed $ Absurd r }

Expr3NoCurly :: { Expr }
Expr3NoCurly
    : '?'                               { QuestionMark (getRange $1) Nothing }
    | '_'                               { Underscore (getRange $1) Nothing }
    | 'quote'                           { Quote (getRange $1) }
    | 'quoteTerm'                       { QuoteTerm (getRange $1) }
    | 'unquote'                         { Unquote (getRange $1) }
    | '(|' UnnamedWithExprs '|)'        { IdiomBrackets (getRange ($1,$2,$3)) (List1.toList $2) }
    | '(|)'                             { IdiomBrackets (getRange $1) [] }
    | '(' ')'                           { Absurd (fuseRange $1 $2) }
    | Id '@' Expr3                      { As (getRange ($1,$2,$3)) $1 $3 }
    | '.' Expr3                         { Dot (fuseRange $1 $2) $2 }
    | '..' Expr3                        { DoubleDot (fuseRange $1 $2) $2 }
    | 'record' '{' RecordAssignments '}' { Rec (getRange ($1,$2,$3,$4)) $3 }
    | 'record' Expr3NoCurly '{' FieldAssignments '}' { RecUpdate (getRange ($1,$2,$3,$4,$5)) $2 $4 }
    | '...'                             { Ellipsis (getRange $1) }
    | ExprOrAttr                       { $1 }

-- Level 4: Maybe named, or cubical faces
Expr4 :: { Expr }
Expr4 : Expr1 '=' Expr { Equal (getRange ($1, $2, $3)) $1 $3 }
      | Expr           { $1 }

ExprOrAttr :: { Expr }
ExprOrAttr
    : QId           { Ident $1 }
    | literal       { Lit (getRange $1) (rangedThing $1) }
    | '(' Expr4 ')' { Paren (getRange ($1,$2,$3)) $2 }
    -- ^ this is needed for cubical stuff

Expr3 :: { Expr }
Expr3
    : Expr3Curly   { $1 }
    | Expr3NoCurly { $1 }

RecordAssignments :: { RecordAssignments }
RecordAssignments
  : {- empty -}        { [] }
  | RecordAssignments1 { List1.toList $1 }

RecordAssignments1 :: { List1 RecordAssignment }
RecordAssignments1
  : RecordAssignment                        { singleton $1 }
  | RecordAssignment ';' RecordAssignments1 { $1 <| $3 }

RecordAssignment :: { RecordAssignment }
RecordAssignment
  : FieldAssignment  { Left  $1 }
  | ModuleAssignment { Right $1 }

ModuleAssignment :: { ModuleAssignment }
ModuleAssignment
  : ModuleName OpenArgs ImportDirective  { ModuleAssignment $1 $2 $3 }

FieldAssignments :: { [FieldAssignment] }
FieldAssignments
  : {- empty -}       { [] }
  | FieldAssignments1 { List1.toList $1 }

FieldAssignments1 :: { List1 FieldAssignment }
FieldAssignments1
  : FieldAssignment                       { singleton $1 }
  | FieldAssignment ';' FieldAssignments1 { $1 <| $3 }

FieldAssignment :: { FieldAssignment }
FieldAssignment
  : Id '=' Expr   { FieldAssignment $1 $3 }

{--------------------------------------------------------------------------
    Bindings
 --------------------------------------------------------------------------}

-- "Delta ->" to avoid conflict between Delta -> Gamma and Delta -> A.
TeleArrow :: { Telescope1 }
TeleArrow : Telescope1 '->' { $1 }

Telescope1 :: { Telescope1 }
Telescope1 : TypedBindings { $1 }

TypedBindings :: { List1 TypedBinding }
TypedBindings
    : TypedBinding TypedBindings { $1 <| $2 }
    | TypedBinding               { singleton $1 }


-- A typed binding is either (x1 .. xn : A) or   {y1 .. ym : B}
-- Andreas, 2011-04-07: or  .(x1 .. xn : A) or  .{y1 .. ym : B}
-- Andreas, 2011-04-27: or ..(x1 .. xn : A) or ..{y1 .. ym : B}
TypedBinding :: { TypedBinding }
TypedBinding
    : '.' '(' TBindWithHiding ')'    { setRange (getRange ($2,$3,$4)) $
                             setRelevance Irrelevant $3 }
    | '.' '{' TBind '}'    { setRange (getRange ($2,$3,$4)) $
                             setHiding Hidden $
                             setRelevance Irrelevant $3 }
    | '.' '{{' TBind DoubleCloseBrace
                           { setRange (getRange ($2,$3,$4)) $
                             makeInstance $
                             setRelevance Irrelevant $3 }
    | '..' '(' TBindWithHiding ')'   { setRange (getRange ($2,$3,$4)) $
                             setRelevance NonStrict $3 }
    | '..' '{' TBind '}'   { setRange (getRange ($2,$3,$4)) $
                             setHiding Hidden $
                             setRelevance NonStrict $3 }
    | '..' '{{' TBind DoubleCloseBrace
                           { setRange (getRange ($2,$3,$4)) $
                             makeInstance $
                             setRelevance NonStrict $3 }
    | '(' TBindWithHiding ')'        { setRange (getRange ($1,$2,$3)) $2 }
    | '(' ModalTBindWithHiding ')'        { setRange (getRange ($1,$2,$3)) $2 }
    | '{{' TBind DoubleCloseBrace
                           { setRange (getRange ($1,$2,$3)) $
                             makeInstance $2 }
    | '{{' ModalTBind DoubleCloseBrace
                           { setRange (getRange ($1,$2,$3)) $
                             makeInstance $2 }
    | '{' TBind '}'        { setRange (getRange ($1,$2,$3)) $
                             setHiding Hidden $2 }
    | '{' ModalTBind '}'   { setRange (getRange ($1,$2,$3)) $
                             setHiding Hidden $2 }
    | '(' Open ')'               { TLet (getRange ($1,$3)) $2 }
    | '(' 'let' Declarations ')' { TLet (getRange ($1,$4)) $3 }


-- x1 .. xn : A
-- x1 .. xn :{i1 i2 ..} A
TBind :: { TypedBinding }
TBind : CommaBIds ':' Expr  {
    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings
    in TBind r $1 $3
  }

ModalTBind :: { TypedBinding }
ModalTBind : Attributes1 CommaBIds ':' Expr  {% do
    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings
    xs <- mapM (applyAttrs1 $1 . setTacticAttr $1) $2
    return $ TBind r xs $4
  }

-- x {y z} _ {v} : A
TBindWithHiding :: { TypedBinding }
TBindWithHiding : BIdsWithHiding ':' Expr  {
    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings
    in TBind r $1 $3
  }

ModalTBindWithHiding :: { TypedBinding }
ModalTBindWithHiding : Attributes1 BIdsWithHiding ':' Expr  {% do
    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings
    xs <- mapM (applyAttrs1 $1 . setTacticAttr $1) $2
    return $ TBind r xs $4
  }

-- A non-empty sequence of lambda bindings.
LamBindings :: { List1 LamBinding }
LamBindings
  : LamBinds '->' {%
      case absurdBinding $1 of
        Just{}  -> parseError "Absurd lambda cannot have a body."
        Nothing -> return $ List1.fromListSafe __IMPOSSIBLE__ $ lamBindings $1
      }

AbsurdLamBindings :: { Either ([LamBinding], Hiding) (List1 Expr) }
AbsurdLamBindings
  : LamBindsAbsurd {%
    case $1 of
      Left lb -> case absurdBinding lb of
                   Nothing -> parseError "Missing body for lambda"
                   Just h  -> return $ Left (lamBindings lb, h)
      Right es -> return $ Right es
    }

-- absurd lambda is represented by @Left hiding@
LamBinds :: { LamBinds }
LamBinds
  : DomainFreeBinding LamBinds  { fmap (map DomainFree (List1.toList $1) ++) $2 }
  | TypedBinding LamBinds       { fmap (DomainFull $1 :) $2 }
  | DomainFreeBinding           { mkLamBinds $ map DomainFree $ List1.toList $1 }
  | TypedBinding                { mkLamBinds [DomainFull $1] }
  | '(' ')'                     { mkAbsurdBinding NotHidden }
  | '{' '}'                     { mkAbsurdBinding Hidden }
  | '{{' DoubleCloseBrace       { mkAbsurdBinding (Instance NoOverlap) }

-- Like LamBinds, but could also parse an absurd LHS of an extended lambda @{ p1 ... () }@
LamBindsAbsurd :: { Either LamBinds (List1 Expr) }
LamBindsAbsurd
  : DomainFreeBinding LamBinds  { Left $ fmap (map DomainFree (List1.toList $1) ++) $2 }
  | TypedBinding LamBinds       { Left $ fmap (DomainFull $1 :) $2 }
  | DomainFreeBindingAbsurd     { case $1 of
                                    Left lb -> Left $ mkLamBinds (map DomainFree $ List1.toList lb)
                                    Right es -> Right es }
  | TypedBinding                { Left $ mkLamBinds [DomainFull $1] }
  | '(' ')'                     { Left $ mkAbsurdBinding NotHidden }
  | '{' '}'                     { Left $ mkAbsurdBinding Hidden }
  | '{{' DoubleCloseBrace       { Left $ mkAbsurdBinding (Instance NoOverlap) }

-- FNF, 2011-05-05: No where-clauses in extended lambdas for now.
-- Andreas, 2020-03-28: And also not in sight either nine years later.
NonAbsurdLamClause :: { LamClause }
NonAbsurdLamClause
  : Application3PossiblyEmpty '->' Expr {% mkLamClause False $1 (RHS $3) }
  | CatchallPragma
    Application3PossiblyEmpty '->' Expr {% mkLamClause True  $2 (RHS $4) }

AbsurdLamClause :: { LamClause }
AbsurdLamClause
-- FNF, 2011-05-09: By being more liberal here, we avoid shift/reduce and reduce/reduce errors.
-- Later stages such as scope checking will complain if we let something through which we should not
  : Application                {% mkAbsurdLamClause False $1 }
  | CatchallPragma Application {% mkAbsurdLamClause True  $2 }

LamClause :: { LamClause }
LamClause
  : NonAbsurdLamClause { $1 }
  | AbsurdLamClause { $1 }

-- Parses all extended lambda clauses except for a single absurd clause, which is taken care of
-- in AbsurdLambda
LamClauses :: { List1 LamClause }
LamClauses
   : LamClauses semi LamClause { $3 <| $1 }
   | AbsurdLamClause semi LamClause { $3 <| singleton $1 }
   | NonAbsurdLamClause { singleton $1 }

-- Parses all extended lambda clauses including a single absurd clause.
-- For lambda-where this is not[sic!, now?] taken care of in AbsurdLambda.
LamWhereClauses :: { List1 LamClause }
LamWhereClauses
   : LamWhereClauses semi LamClause { $3 <| $1 }
   | LamClause { singleton $1 }

ForallBindings :: { List1 LamBinding }
ForallBindings
  : TypedUntypedBindings1 '->' { $1 }

-- A non-empty sequence of possibly untyped bindings.
TypedUntypedBindings1 :: { List1 LamBinding }
TypedUntypedBindings1
  : DomainFreeBinding TypedUntypedBindings1 { fmap DomainFree $1 <> $2 }
  | TypedBinding TypedUntypedBindings1      { DomainFull $1 <| $2 }
  | DomainFreeBinding                       { fmap DomainFree $1 }
  | TypedBinding                            { singleton $ DomainFull $1 }

-- A possibly empty sequence of possibly untyped bindings.
-- This is used as telescope in data and record decls.
TypedUntypedBindings :: { [LamBinding] }
TypedUntypedBindings
  : DomainFreeBinding TypedUntypedBindings { map DomainFree (List1.toList $1) ++ $2 }
  | TypedBinding TypedUntypedBindings      { DomainFull $1 : $2 }
  |                                        { [] }

DomainFreeBindings :: { [NamedArg Binder] }
DomainFreeBindings
  : {- empty -}                          { [] }
  | DomainFreeBinding DomainFreeBindings { List1.toList $1 ++ $2 }

-- A domain free binding is either x or {x1 .. xn}
DomainFreeBinding :: { List1 (NamedArg Binder) }
DomainFreeBinding
  : DomainFreeBindingAbsurd {% case $1 of
                             Left lbs -> return lbs
                             Right _ -> parseError "expected sequence of bound identifiers, not absurd pattern"
                          }

MaybeAsPattern :: { Maybe Pattern }
MaybeAsPattern
  : '@' Expr3   {% fmap Just (exprToPattern $2) }
  | {- empty -} { Nothing }

-- A domain free binding is either x or {x1 .. xn}
DomainFreeBindingAbsurd :: { Either (List1 (NamedArg Binder)) (List1 Expr)}
DomainFreeBindingAbsurd
    : BId      MaybeAsPattern { Left . singleton $ mkDomainFree_ id $2 $1 }
    | '.' BId  MaybeAsPattern { Left . singleton $ mkDomainFree_ (setRelevance Irrelevant) $3 $2 }
    | '..' BId MaybeAsPattern { Left . singleton $ mkDomainFree_ (setRelevance NonStrict) $3 $2 }
    | '(' Application ')'     {% exprToPattern (rawApp $2) >>= \ p ->
                                 pure . Left . singleton $ mkDomainFree_ id (Just p) $ simpleHole }
    | '(' Attributes1 CommaBIdAndAbsurds ')'
         {% applyAttrs1 $2 defaultArgInfo <&> \ ai ->
              first (fmap (setTacticAttr $2 . setArgInfo ai)) $3 }
    | '{' CommaBIdAndAbsurds '}'
         { first (fmap hide) $2 }
    | '{' Attributes1 CommaBIdAndAbsurds '}'
         {% applyAttrs1 $2 defaultArgInfo <&> \ ai ->
              first (fmap (hide . setTacticAttr $2 . setArgInfo ai)) $3 }
    | '{{' CommaBIds DoubleCloseBrace { Left $ fmap makeInstance $2 }
    | '{{' Attributes1 CommaBIds DoubleCloseBrace
         {% applyAttrs1 $2 defaultArgInfo <&> \ ai ->
              Left $ fmap (makeInstance . setTacticAttr $2 . setArgInfo ai) $3 }
    | '.' '{' CommaBIds '}' { Left $ fmap (hide . setRelevance Irrelevant) $3 }
    | '.' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . setRelevance Irrelevant) $3 }
    | '..' '{' CommaBIds '}' { Left $ fmap (hide . setRelevance NonStrict) $3 }
    | '..' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . setRelevance NonStrict) $3 }


{--------------------------------------------------------------------------
    Do-notation
 --------------------------------------------------------------------------}

DoStmts :: { List1 DoStmt }
DoStmts : DoStmt              { singleton $1 }
        | DoStmt vsemi        { singleton $1 }    -- #3046
        | DoStmt semi DoStmts { $1 <| $3 }

DoStmt :: { DoStmt }
DoStmt : Expr DoWhere {% buildDoStmt $1 $2 }

DoWhere :: { [LamClause] }
DoWhere
  : {- empty -} { [] }
  | 'where' vopen LamWhereClauses close { reverse (List1.toList $3) }

{--------------------------------------------------------------------------
    Modules and imports
 --------------------------------------------------------------------------}

-- Import directives
ImportDirective :: { ImportDirective }
ImportDirective
  : ImportDirective1 ImportDirective { $1 <> $2 }
  | {- empty -}                      { mempty }

ImportDirective1 :: { ImportDirective }
  : 'public'      { defaultImportDir { importDirRange = getRange $1, publicOpen = Just (getRange $1) } }
  | Using         { defaultImportDir { importDirRange = snd $1, using    = fst $1 } }
  | Hiding        { defaultImportDir { importDirRange = snd $1, hiding   = fst $1 } }
  | RenamingDir   { defaultImportDir { importDirRange = snd $1, impRenaming = fst $1 } }

Using :: { (Using, Range) }
Using
    : 'using' '(' CommaImportNames ')'   { (Using $3 , getRange ($1,$2,$3,$4)) }
        -- using can have an empty list

Hiding :: { ([ImportedName], Range) }
Hiding
    : 'hiding' '(' CommaImportNames ')'  { ($3 , getRange ($1,$2,$3,$4)) }
        -- if you want to hide nothing that's fine, isn't it?

RenamingDir :: { ([Renaming] , Range) }
RenamingDir
    : 'renaming' '(' Renamings ')'      { ($3 , getRange ($1,$2,$3,$4)) }
    | 'renaming' '(' ')'                { ([] , getRange ($1,$2,$3)) }

-- Renamings of the form 'x to y'
Renamings :: { [Renaming] }
Renamings
    : Renaming ';' Renamings    { $1 : $3 }
    | Renaming                  { [$1] }

Renaming :: { Renaming }
Renaming
    : ImportName_ 'to' RenamingTarget { Renaming $1 (setImportedName $1 (snd $3)) (fst $3) (getRange $2) }

RenamingTarget :: { (Maybe Fixity, Name) }
RenamingTarget
    : Id                 { (Nothing, $1) }
    | 'infix'  Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) NonAssoc)  , $3) }
    | 'infixl' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) LeftAssoc) , $3) }
    | 'infixr' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) RightAssoc), $3) }

-- We need a special imported name here, since we have to trigger
-- the imp_dir state exactly one token before the 'to'
ImportName_ :: { ImportedName }
ImportName_
    : beginImpDir Id          { ImportedName $2 }
    | 'module' beginImpDir Id { ImportedModule $3 }

ImportName :: { ImportedName }
ImportName : Id          { ImportedName $1 }
           | 'module' Id { ImportedModule $2 }

-- Actually semi-colon separated, possibly empty list of ImportName.
CommaImportNames :: { [ImportedName] }
CommaImportNames
    : {- empty -}       { [] }
    | CommaImportNames1 { List1.toList $1 }

CommaImportNames1 :: { List1 ImportedName }
CommaImportNames1
    : ImportName                        { singleton $1 }
    | ImportName ';' CommaImportNames1  { $1 <| $3 }

{--------------------------------------------------------------------------
    Function clauses
 --------------------------------------------------------------------------}

-- A left hand side of a function clause. We parse it as an expression, and
-- then check that it is a valid left hand side.
LHS :: { [RewriteEqn] -> [WithExpr] -> LHS }
LHS : Expr1 {% exprToLHS $1 }

WithClause :: { [Either RewriteEqn (List1 (Named Name Expr))] }
WithClause
  : 'with' WithExprs WithClause
    {% fmap (++ $3) (buildWithStmt $2)  }
  | 'rewrite' UnnamedWithExprs WithClause
    { Left (Rewrite $ fmap ((),) $2) : $3 }
  | {- empty -} { [] }

-- Parsing either an expression @e@ or a @(rewrite | with p <-) e1 | ... | en@.
HoleContent :: { HoleContent }
HoleContent
  : Expr                   {  HoleContentExpr    $1 }
  | WithClause
    {% fmap HoleContentRewrite $ forM $1 $ \case
         Left r  -> pure r
         Right{} -> parseError "Cannot declare a 'with' abstraction from inside a hole."
      }

-- Where clauses are optional.
WhereClause :: { WhereClause }
WhereClause
    : {- empty -}                               { NoWhere }
    |                     'where' Declarations0 { AnyWhere  (getRange $1) $2 }
    | 'module' Id         'where' Declarations0 { SomeWhere (getRange ($1,$3)) $2 PublicAccess $4 }
    | 'module' Underscore 'where' Declarations0 { SomeWhere (getRange ($1,$3)) $2 PublicAccess $4 }
  -- Note: The access modifier is a dummy, it is computed in the nicifier.

ExprWhere :: { ExprWhere }
ExprWhere : Expr WhereClause { ExprWhere $1 $2 }

{--------------------------------------------------------------------------
    Different kinds of declarations
 --------------------------------------------------------------------------}

-- Top-level definitions.
Declaration :: { List1 Declaration }
Declaration
    : Fields          { singleton $1 }
    | FunClause       { $1 }            -- includes type signatures
    | Data            { singleton $1 }
    | DataSig         { singleton $1 }  -- lone data type signature in mutual block
    | Record          { singleton $1 }
    | RecordSig       { singleton $1 }  -- lone record signature in mutual block
    | Infix           { singleton $1 }
    | Generalize      { singleton $1 }
    | Mutual          { singleton $1 }
    | Abstract        { singleton $1 }
    | Private         { singleton $1 }
    | Instance        { singleton $1 }
    | Macro           { singleton $1 }
    | Postulate       { singleton $1 }
    | Primitive       { singleton $1 }
    | Open            { $1 }
    | ModuleMacro     { singleton $1 }
    | Module          { singleton $1 }
    | Pragma          { singleton $1 }
    | Syntax          { singleton $1 }
    | PatternSyn      { singleton $1 }
    | UnquoteDecl     { singleton $1 }
    | Constructor     { singleton $1 }

{--------------------------------------------------------------------------
    Individual declarations
 --------------------------------------------------------------------------}

-- Type signatures of the form "n1 n2 n3 ... : Type", with at least
-- one bound name.
TypeSigs :: { List1 Declaration }
TypeSigs : SpaceIds ':' Expr { fmap (\ x -> typeSig defaultArgInfo Nothing x $3) $1 }

-- A variant of TypeSigs where any sub-sequence of names can be marked
-- as hidden or irrelevant using braces and dots:
-- {n1 .n2} n3 .n4 {n5} .{n6 n7} ... : Type.
ArgTypeSigs :: { List1 (Arg Declaration) }
ArgTypeSigs
  : ModalArgIds ':' Expr { let (attrs, xs) = $1 in
                           fmap (fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $3)) xs }
  | 'overlap' ModalArgIds ':' Expr {%
      let (attrs, xs) = $2
          setOverlap x =
            case getHiding x of
              Instance _ -> return $ makeInstance' YesOverlap x
              _          -> parseErrorRange $1
                             "The 'overlap' keyword only applies to instance fields (fields marked with {{ }})"
      in T.traverse (setOverlap . fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $4)) xs }
  | 'instance' ArgTypeSignatures {
    let
      setInstance (TypeSig info tac x t) = TypeSig (makeInstance info) tac x t
      setInstance _ = __IMPOSSIBLE__ in
    fmap (fmap setInstance) $2 }

-- Function declarations. The left hand side is parsed as an expression to allow
-- declarations like 'x::xs ++ ys = e', when '::' has higher precedence than '++'.
-- FunClause also handle possibly dotted type signatures.
FunClause :: { List1 Declaration }
FunClause
  : {- emptyb -} LHS WHS RHS WhereClause {% funClauseOrTypeSigs [] $1 $2 $3 $4 }
  | Attributes1  LHS WHS RHS WhereClause {% funClauseOrTypeSigs (List1.toList $1) $2 $3 $4 $5 }

-- "With Hand Side", in between the Left & the Right hand ones
WHS :: { [Either RewriteEqn (List1 (Named Name Expr))] }
WHS
  : {- empty -}                           { [] }
  | 'with'    WithExprs        WithClause {% fmap (++ $3) (buildWithStmt $2) }
  | 'rewrite' UnnamedWithExprs WithClause { Left (Rewrite $ fmap ((),) $2) : $3 }

RHS :: { RHSOrTypeSigs }
RHS
  : {- empty -}    { JustRHS AbsurdRHS }
  | '='       Expr { JustRHS (RHS $2) }
  | ':'       Expr { TypeSigsRHS $2 }

-- Data declaration. Can be local.
Data :: { Declaration }
Data : 'data' Id TypedUntypedBindings ':' Expr 'where'
            Declarations0       { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) $2 $3 $5 $7 }

  -- New cases when we already had a DataSig.  Then one can omit the sort.
     | 'data' Id TypedUntypedBindings 'where'
            Declarations0       { DataDef (getRange ($1,$2,$3,$4,$5)) $2 $3 $5 }

-- Data type signature. Found in mutual blocks.
DataSig :: { Declaration }
DataSig : 'data' Id TypedUntypedBindings ':' Expr
  { DataSig (getRange ($1,$2,$3,$4,$5)) $2 $3 $5 }

-- Andreas, 2012-03-16:  The Expr3NoCurly instead of Id in everything
-- following 'record' is to remove the (harmless) shift/reduce conflict
-- introduced by record update expressions.

-- Record declarations.
Record :: { Declaration }
Record : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr 'where'
            RecordDeclarations
         {% exprToName $2 >>= \ n -> let (dir, ds) = $7 in return $ Record (getRange ($1,$2,$3,$4,$5,$6,$7)) n dir $3 $5 ds }
       | 'record' Expr3NoCurly TypedUntypedBindings 'where'
            RecordDeclarations
         {% exprToName $2 >>= \ n -> let (dir, ds) = $5 in return $ RecordDef (getRange ($1,$2,$3,$4,$5)) n dir $3 ds }

-- Record type signature. In mutual blocks.
RecordSig :: { Declaration }
RecordSig : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr
  {% exprToName $2 >>= \ n -> return $ RecordSig (getRange ($1,$2,$3,$4,$5)) n $3 $5 }

Constructor :: { Declaration }
Constructor : 'data' '_' 'where' Declarations0
  { LoneConstructor (getRange ($1,$4)) $4 }

-- Declaration of record constructor name.
RecordConstructorName :: { (Name, IsInstance) }
RecordConstructorName :                  'constructor' Id       { ($2, NotInstanceDef) }
                      | 'instance' vopen 'constructor' Id close { ($4, InstanceDef (getRange $1)) }


-- Fixity declarations.
Infix :: { Declaration }
Infix : 'infix'  Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) NonAssoc)   $3 }
      | 'infixl' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) LeftAssoc)  $3 }
      | 'infixr' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) RightAssoc) $3 }

-- Field declarations.
Fields :: { Declaration }
Fields : 'field' ArgTypeSignaturesOrEmpty
            { let
                inst i = case getHiding i of
                           Instance _ -> InstanceDef noRange  -- no @instance@ keyword here
                           _          -> NotInstanceDef
                toField (Arg info (TypeSig info' tac x t)) = FieldSig (inst info') tac x (Arg info t)
              in Field (fuseRange $1 $2) $ map toField $2 }
  -- | 'field' ModalArgTypeSignatures
  --           { let
  --               inst i = case getHiding i of
  --                          Instance _ -> InstanceDef
  --                          _          -> NotInstanceDef
  --               toField (Arg info (TypeSig info' x t)) = FieldSig (inst info') x (Arg info t)
  --             in Field (fuseRange $1 $2) $ map toField $2 }

-- Variable declarations for automatic generalization
Generalize :: { Declaration }
Generalize : 'variable' ArgTypeSignaturesOrEmpty
            { let
                toGeneralize (Arg info (TypeSig _ tac x t)) = TypeSig info tac x t
              in Generalize (fuseRange $1 $2) (map toGeneralize $2) }

-- Mutually recursive declarations.
Mutual :: { Declaration }
Mutual : 'mutual' Declarations0  { Mutual (fuseRange $1 $2) $2 }
       | 'interleaved' 'mutual' Declarations0 { InterleavedMutual (getRange ($1,$2,$3)) $3 }

-- Abstract declarations.
Abstract :: { Declaration }
Abstract : 'abstract' Declarations0  { Abstract (fuseRange $1 $2) $2 }


-- Private can only appear on the top-level (or rather the module level).
Private :: { Declaration }
Private : 'private' Declarations0        { Private (fuseRange $1 $2) UserWritten $2 }


-- Instance declarations.
Instance :: { Declaration }
Instance : 'instance' Declarations0  { InstanceB (getRange $1) $2 }


-- Macro declarations.
Macro :: { Declaration }
Macro : 'macro' Declarations0 { Macro (fuseRange $1 $2) $2 }


-- Postulates.
Postulate :: { Declaration }
Postulate : 'postulate' Declarations0 { Postulate (fuseRange $1 $2) $2 }

-- Primitives. Can only contain type signatures.
Primitive :: { Declaration }
Primitive : 'primitive' ArgTypeSignaturesOrEmpty  {
  let { setArg (Arg info (TypeSig _ tac x t)) = TypeSig info tac x t
      ; setArg _ = __IMPOSSIBLE__ } in
  Primitive (fuseRange $1 $2) (map setArg $2) }

-- Unquoting declarations.
UnquoteDecl :: { Declaration }
UnquoteDecl
  : 'unquoteDecl' '=' Expr { UnquoteDecl (fuseRange $1 $3) [] $3 }
  | 'unquoteDecl' 'data' Id '=' Expr { UnquoteData (getRange($1, $2, $5)) $3 [] $5 }
  | 'unquoteDecl' 'data' Id 'constructor' SpaceIds '=' Expr { UnquoteData (getRange($1, $2, $4, $7)) $3 (List1.toList $5) $7 }
  | 'unquoteDecl' SpaceIds '=' Expr { UnquoteDecl (fuseRange $1 $4) (List1.toList $2) $4 }
  | 'unquoteDef'  SpaceIds '=' Expr { UnquoteDef (fuseRange $1 $4) (List1.toList $2) $4 }

-- Syntax declaration (To declare eg. mixfix binders)
Syntax :: { Declaration }
Syntax : 'syntax' Id HoleNames '=' SimpleIds  {%
  case $2 of
    Name _ _ (_ :| []) -> case mkNotation (DL.toList $3) (reverse $5) of
      Left err -> parseError $ "Malformed syntax declaration: " ++ err
      Right n -> return $ Syntax $2 n
    _ -> parseError "Syntax declarations are allowed only for simple names (without holes)"
}

-- Pattern synonyms.
PatternSyn :: { Declaration }
PatternSyn : 'pattern' Id PatternSynArgs '=' Expr {% do
  p <- exprToPattern $5
  return (PatternSyn (getRange ($1,$2,$3,$4,$5)) $2 $3 p)
  }

PatternSynArgs :: { [Arg Name] }
PatternSynArgs : DomainFreeBindings    {% patternSynArgs $1 }

-- The list should be reversed.

SimpleIds :: { [RString] }
SimpleIds : SimpleId           { [$1] }
          | SimpleIds SimpleId { $2 : $1 }

-- The list should be reversed.

SimpleIdsOrWildcards :: { List1 RString }
SimpleIdsOrWildcards
  : SimpleIdOrWildcard                      { List1.singleton $1 }
  | SimpleIdsOrWildcards SimpleIdOrWildcard { $2 <| $1 }

HoleNames :: { DList (NamedArg HoleName) }
HoleNames :                    { mempty }
          | HoleNames HoleName { $1 `DL.snoc` $2 }

HoleName :: { NamedArg HoleName }
HoleName
  : SimpleTopHole { defaultNamedArg $1 }
  | '{'  SimpleHole '}'  { hide         $ defaultNamedArg $2 }
  | '{{' SimpleHole '}}' { makeInstance $ defaultNamedArg $2 }
  | '{'  SimpleId '=' SimpleHole '}'  { hide         $ defaultArg $ userNamed $2 $4 }
  | '{{' SimpleId '=' SimpleHole '}}' { makeInstance $ defaultArg $ userNamed $2 $4 }

SimpleTopHole :: { HoleName }
SimpleTopHole
  : SimpleId { ExprHole $1 }
  | '(' '\\' SimpleIdsOrWildcards '->' SimpleId ')'
    { LambdaHole (List1.reverse $3) $5 }

SimpleHole :: { HoleName }
SimpleHole
  : SimpleId { ExprHole $1 }
  | '\\' SimpleIdsOrWildcards '->' SimpleId
    { LambdaHole (List1.reverse $2) $4 }

-- Discard the interval.
SimpleId :: { RString }
SimpleId : id  { Ranged (getRange $ fst $1) (stringToRawName $ snd $1) }

SimpleIdOrWildcard :: { RString }
SimpleIdOrWildcard
  : SimpleId { $1 }
  | '_'      { Ranged (getRange $1) "_" }

MaybeOpen :: { Maybe Range }
MaybeOpen : 'open'      { Just (getRange $1) }
          | {- empty -} { Nothing }

-- Open
Open :: { List1 Declaration }
Open : MaybeOpen 'import' ModuleName OpenArgs ImportDirective {%
    let
    { doOpen = maybe DontOpen (const DoOpen) $1
    ; m   = $3
    ; es  = $4
    ; dir = $5
    ; r   = getRange ($1, $2, m, es, dir)
    ; mr  = getRange m
    ; unique = hashString $ prettyShow $ (Strict.Nothing :: Strict.Maybe ()) <$ r
         -- turn range into unique id, but delete file path
         -- which is absolute and messes up suite of failing tests
         -- (different hashs on different installations)
         -- TODO: Don't use (insecure) hashes in this way.
    ; fresh  = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show unique
    ; fresh' = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show (unique + 1)
    ; impStm asR = Import noRange m (Just (AsName (Right fresh) asR)) DontOpen defaultImportDir
    ; appStm m' es =
        Private r Inserted
          [ ModuleMacro r m'
             (SectionApp (getRange es) []
               (rawApp (Ident (QName fresh) :| es)))
             doOpen dir
          ]
    ; (initArgs, last2Args) = splitAt (length es - 2) es
    ; parseAsClause = case last2Args of
      { [ Ident (QName (Name asR InScope (Id x :| [])))
        , e
          -- Andreas, 2018-11-03, issue #3364, accept anything after 'as'
          -- but require it to be a 'Name' in the scope checker.
        ] | rawNameToString x == "as" -> Just . (asR,) $
          if | Ident (QName m') <- e -> Right m'
             | otherwise             -> Left e
      ; _ -> Nothing
      }
    } in
    case es of
      { [] -> return $ singleton $ Import r m Nothing doOpen dir
      ; _ | Just (asR, m') <- parseAsClause -> return $
              if null initArgs then singleton
                 ( Import (getRange (m, asR, m', dir)) m
                     (Just (AsName m' asR)) doOpen dir
                 )
              else impStm asR :| [ appStm (fromRight (const fresh') m') initArgs ]
          -- Andreas, 2017-05-13, issue #2579
          -- Nisse reports that importing with instantation but without open
          -- could be usefule for bringing instances into scope.
          -- Ulf, 2018-12-6: Not since fixes of #1913 and #2489 which require
          -- instances to be in scope.
          | DontOpen <- doOpen -> parseErrorRange $2 "An import statement with module instantiation is useless without either an `open' keyword or an `as` binding giving a name to the instantiated module."
          | otherwise -> return $
              impStm noRange :|
              appStm (noName $ beginningOf $ getRange m) es :
              []
      }
  }
  |'open' ModuleName OpenArgs ImportDirective {
    let
    { m   = $2
    ; es  = $3
    ; dir = $4
    ; r   = getRange ($1, m, es, dir)
    } in singleton $
      case es of
      { []  -> Open r m dir
      ; _   -> Private r Inserted
                 [ ModuleMacro r (noName $ beginningOf $ getRange m)
                             (SectionApp (getRange (m , es)) [] (rawApp (Ident m :| es)))
                             DoOpen dir
                 ]
      }
  }
  | 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective {
    let r = getRange $2 in singleton $
      Private r Inserted
      [ ModuleMacro r (noName $ beginningOf $ getRange $2) (RecordModuleInstance r $2) DoOpen $6
      ]
  }

OpenArgs :: { [Expr] }
OpenArgs : {- empty -}    { [] }
         | Expr3 OpenArgs { $1 : $2 }

ModuleApplication :: { Telescope -> Parser ModuleApplication }
ModuleApplication : ModuleName '{{' '...' DoubleCloseBrace { (\ts ->
                    if null ts then return $ RecordModuleInstance (getRange ($1,$2,$3,$4)) $1
                    else parseError "No bindings allowed for record module with non-canonical implicits" )
                    }
                  | ModuleName OpenArgs {
                    (\ts -> return $ SectionApp (getRange ($1, $2)) ts (rawApp (Ident $1 :| $2)) ) }


-- Module instantiation
ModuleMacro :: { Declaration }
ModuleMacro : 'module' ModuleName TypedUntypedBindings '=' ModuleApplication ImportDirective
                    {% do { ma <- $5 (map addType $3)
                          ; name <- ensureUnqual $2
                          ; return $ ModuleMacro (getRange ($1, $2, ma, $6)) name ma DontOpen $6 } }
            | 'open' 'module' Id TypedUntypedBindings '=' ModuleApplication ImportDirective
                    {% do {ma <- $6 (map addType $4); return $ ModuleMacro (getRange ($1, $2, $3, ma, $7)) $3 ma DoOpen $7 } }

-- Module
Module :: { Declaration }
Module : 'module' ModuleName TypedUntypedBindings 'where' Declarations0
                    { Module (getRange ($1,$2,$3,$4,$5)) $2 (map addType $3) $5 }
       | 'module' Underscore TypedUntypedBindings 'where' Declarations0
                    { Module (getRange ($1,$2,$3,$4,$5)) (QName $2) (map addType $3) $5 }

Underscore :: { Name }
Underscore : '_' { noName (getRange $1) }

TopLevel :: { [Declaration] }
TopLevel : TopDeclarations { figureOutTopLevelModule $1 }

Pragma :: { Declaration }
Pragma : DeclarationPragma  { Pragma $1 }

DeclarationPragma :: { Pragma }
DeclarationPragma
  : BuiltinPragma            { $1 }
  | RewritePragma            { $1 }
  | CompilePragma            { $1 }
  | ForeignPragma            { $1 }
  | StaticPragma             { $1 }
  | InjectivePragma          { $1 }
  | InlinePragma             { $1 }
  | NoInlinePragma           { $1 }
  | ImpossiblePragma         { $1 }
  | TerminatingPragma        { $1 }
  | NonTerminatingPragma     { $1 }
  | NoTerminationCheckPragma { $1 }
  | NonCoveringPragma        { $1 }
  | NotProjectionLikePragma  { $1 }
  | WarningOnUsagePragma     { $1 }
  | WarningOnImportPragma    { $1 }
  | MeasurePragma            { $1 }
  | CatchallPragma           { $1 }
  | DisplayPragma            { $1 }
  | EtaPragma                { $1 }
  | NoPositivityCheckPragma  { $1 }
  | NoUniverseCheckPragma    { $1 }
  | PolarityPragma           { $1 }
  | OptionsPragma            { $1 }
    -- Andreas, 2014-03-06
    -- OPTIONS pragma not allowed everywhere, but don't give parse error.
    -- Give better error during type checking instead.

OptionsPragma :: { Pragma }
OptionsPragma : '{-#' 'OPTIONS' PragmaStrings '#-}' { OptionsPragma (getRange ($1,$2,$4)) $3 }

BuiltinPragma :: { Pragma }
BuiltinPragma
    : '{-#' 'BUILTIN' string PragmaQName '#-}'
      { BuiltinPragma (getRange ($1,$2,fst $3,$4,$5)) (mkRString $3) $4 }
    -- Extra rule to accept keyword REWRITE also as built-in:
    | '{-#' 'BUILTIN' 'REWRITE' PragmaQName '#-}'
      { BuiltinPragma (getRange ($1,$2,$3,$4,$5)) (Ranged (getRange $3) "REWRITE") $4 }

RewritePragma :: { Pragma }
RewritePragma
    : '{-#' 'REWRITE' PragmaQNames '#-}'
      { RewritePragma (getRange ($1,$2,$3,$4)) (getRange $2) $3 }

ForeignPragma :: { Pragma }
ForeignPragma
  : '{-#' 'FOREIGN' string ForeignCode '#-}'
    { ForeignPragma (getRange ($1, $2, fst $3, $5))
        (mkRString $3) (recoverLayout (DL.toList $4)) }

CompilePragma :: { Pragma }
CompilePragma
  : '{-#' 'COMPILE' string PragmaQName PragmaStrings '#-}'
    { CompilePragma (getRange ($1,$2,fst $3,$4,$6)) (mkRString $3) $4 (unwords $5) }

StaticPragma :: { Pragma }
StaticPragma
  : '{-#' 'STATIC' PragmaQName '#-}'
    { StaticPragma (getRange ($1,$2,$3,$4)) $3 }

InlinePragma :: { Pragma }
InlinePragma
  : '{-#' 'INLINE' PragmaQName '#-}'
    { InlinePragma (getRange ($1,$2,$3,$4)) True $3 }

NoInlinePragma :: { Pragma }
NoInlinePragma
  : '{-#' 'NOINLINE' PragmaQName '#-}'
    { InlinePragma (getRange ($1,$2,$3,$4)) False $3 }

NotProjectionLikePragma :: { Pragma }
NotProjectionLikePragma
  : '{-#' 'NOT_PROJECTION_LIKE' PragmaQName '#-}'
    { NotProjectionLikePragma (getRange ($1,$2,$3,$4)) $3 }

InjectivePragma :: { Pragma }
InjectivePragma
  : '{-#' 'INJECTIVE' PragmaQName '#-}'
    { InjectivePragma (getRange ($1,$2,$3,$4)) $3 }

DisplayPragma :: { Pragma }
DisplayPragma
  : '{-#' 'DISPLAY' string PragmaStrings '#-}' {%
      let (r, s) = $3 in
      parseDisplayPragma (fuseRange $1 $5) (iStart r) (unwords (s : $4)) }

EtaPragma :: { Pragma }
EtaPragma
  : '{-#' 'ETA' PragmaQName '#-}'
    { EtaPragma (getRange ($1,$2,$3,$4)) $3 }

NoTerminationCheckPragma :: { Pragma }
NoTerminationCheckPragma
  : '{-#' 'NO_TERMINATION_CHECK' '#-}'
    { TerminationCheckPragma (getRange ($1,$2,$3)) NoTerminationCheck }

NonTerminatingPragma :: { Pragma }
NonTerminatingPragma
  : '{-#' 'NON_TERMINATING' '#-}'
    { TerminationCheckPragma (getRange ($1,$2,$3)) NonTerminating }

TerminatingPragma :: { Pragma }
TerminatingPragma
  : '{-#' 'TERMINATING' '#-}'
    { TerminationCheckPragma (getRange ($1,$2,$3)) Terminating }

NonCoveringPragma :: { Pragma }
NonCoveringPragma
  : '{-#' 'NON_COVERING' '#-}'
    { NoCoverageCheckPragma (getRange ($1,$2,$3)) }

MeasurePragma :: { Pragma }
MeasurePragma
  : '{-#' 'MEASURE' PragmaName '#-}'
    { let r = getRange ($1, $2, $3, $4) in
      TerminationCheckPragma r (TerminationMeasure r $3) }

CatchallPragma :: { Pragma }
CatchallPragma
  : '{-#' 'CATCHALL' '#-}'
    { CatchallPragma (getRange ($1,$2,$3)) }

ImpossiblePragma :: { Pragma }
ImpossiblePragma
  : '{-#' 'IMPOSSIBLE' PragmaStrings '#-}'
    { ImpossiblePragma (getRange ($1,$2,$4)) $3 }

NoPositivityCheckPragma :: { Pragma }
NoPositivityCheckPragma
  : '{-#' 'NO_POSITIVITY_CHECK' '#-}'
    { NoPositivityCheckPragma (getRange ($1,$2,$3)) }

NoUniverseCheckPragma :: { Pragma }
NoUniverseCheckPragma
  : '{-#' 'NO_UNIVERSE_CHECK' '#-}'
    { NoUniverseCheckPragma (getRange ($1,$2,$3)) }

PolarityPragma :: { Pragma }
PolarityPragma
  : '{-#' 'POLARITY' PragmaName Polarities '#-}'
    { let (rs, occs) = unzip (reverse $4) in
      PolarityPragma (getRange ($1,$2,$3,rs,$5)) $3 occs }

WarningOnUsagePragma :: { Pragma }
WarningOnUsagePragma
  : '{-#' 'WARNING_ON_USAGE' PragmaQName literal '#-}'
  {%  case $4 of
        { Ranged r (LitString str) -> return $ WarningOnUsage (getRange ($1,$2,$3,r,$5)) $3 str
        ; _ -> parseError "Expected string literal"
        }
  }

WarningOnImportPragma :: { Pragma }
WarningOnImportPragma
  : '{-#' 'WARNING_ON_IMPORT' literal '#-}'
  {%  case $3 of
        { Ranged r (LitString str) -> return $ WarningOnImport (getRange ($1,$2,r,$4)) str
        ; _ -> parseError "Expected string literal"
        }
  }

-- Possibly empty list of polarities. Reversed.
Polarities :: { [(Range, Occurrence)] }
Polarities : {- empty -}          { [] }
           | Polarities Polarity  { $2 : $1 }

Polarity :: { (Range, Occurrence) }
Polarity : string {% polarity $1 }

{--------------------------------------------------------------------------
    Sequences of declarations
 --------------------------------------------------------------------------}

-- Possibly empty list of type signatures, with several identifiers allowed
-- for every signature.
TypeSignatures0 :: { [TypeSignature] }
TypeSignatures
    : vopen close    { [] }
    | TypeSignatures { List1.toList $1 }

-- Non-empty list of type signatures, with several identifiers allowed
-- for every signature.
TypeSignatures :: { List1 TypeSignature }
TypeSignatures
    : vopen TypeSignatures1 close   { List1.reverse $2 }

-- Inside the layout block.
TypeSignatures1 :: { List1 TypeSignature }
TypeSignatures1
    : TypeSignatures1 semi TypeSigs { List1.reverse $3 <> $1 }
    | TypeSigs                      { List1.reverse $1 }

-- A variant of TypeSignatures which uses ArgTypeSigs instead of
-- TypeSigs.
ArgTypeSignatures :: { List1 (Arg TypeSignature) }
ArgTypeSignatures
    : vopen ArgTypeSignatures1 close   { List1.reverse $2 }

-- Inside the layout block.
ArgTypeSignatures1 :: { List1 (Arg TypeSignature) }
ArgTypeSignatures1
    : ArgTypeSignatures1 semi ArgTypeSigs { List1.reverse $3 <> $1 }
    | ArgTypeSigs                         { List1.reverse $1 }

-- A variant of TypeSignatures which uses ArgTypeSigs instead of
-- TypeSigs.
ArgTypeSignaturesOrEmpty :: { [Arg TypeSignature] }
ArgTypeSignaturesOrEmpty
    : vopen ArgTypeSignatures0 close   { reverse $2 }

-- Inside the layout block.
ArgTypeSignatures0 :: { [Arg TypeSignature] }
ArgTypeSignatures0
    : ArgTypeSignatures0 semi ArgTypeSigs { reverse (List1.toList $3) ++ $1 }
    | ArgTypeSigs                         { reverse (List1.toList $1) }
    | {- empty -}                         { [] }

-- Record declarations, including an optional record constructor name.
RecordDeclarations :: { (RecordDirectives, [Declaration]) }
RecordDeclarations
    : vopen RecordDirectives close                    {% verifyRecordDirectives $2 <&> (,[]) }
    | vopen RecordDirectives semi Declarations1 close {% verifyRecordDirectives $2 <&> (, List1.toList $4) }
    | vopen Declarations1 close                       { (emptyRecordDirectives, List1.toList $2) }


RecordDirectives :: { [RecordDirective] }
RecordDirectives
    : {- empty -}                           { [] }
    | RecordDirectives semi RecordDirective { $3 : $1 }
    | RecordDirective                       { [$1] }

RecordDirective :: { RecordDirective }
RecordDirective
    : RecordConstructorName { uncurry Constructor $1 }
    | RecordInduction       { Induction $1 }
    | RecordEta             { Eta $1 }
    | RecordPatternMatching { PatternOrCopattern $1 }

RecordEta :: { Ranged HasEta0 }
RecordEta
    : 'eta-equality'    { Ranged (getRange $1) YesEta }
    | 'no-eta-equality' { Ranged (getRange $1) (NoEta ()) }

-- Directive 'pattern' if a decision between matching on constructor/record pattern
-- or copattern matching is needed.
-- Such decision is only needed for 'no-eta-equality' records.
-- But eta could be turned off automatically, thus, we do not bundle this
-- with the 'no-eta-equality' declaration.
-- Nor with the 'constructor' declaration, since it applies also to
-- the record pattern.
RecordPatternMatching :: { Range }
RecordPatternMatching
    : 'pattern'     { getRange $1 }

-- Declaration of record as 'inductive' or 'coinductive'.
RecordInduction :: { Ranged Induction }
RecordInduction
    : 'inductive'   { Ranged (getRange $1) Inductive   }
    | 'coinductive' { Ranged (getRange $1) CoInductive }

-- Arbitrary declarations
Declarations :: { List1 Declaration }
Declarations
    : vopen Declarations1 close { $2 }

-- Arbitrary declarations (possibly empty)
Declarations0 :: { [Declaration] }
Declarations0
    : vopen close  { [] }
    | Declarations { List1.toList $1 }

Declarations1 :: { List1 Declaration }
Declarations1
    : Declaration semi Declarations1 { $1 <> $3 }
    | Declaration vsemi              { $1 } -- #3046
    | Declaration                    { $1 }

TopDeclarations :: { [Declaration] }
TopDeclarations
  : {- empty -}   { [] }
  | Declarations1 { List1.toList $1 }

{

{--------------------------------------------------------------------------
    Parsers
 --------------------------------------------------------------------------}

-- | Parse the token stream. Used by the TeX compiler.
tokensParser :: Parser [Token]

-- | Parse an expression. Could be used in interactions.
exprParser :: Parser Expr

-- | Parse an expression followed by a where clause. Could be used in interactions.
exprWhereParser :: Parser ExprWhere

-- | Parse a module.
moduleParser :: Parser Module


{--------------------------------------------------------------------------
    Happy stuff
 --------------------------------------------------------------------------}

-- | Required by Happy.
happyError :: Parser a
happyError = parseError "Parse error"


{--------------------------------------------------------------------------
    Utility functions
 --------------------------------------------------------------------------}

-- | Grab leading OPTIONS pragmas.
takeOptionsPragmas :: [Declaration] -> Module
takeOptionsPragmas = uncurry Mod . spanJust (\ d -> case d of
  Pragma p@OptionsPragma{} -> Just p
  _                        -> Nothing)

-- | Insert a top-level module if there is none.
--   Also fix-up for the case the declarations in the top-level module
--   are not indented (this is allowed as a special case).
figureOutTopLevelModule :: [Declaration] -> [Declaration]
figureOutTopLevelModule ds =
  case spanAllowedBeforeModule ds of
    -- Andreas 2016-02-01, issue #1388.
    -- We need to distinguish two additional cases.

    -- Case 1: Regular file layout: imports followed by one module. Nothing to do.
    (ds0, [ Module{} ]) -> ds

    -- Case 2: The declarations in the module are not indented.
    -- This is allowed for the top level module, and thus rectified here.
    (ds0, Module r m tel [] : ds2) -> ds0 ++ [Module r m tel ds2]

    -- Case 3: There is a module with indented declarations,
    -- followed by non-indented declarations.  This should be a
    -- parse error and be reported later (see @toAbstract TopLevel{}@),
    -- thus, we do not do anything here.
    (ds0, Module r m tel ds1 : ds2) -> ds  -- Gives parse error in scope checker.
    -- OLD code causing issue 1388:
    -- (ds0, Module r m tel ds1 : ds2) -> ds0 ++ [Module r m tel $ ds1 ++ ds2]

    -- Case 4: a top-level module declaration is missing.
    -- Andreas, 2017-01-01, issue #2229:
    -- Put everything (except OPTIONS pragmas) into an anonymous module.
    _ -> ds0 ++ [Module r (QName $ noName r) [] ds1]
      where
      (ds0, ds1) = (`span` ds) $ \case
        Pragma OptionsPragma{} -> True
        _ -> False
      -- Andreas, 2017-05-17, issue #2574.
      -- Since the module noName will act as jump target, it needs a range.
      -- We use the beginning of the file as beginning of the top level module.
      r = beginningOfFile $ getRange ds1

-- | Create a name from a string.

mkName :: (Interval, String) -> Parser Name
mkName (i, s) = do
    let xs = C.stringNameParts s
    mapM_ isValidId xs
    unless (alternating xs) $ parseError $ "a name cannot contain two consecutive underscores"
    return $ Name (getRange i) InScope xs
    where
        isValidId Hole   = return ()
        isValidId (Id y) = do
          let x = rawNameToString y
              err = "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"
          case parse defaultParseFlags [0] (lexer return) x of
            ParseOk _ TokId{}  -> return ()
            ParseFailed{}      -> parseError err
            ParseOk _ TokEOF{} -> parseError err
            ParseOk _ t   -> parseError . ((err ++ " because it is ") ++) $ case t of
              TokId{}       -> __IMPOSSIBLE__
              TokQId{}      -> __IMPOSSIBLE__ -- "qualified"
              TokKeyword{}  -> "a keyword"
              TokLiteral{}  -> "a literal"
              TokSymbol s _ -> case s of
                SymDot               -> __IMPOSSIBLE__ -- "reserved"
                SymSemi              -> "used to separate declarations"
                SymVirtualSemi       -> __IMPOSSIBLE__
                SymBar               -> "used for with-arguments"
                SymColon             -> "part of declaration syntax"
                SymArrow             -> "the function arrow"
                SymEqual             -> "part of declaration syntax"
                SymLambda            -> "used for lambda-abstraction"
                SymUnderscore        -> "used for anonymous identifiers"
                SymQuestionMark      -> "a meta variable"
                SymAs                -> "used for as-patterns"
                SymOpenParen         -> "used to parenthesize expressions"
                SymCloseParen        -> "used to parenthesize expressions"
                SymOpenIdiomBracket  -> "an idiom bracket"
                SymCloseIdiomBracket -> "an idiom bracket"
                SymDoubleOpenBrace   -> "used for instance arguments"
                SymDoubleCloseBrace  -> "used for instance arguments"
                SymOpenBrace         -> "used for hidden arguments"
                SymCloseBrace        -> "used for hidden arguments"
                SymOpenVirtualBrace  -> __IMPOSSIBLE__
                SymCloseVirtualBrace -> __IMPOSSIBLE__
                SymOpenPragma        -> __IMPOSSIBLE__ -- "used for pragmas"
                SymClosePragma       -> __IMPOSSIBLE__ -- "used for pragmas"
                SymEllipsis          -> "used for function clauses"
                SymDotDot            -> __IMPOSSIBLE__ -- "a modality"
                SymEndComment        -> "the end-of-comment brace"
              TokString{}   -> __IMPOSSIBLE__
              TokTeX{}      -> __IMPOSSIBLE__  -- used by the LaTeX backend only
              TokMarkup{}   -> __IMPOSSIBLE__  -- ditto
              TokComment{}  -> __IMPOSSIBLE__
              TokDummy{}    -> __IMPOSSIBLE__
              TokEOF{}      -> __IMPOSSIBLE__

        -- we know that there are no two Ids in a row
        alternating (Hole :| Hole : _) = False
        alternating (_    :| x   : xs) = alternating $ x :| xs
        alternating (_    :|       []) = True

-- | Create a qualified name from a list of strings
mkQName :: [(Interval, String)] -> Parser QName
mkQName ss = do
    xs <- mapM mkName ss
    return $ foldr Qual (QName $ last xs) (init xs)

mkDomainFree_ :: (NamedArg Binder -> NamedArg Binder) -> Maybe Pattern -> Name -> NamedArg Binder
mkDomainFree_ f p n = f $ defaultNamedArg $ Binder p $ mkBoundName_ n

mkRString :: (Interval, String) -> RString
mkRString (i, s) = Ranged (getRange i) s

-- | Create a qualified name from a string (used in pragmas).
--   Range of each name component is range of whole string.
--   TODO: precise ranges!

pragmaQName :: (Interval, String) -> Parser QName
pragmaQName (r, s) = do
  let ss = chopWhen (== '.') s
  mkQName $ map (r,) ss

mkNamedArg :: Maybe QName -> Either QName Range -> Parser (NamedArg BoundName)
mkNamedArg x y = do
  lbl <- case x of
           Nothing        -> return $ Just $ WithOrigin UserWritten $ unranged "_"
           Just (QName x) -> return $ Just $ WithOrigin UserWritten $ Ranged (getRange x) $ prettyShow x
           _              -> parseError "expected unqualified variable name"
  var <- case y of
           Left (QName y) -> return $ mkBoundName y noFixity'
           Right r        -> return $ mkBoundName (noName r) noFixity'
           _              -> parseError "expected unqualified variable name"
  return $ defaultArg $ Named lbl var

-- | Polarity parser.

polarity :: (Interval, String) -> Parser (Range, Occurrence)
polarity (i, s) =
  case s of
    "_"  -> ret Unused
    "++" -> ret StrictPos
    "+"  -> ret JustPos
    "-"  -> ret JustNeg
    "*"  -> ret Mixed
    _    -> parseError $ "Not a valid polarity: " ++ s
  where
  ret x = return (getRange i, x)

recoverLayout :: [(Interval, String)] -> String
recoverLayout [] = ""
recoverLayout xs@((i, _) : _) = go (iStart i) xs
  where
    c0 = posCol (iStart i)

    go cur [] = ""
    go cur ((i, s) : xs) = padding cur (iStart i) ++ s ++ go (iEnd i) xs

    padding Pn{ posLine = l1, posCol = c1 } Pn{ posLine = l2, posCol = c2 }
      | l1 < l2  = List.genericReplicate (l2 - l1) '\n' ++ List.genericReplicate (max 0 (c2 - c0)) ' '
      | l1 == l2 = List.genericReplicate (c2 - c1) ' '

ensureUnqual :: QName -> Parser Name
ensureUnqual (QName x) = return x
ensureUnqual q@Qual{}  = parseError' (rStart' $ getRange q) "Qualified name not allowed here"

-- | Match a particular name.
isName :: String -> (Interval, String) -> Parser ()
isName s (_,s')
    | s == s'   = return ()
    | otherwise = parseError $ "expected " ++ s ++ ", found " ++ s'

-- Lambinds

-- | Result of parsing @LamBinds@.
data LamBinds' a = LamBinds
  { lamBindings   :: a             -- ^ A number of domain-free or typed bindings or record patterns.
  , absurdBinding :: Maybe Hiding  -- ^ Followed by possibly a final absurd pattern.
  } deriving (Functor)
type LamBinds = LamBinds' [LamBinding]

mkAbsurdBinding :: Hiding -> LamBinds
mkAbsurdBinding = LamBinds [] . Just

mkLamBinds :: a -> LamBinds' a
mkLamBinds bs = LamBinds bs Nothing

-- | Build a forall pi (forall x y z -> ...)
forallPi :: List1 LamBinding -> Expr -> Expr
forallPi bs e = Pi (fmap addType bs) e

-- | Converts lambda bindings to typed bindings.
addType :: LamBinding -> TypedBinding
addType (DomainFull b) = b
addType (DomainFree x) = TBind r (singleton x) $ Underscore r Nothing
  where r = getRange x

-- | Returns the value of the first erasure attribute, if any, or else
-- the default value of type 'Erased'.
--
-- Raises warnings for all attributes except for erasure attributes,
-- and for multiple erasure attributes.

onlyErased
  :: [Attr]  -- ^ The attributes, in reverse order.
  -> Parser Erased
onlyErased as = do
  es <- catMaybes <$> mapM onlyErased' (reverse as)
  case es of
    []     -> return defaultErased
    [e]    -> return e
    e : es -> do
      parseWarning $ MultipleAttributes (getRange es) (Just "erasure")
      return e
  where
  onlyErased' a = case theAttr a of
    RelevanceAttribute{} -> unsup "Relevance"
    CohesionAttribute{}  -> unsup "Cohesion"
    LockAttribute{}      -> unsup "Lock"
    TacticAttribute{}    -> unsup "Tactic"
    QuantityAttribute q  -> maybe (unsup "Linearity") (return . Just) $ erasedFromQuantity q
    where
    unsup s = do
      parseWarning $ UnsupportedAttribute (attrRange a) (Just s)
      return Nothing

-- | Constructs extended lambdas.

extLam
  :: Range            -- ^ The range of the lambda symbol and @where@ or
                      --   the braces.
  -> [Attr]           -- ^ The attributes in reverse order.
  -> List1 LamClause  -- ^ The clauses in reverse order.
  -> Parser Expr
extLam symbolRange attrs cs = do
  e <- onlyErased attrs
  let cs' = List1.reverse cs
  return $ ExtendedLam (getRange (symbolRange, e, cs')) e cs'

-- | Constructs extended or absurd lambdas.

extOrAbsLam
  :: Range   -- ^ The range of the lambda symbol.
  -> [Attr]  -- ^ The attributes, in reverse order.
  -> Either ([LamBinding], Hiding) (List1 Expr)
  -> Parser Expr
extOrAbsLam lambdaRange attrs cs = case cs of
  Right es -> do
    -- It is of the form @\ { p1 ... () }@.
    e  <- onlyErased attrs
    cl <- mkAbsurdLamClause False es
    return $ ExtendedLam (getRange (lambdaRange, e, es)) e $ singleton cl
  Left (bs, h) -> do
    mapM_ (\a -> parseWarning $
                   UnsupportedAttribute (attrRange a) Nothing)
          (reverse attrs)
    List1.ifNull bs
      {-then-} (return $ AbsurdLam r h)
      {-else-} $ \ bs -> return $ Lam r bs (AbsurdLam r h)
    where
    r = fuseRange lambdaRange bs

-- | Interpret an expression as a list of names and (not parsed yet) as-patterns

exprAsTele :: Expr -> List1 Expr
exprAsTele (RawApp _ es) = List2.toList1 es
exprAsTele e             = singleton e

exprAsNamesAndPatterns :: Expr -> Maybe (List1 (Name, Maybe Expr))
exprAsNamesAndPatterns = mapM exprAsNameAndPattern . exprAsTele

exprAsNameAndPattern :: Expr -> Maybe (Name, Maybe Expr)
exprAsNameAndPattern (Ident (QName x)) = Just (x, Nothing)
exprAsNameAndPattern (Underscore r _)  = Just (setRange r simpleHole, Nothing)
exprAsNameAndPattern (As _ n e)        = Just (n, Just e)
exprAsNameAndPattern (Paren r e)       = Just (setRange r simpleHole, Just e)
exprAsNameAndPattern _                 = Nothing

-- interpret an expression as name or list of hidden / instance names
exprAsNameOrHiddenNames :: Expr -> Maybe (List1 (NamedArg (Name, Maybe Expr)))
exprAsNameOrHiddenNames = \case
  HiddenArg _ (Named Nothing e) ->
    fmap (hide . defaultNamedArg) <$> exprAsNamesAndPatterns e
  InstanceArg _ (Named Nothing e) ->
    fmap (makeInstance . defaultNamedArg) <$> exprAsNamesAndPatterns e
  e ->
    singleton . defaultNamedArg <$> exprAsNameAndPattern e

boundNamesOrAbsurd :: List1 Expr -> Parser (Either (List1 (NamedArg Binder)) (List1 Expr))
boundNamesOrAbsurd es
  | any isAbsurd es = return $ Right es
  | otherwise       =
    case mapM exprAsNameAndPattern es of
        Nothing   -> parseError $ "expected sequence of bound identifiers"
        Just good -> fmap Left $ forM good $ \ (n, me) -> do
                       p <- traverse exprToPattern me
                       return (defaultNamedArg (Binder p (mkBoundName_ n)))

  where

    isAbsurd :: Expr -> Bool
    isAbsurd (Absurd _)                  = True
    isAbsurd (HiddenArg _ (Named _ e))   = isAbsurd e
    isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e
    isAbsurd (Paren _ e)                 = isAbsurd e
    isAbsurd (As _ _ e)                  = isAbsurd e
    isAbsurd (RawApp _ es)               = any isAbsurd es
    isAbsurd _                           = False

-- | Match a pattern-matching "assignment" statement @p <- e@
exprToAssignment :: Expr -> Parser (Maybe (Pattern, Range, Expr))
exprToAssignment e@(RawApp r es)
  | (es1, arr : es2) <- List2.break isLeftArrow es =
    case filter isLeftArrow es2 of
      arr : _ -> parseError' (rStart' $ getRange arr) $ "Unexpected " ++ prettyShow arr
      [] ->
        -- Andreas, 2021-05-06, issue #5365
        -- Handle pathological cases like @do <-@ and @do x <-@.
        case (es1, es2) of
          (e1:rest1, e2:rest2) -> do
            p <- exprToPattern $ rawApp $ e1 :| rest1
            pure $ Just (p, getRange arr, rawApp (e2 :| rest2))
          _ -> parseError' (rStart' $ getRange e) $ "Incomplete binding " ++ prettyShow e
  where
    isLeftArrow (Ident (QName (Name _ _ (Id arr :| [])))) =
      arr `elem` ["<-", "\x2190"]  -- \leftarrow [issue #5465, unicode might crash happy]
    isLeftArrow _ = False
exprToAssignment _ = pure Nothing

-- | Build a with-block
buildWithBlock ::
  [Either RewriteEqn (List1 (Named Name Expr))] ->
  Parser ([RewriteEqn], [Named Name Expr])
buildWithBlock rees = case groupByEither rees of
  (Left rs : rest) -> (List1.toList rs,) <$> finalWith rest
  rest             -> ([],) <$> finalWith rest

  where

    finalWith :: (HasRange a, HasRange b) =>
                 [Either (List1 a) (List1 (List1 b))] -> Parser [b]
    finalWith []             = pure $ []
    finalWith [Right ees]    = pure $ List1.toList $ sconcat ees
    finalWith (Right{} : tl) = parseError' (rStart' $ getRange tl)
      "Cannot use rewrite / pattern-matching with after a with-abstraction."

-- | Build a with-statement
buildWithStmt :: List1 (Named Name Expr) ->
                 Parser [Either RewriteEqn (List1 (Named Name Expr))]
buildWithStmt nes = do
  ws <- mapM buildSingleWithStmt (List1.toList nes)
  let rws = groupByEither ws
  pure $ map (first (Invert ())) rws

buildSingleWithStmt ::
  Named Name Expr ->
  Parser (Either (Named Name (Pattern, Expr)) (Named Name Expr))
buildSingleWithStmt e = do
  mpatexpr <- exprToAssignment (namedThing e)
  pure $ case mpatexpr of
    Just (pat, _, expr) -> Left ((pat, expr) <$ e)
    Nothing             -> Right e

fromWithApp :: Expr -> List1 Expr
fromWithApp = \case
  WithApp _ e es -> e :| es
  e              -> singleton e

-- | Build a do-statement
defaultBuildDoStmt :: Expr -> [LamClause] -> Parser DoStmt
defaultBuildDoStmt e (_ : _) = parseError' (rStart' $ getRange e) "Only pattern matching do-statements can have where clauses."
defaultBuildDoStmt e []      = pure $ DoThen e

buildDoStmt :: Expr -> [LamClause] -> Parser DoStmt
buildDoStmt (Let r ds Nothing) [] = return $ DoLet r ds
buildDoStmt e@(RawApp r _)    cs = do
  mpatexpr <- exprToAssignment e
  case mpatexpr of
    Just (pat, r, expr) -> pure $ DoBind r pat expr cs
    Nothing -> defaultBuildDoStmt e cs
buildDoStmt e cs = defaultBuildDoStmt e cs


-- | Extract record directives
extractRecordDirectives :: [Declaration] -> Parser (RecordDirectives, [Declaration])
extractRecordDirectives ds = do
  let (dirs, rest) = spanJust isRecordDirective ds
  dir <- verifyRecordDirectives dirs
  pure (dir, rest)

-- | Check for duplicate record directives.
verifyRecordDirectives :: [RecordDirective] -> Parser RecordDirectives
verifyRecordDirectives ds
  | null rs   = return (RecordDirectives (listToMaybe is) (listToMaybe es) (listToMaybe ps) (listToMaybe cs))
      -- Here, all the lists is, es, cs, ps are at most singletons.
  | otherwise = parseErrorRange (head rs) $ unlines $ "Repeated record directives at:" : map prettyShow rs
  where
  errorFromList []  = []
  errorFromList [x] = []
  errorFromList xs  = map getRange xs
  rs  = List.sort $ concat [ errorFromList is, errorFromList es', errorFromList cs, errorFromList ps ]
  es  = map rangedThing es'
  is  = [ i      | Induction i          <- ds ]
  es' = [ e      | Eta e                <- ds ]
  cs  = [ (c, i) | Constructor c i      <- ds ]
  ps  = [ r      | PatternOrCopattern r <- ds ]


-- | Breaks up a string into substrings. Returns every maximal
-- subsequence of zero or more characters distinct from @'.'@.
--
-- > splitOnDots ""         == [""]
-- > splitOnDots "foo.bar"  == ["foo", "bar"]
-- > splitOnDots ".foo.bar" == ["", "foo", "bar"]
-- > splitOnDots "foo.bar." == ["foo", "bar", ""]
-- > splitOnDots "foo..bar" == ["foo", "", "bar"]
splitOnDots :: String -> [String]
splitOnDots ""        = [""]
splitOnDots ('.' : s) = [] : splitOnDots s
splitOnDots (c   : s) = case splitOnDots s of
  p : ps -> (c : p) : ps


-- | Returns 'True' iff the name is a valid Haskell (hierarchical)
-- module name.
validHaskellModuleName :: String -> Bool
validHaskellModuleName = all ok . splitOnDots
  where
  -- Checks if a dot-less module name is well-formed.
  ok :: String -> Bool
  ok []      = False
  ok (c : s) =
    isUpper c &&
    all (\c -> isLower c || c == '_' ||
               isUpper c ||
               generalCategory c == DecimalNumber ||
               c == '\'')
        s

{--------------------------------------------------------------------------
    Patterns
 --------------------------------------------------------------------------}

-- | Turn an expression into a left hand side.
exprToLHS :: Expr -> Parser ([RewriteEqn] -> [WithExpr] -> LHS)
exprToLHS e = LHS <$> exprToPattern e

-- | Turn an expression into a pattern. Fails if the expression is not a
--   valid pattern.
exprToPattern :: Expr -> Parser Pattern
exprToPattern e = case C.isPattern e of
  Nothing -> parseErrorRange e $ "Not a valid pattern: " ++ prettyShow e
  Just p  -> pure p

opAppExprToPattern :: OpApp Expr -> Parser Pattern
opAppExprToPattern (SyntaxBindingLambda _ _ _) = parseError "Syntax binding lambda cannot appear in a pattern"
opAppExprToPattern (Ordinary e) = exprToPattern e

-- | Turn an expression into a name. Fails if the expression is not a
--   valid identifier.
exprToName :: Expr -> Parser Name
exprToName (Ident (QName x)) = return x
exprToName e = parseErrorRange e $ "Not a valid identifier: " ++ prettyShow e

isEqual :: Expr -> Maybe (Expr, Expr)
isEqual = \case
    Equal _ a b -> Just (a, b)
    _           -> Nothing

-- | When given expression is @e1 = e2@, turn it into a named expression.
--   Call this inside an implicit argument @{e}@ or @{{e}}@, where
--   an equality must be a named argument (rather than a cubical partial match).
maybeNamed :: Expr -> Parser (Named_ Expr)
maybeNamed e =
  case isEqual e of
    Nothing       -> return $ unnamed e
    Just (e1, e2) -> do
      let succeed x = return $ named (WithOrigin UserWritten $ Ranged (getRange e1) x) e2
      case e1 of
        Ident (QName x) -> succeed $ nameToRawName x
        -- We could have the following, but names of arguments cannot be _.
        -- Underscore{}    -> succeed $ "_"
        _ -> parseErrorRange e $ "Not a valid named argument: " ++ prettyShow e

patternSynArgs :: [NamedArg Binder] -> Parser [Arg Name]
patternSynArgs = mapM pSynArg
  where
    pSynArg x
      | let h = getHiding x, h `notElem` [Hidden, NotHidden] =
          abort $ prettyShow h ++ " arguments not allowed to pattern synonyms"
      | not (isRelevant x) =
          abort "Arguments to pattern synonyms must be relevant"
      | Just p <- binderPattern (namedArg x) =
          abort "Arguments to pattern synonyms cannot be patterns themselves"
      | otherwise = return $ fmap (boundName . binderName . namedThing) x
      where
      abort s = parseError $
        "Illegal pattern synonym argument  " ++ prettyShow x ++ "\n" ++
        "(" ++ s ++ ".)"

mkLamClause
  :: Bool   -- ^ Catch-all?
  -> [Expr] -- ^ Possibly empty list of patterns.
  -> RHS
  -> Parser LamClause
mkLamClause catchAll es rhs = mapM exprToPattern es <&> \ ps ->
  LamClause{ lamLHS = ps, lamRHS = rhs, lamCatchAll = catchAll }

mkAbsurdLamClause :: Bool -> List1 Expr -> Parser LamClause
mkAbsurdLamClause catchAll es = mkLamClause catchAll (List1.toList es) AbsurdRHS

parsePanic s = parseError $ "Internal parser error: " ++ s ++ ". Please report this as a bug."

{- RHS or type signature -}

data RHSOrTypeSigs
 = JustRHS RHS
 | TypeSigsRHS Expr
 deriving Show

patternToNames :: Pattern -> Parser (List1 (ArgInfo, Name))
patternToNames = \case
    IdentP (QName i)         -> return $ singleton $ (defaultArgInfo, i)
    WildP r                  -> return $ singleton $ (defaultArgInfo, C.noName r)
    DotP _ (Ident (QName i)) -> return $ singleton $ (setRelevance Irrelevant defaultArgInfo, i)
    RawAppP _ ps             -> sconcat . List2.toList1 <$> mapM patternToNames ps
    p                        -> parseError $
      "Illegal name in type signature: " ++ prettyShow p

funClauseOrTypeSigs :: [Attr] -> ([RewriteEqn] -> [WithExpr] -> LHS)
                    -> [Either RewriteEqn (List1 (Named Name Expr))]
                    -> RHSOrTypeSigs
                    -> WhereClause -> Parser (List1 Declaration)
funClauseOrTypeSigs attrs lhs' with mrhs wh = do
  (rs , es) <- buildWithBlock with
  let lhs = lhs' rs (map (fmap observeModifiers) es)
  -- traceShowM lhs
  case mrhs of
    JustRHS rhs   -> do
      unless (null attrs) $ parseErrorRange attrs $ "A function clause cannot have attributes"
      return $ singleton $ FunClause lhs rhs wh False
    TypeSigsRHS e -> case wh of
      NoWhere -> case lhs of
        LHS p _ _ | hasEllipsis p -> parseError "The ellipsis ... cannot have a type signature"
        LHS _ _ (_:_) -> parseError "Illegal: with in type signature"
        LHS _ (_:_) _ -> parseError "Illegal: rewrite in type signature"
        LHS p _ _ | hasWithPatterns p -> parseError "Illegal: with patterns in type signature"
        LHS p [] [] -> forMM (patternToNames p) $ \ (info, x) -> do
          info <- applyAttrs attrs info
          return $ typeSig info (getTacticAttr attrs) x e
      _ -> parseError "A type signature cannot have a where clause"

parseDisplayPragma :: Range -> Position -> String -> Parser Pragma
parseDisplayPragma r pos s =
  case parsePosString pos defaultParseFlags [normal] funclauseParser s of
    ParseOk s (FunClause (LHS lhs [] []) (RHS rhs) NoWhere ca :| []) | null (parseInp s) ->
      return $ DisplayPragma r lhs rhs
    _ -> parseError "Invalid DISPLAY pragma. Should have form {-# DISPLAY LHS = RHS #-}."

typeSig :: ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration
typeSig i tac n e = TypeSig i tac n (Generalized e)

-- * Attributes

-- | Parsed attribute.

data Attr = Attr
  { attrRange :: Range       -- ^ Range includes the @.
  , attrName  :: String      -- ^ Concrete, user written attribute for error reporting.
  , theAttr   :: Attribute   -- ^ Parsed attribute.
  }

instance HasRange Attr where
  getRange = attrRange

instance SetRange Attr where
  setRange r (Attr _ x a) = Attr r x a

-- | Parse an attribute.
toAttribute :: Expr -> Parser Attr
toAttribute x = do
  attr <- maybe failure (return . Attr r y) $ exprToAttribute x
  case theAttr attr of
    CohesionAttribute{} ->
      modify' (\s -> s { parseCohesion = (y, r) : parseCohesion s })
    _                   -> return ()
  return attr
  where
  r = getRange x
  y = prettyShow x
  failure = parseErrorRange x $ "Unknown attribute: " ++ y

-- | Apply an attribute to thing (usually `Arg`).
--   This will fail if one of the attributes is already set
--   in the thing to something else than the default value.
applyAttr :: (LensAttribute a) => Attr -> a -> Parser a
applyAttr attr@(Attr r x a) = maybe failure return . setPristineAttribute a
  where
  failure = errorConflictingAttribute attr

-- | Apply attributes to thing (usually `Arg`).
--   Expects a reversed list of attributes.
--   This will fail if one of the attributes is already set
--   in the thing to something else than the default value.
applyAttrs :: LensAttribute a => [Attr] -> a -> Parser a
applyAttrs rattrs arg = do
  let attrs = reverse rattrs
  checkForUniqueAttribute (isJust . isQuantityAttribute ) attrs
  checkForUniqueAttribute (isJust . isRelevanceAttribute) attrs
  checkForUniqueAttribute (isJust . isTacticAttribute)    attrs
  foldM (flip applyAttr) arg attrs

applyAttrs1 :: LensAttribute a => List1 Attr -> a -> Parser a
applyAttrs1 = applyAttrs . List1.toList

-- | Set the tactic attribute of a binder
setTacticAttr :: List1 Attr -> NamedArg Binder -> NamedArg Binder
setTacticAttr as = updateNamedArg $ fmap $ \ b ->
  case getTacticAttr $ List1.toList as of
    Just t  -> b { bnameTactic = Just t }
    Nothing -> b

-- | Get the tactic attribute if present.
getTacticAttr :: [Attr] -> TacticAttribute
getTacticAttr as =
  case tacticAttributes [ a | Attr _ _ a <- as ] of
    [TacticAttribute e] -> Just e
    []                  -> Nothing
    _                   -> __IMPOSSIBLE__

-- | Report a parse error if two attributes in the list are of the same kind,
--   thus, present conflicting information.
checkForUniqueAttribute :: (Attribute -> Bool) -> [Attr] -> Parser ()
checkForUniqueAttribute p attrs = do
  let pAttrs = filter (p . theAttr) attrs
  when (length pAttrs >= 2) $
    errorConflictingAttributes pAttrs

-- | Report an attribute as conflicting (e.g., with an already set value).
errorConflictingAttribute :: Attr -> Parser a
errorConflictingAttribute a = parseErrorRange a $ "Conflicting attribute: " ++ attrName a

-- | Report attributes as conflicting (e.g., with each other).
--   Precondition: List not emtpy.
errorConflictingAttributes :: [Attr] -> Parser a
errorConflictingAttributes [a] = errorConflictingAttribute a
errorConflictingAttributes as  = parseErrorRange as $
  "Conflicting attributes: " ++ unwords (map attrName as)
}
