{ #if __GLASGOW_HASKELL__ > 800 {-# OPTIONS_GHC -Wno-error=missing-signatures #-} #endif {-# LANGUAGE PatternGuards #-} {-| The parser is generated by 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 ) where import Prelude hiding ( null ) import qualified Prelude 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.Helpers 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.Syntax.Common.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 $$ } 'opaque' { TokKeyword KwOpaque $$ } 'unfolding' { TokKeyword KwUnfolding $$ } 'BUILTIN' { TokKeyword KwBUILTIN $$ } 'CATCHALL' { TokKeyword KwCATCHALL $$ } 'DISPLAY' { TokKeyword KwDISPLAY $$ } 'ETA' { TokKeyword KwETA $$ } 'FOREIGN' { TokKeyword KwFOREIGN $$ } 'COMPILE' { TokKeyword KwCOMPILE $$ } 'IMPOSSIBLE' { TokKeyword KwIMPOSSIBLE $$ } 'INCOHERENT' { TokKeyword KwINCOHERENT $$ } 'INJECTIVE' { TokKeyword KwINJECTIVE $$ } 'INJECTIVE_FOR_INFERENCE' { TokKeyword KwINJECTIVE_FOR_INFERENCE $$ } '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 $$ } 'OVERLAPPABLE' { TokKeyword KwOVERLAPPABLE $$ } 'OVERLAPPING' { TokKeyword KwOVERLAPPING $$ } 'OVERLAPS' { TokKeyword KwOVERLAPS $$ } '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 } | 'opaque' { TokKeyword KwOpaque $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 } | 'unfolding' { TokKeyword KwUnfolding $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 } | 'INCOHERENT' { TokKeyword KwINCOHERENT $1 } | 'INJECTIVE' { TokKeyword KwINJECTIVE $1 } | 'INJECTIVE_FOR_INFERENCE' { TokKeyword KwINJECTIVE_FOR_INFERENCE $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 } | 'OVERLAPPABLE' { TokKeyword KwOVERLAPPABLE $1 } | 'OVERLAPPING' { TokKeyword KwOVERLAPPING $1 } | 'OVERLAPS' { TokKeyword KwOVERLAPS $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 { defaultShapeIrrelevantArg $1 $2 } | '.' Id { defaultIrrelevantArg $1 $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 . defaultIrrelevantArg $1) $3 <> $5 } | '.' '{' SpaceIds '}' { fmap (hide . defaultIrrelevantArg $1) $3 } | '.' '{{' SpaceIds DoubleCloseBrace ArgIds { fmap (makeInstance . defaultIrrelevantArg $1) $3 <> $5 } | '.' '{{' SpaceIds DoubleCloseBrace { fmap (makeInstance . defaultIrrelevantArg $1) $3 } | '..' '{' SpaceIds '}' ArgIds { fmap (hide . defaultShapeIrrelevantArg $1) $3 <> $5 } | '..' '{' SpaceIds '}' { fmap (hide . defaultShapeIrrelevantArg $1) $3 } | '..' '{{' SpaceIds DoubleCloseBrace ArgIds { fmap (makeInstance . defaultShapeIrrelevantArg $1) $3 <> $5 } | '..' '{{' SpaceIds DoubleCloseBrace { fmap (makeInstance . defaultShapeIrrelevantArg $1) $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 {% toAttribute (getRange ($1,$2)) $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 empty , $1) } | '.' BId { (Irrelevant (OIrrDot $ getRange $1), $2) } | '..' BId { (ShapeIrrelevant (OShIrrDotDot $ getRange $1), $2) } -} -- Space separated list of binding identifiers. Used in fixity -- declarations infixl 100 + - SpaceBIds :: { List1 Name } SpaceBIds : BId SpaceBIds { $1 <| $2 } | BId { singleton $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 UserBinderName (mkBoundName_ n) } -- Space separated list of strings in a pragma. PragmaStrings :: { [(Interval, String)] } PragmaStrings : {- empty -} { [] } | string PragmaStrings { $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 } PragmaQNames1 :: { [QName] } PragmaQNames1 : PragmaQName PragmaQNames { $1:$2 } {-------------------------------------------------------------------------- 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 :| e1 : es -> return $ WithApp (getRange (e, e1, es)) e (e1 :| 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 : {- empty -} { [] } | 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 (kwRange $1) $2 } | '..' Expr3 { DoubleDot (kwRange $1) $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 : '(' Open ')' { TLet (getRange ($1,$3)) $2 } | '(' 'let' Declarations ')' { TLet (getRange ($1,$4)) $3 } -- relevant | '(' TBindWithHiding ')' { setRange (getRange ($1,$2,$3)) $ $2 } | '{' TBind '}' { setRange (getRange ($1,$2,$3)) $ hide $2 } | '{{' TBind DoubleCloseBrace { setRange (getRange ($1,$2,$3)) $ makeInstance $2 } -- irrelevant | '.' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $ makeIrrelevant $1 $3 } | '.' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $ hide $ makeIrrelevant $1 $3 } | '.' '{{' TBind DoubleCloseBrace { setRange (getRange ($2,$3,$4)) $ makeInstance $ makeIrrelevant $1 $3 } -- shape-irrelevant | '..' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $ makeShapeIrrelevant $1 $3 } | '..' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $ hide $ makeShapeIrrelevant $1 $3 } | '..' '{{' TBind DoubleCloseBrace { setRange (getRange ($2,$3,$4)) $ makeInstance $ makeShapeIrrelevant $1 $3 } -- attributes, relevant | '(' ModalTBindWithHiding ')' { setRange (getRange ($1,$2,$3)) $ $2 } | '{{' ModalTBind DoubleCloseBrace { setRange (getRange ($1,$2,$3)) $ makeInstance $2 } | '{' ModalTBind '}' { setRange (getRange ($1,$2,$3)) $ hide $2 } -- attributes, irrelevant | '.' '(' ModalTBindWithHiding ')' {% setRange (getRange ($2,$3,$4)) <\$> makeIrrelevantM $1 $3 } | '.' '{' ModalTBind '}' {% setRange (getRange ($2,$3,$4)) . hide <\$> makeIrrelevantM $1 $3 } | '.' '{{' ModalTBind DoubleCloseBrace {% setRange (getRange ($2,$3,$4)) . makeInstance <\$> makeIrrelevantM $1 $3 } -- attributes, shape-irrelevant | '..' '(' ModalTBindWithHiding ')' {% setRange (getRange ($2,$3,$4)) <\$> makeShapeIrrelevantM $1 $3 } | '..' '{' ModalTBind '}' {% setRange (getRange ($2,$3,$4)) . hide <\$> makeShapeIrrelevantM $1 $3 } | '..' '{{' ModalTBind DoubleCloseBrace {% setRange (getRange ($2,$3,$4)) . makeInstance <\$> makeShapeIrrelevantM $1 $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 empty $1 (RHS $3) } | CatchallPragma Application3PossiblyEmpty '->' Expr {% mkLamClause (YesCatchall (getRange $1)) $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 empty $1 } | CatchallPragma Application {% mkAbsurdLamClause (YesCatchall (getRange $1)) $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 -- no parentheses : BId MaybeAsPattern { Left . singleton $ mkDomainFree_ id $2 $1 } | '.' BId MaybeAsPattern { Left . singleton $ mkDomainFree_ (makeIrrelevant $1) $3 $2 } | '..' BId MaybeAsPattern { Left . singleton $ mkDomainFree_ (makeShapeIrrelevant $1) $3 $2 } -- just parentheses | '(' Application ')' {% exprToPattern (rawApp $2) >>= \ p -> pure . Left . singleton $ mkDomainFree_ id (Just p) $ simpleHole } | '{' CommaBIdAndAbsurds '}' { first (fmap hide) $2 } | '{{' CommaBIds DoubleCloseBrace { Left $ fmap makeInstance $2 } -- additonal attributes, e.g. @tactic | '(' Attributes1 CommaBIdAndAbsurds ')' {% applyAttrs1 $2 defaultArgInfo <&> \ ai -> first (fmap (setTacticAttr $2 . setArgInfo ai)) $3 } | '{' Attributes1 CommaBIdAndAbsurds '}' {% applyAttrs1 $2 defaultArgInfo <&> \ ai -> first (fmap (hide . setTacticAttr $2 . setArgInfo ai)) $3 } | '{{' Attributes1 CommaBIds DoubleCloseBrace {% Left <\$> applyAttributes $2 (makeInstance defaultArgInfo) $3 } -- additional irrelevance | '.' '(' CommaBIds ')' { Left $ fmap (makeIrrelevant $1) $3 } | '.' '{' CommaBIds '}' { Left $ fmap (hide . makeIrrelevant $1) $3 } | '.' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . makeIrrelevant $1) $3 } -- additional shape-irrelevance | '..' '(' CommaBIds ')' { Left $ fmap (makeShapeIrrelevant $1) $3 } | '..' '{' CommaBIds '}' { Left $ fmap (hide . makeShapeIrrelevant $1) $3 } | '..' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . makeShapeIrrelevant $1) $3 } -- additional irrelevance and attributes | '.' '(' Attributes1 CommaBIds ')' {% Left <\$> applyAttributes $3 (makeIrrelevant $1 defaultArgInfo) $4 } | '.' '{' Attributes1 CommaBIds '}' {% Left <\$> applyAttributes $3 (makeIrrelevant $1 $ hide defaultArgInfo) $4 } | '.' '{{' Attributes1 CommaBIds DoubleCloseBrace {% Left <\$> applyAttributes $3 (makeIrrelevant $1 $ makeInstance defaultArgInfo) $4 } -- additional shape-irrelevance and attributes | '..' '(' Attributes1 CommaBIds ')' {% Left <\$> applyAttributes $3 (makeShapeIrrelevant $1 defaultArgInfo) $4 } | '..' '{' Attributes1 CommaBIds '}' {% Left <\$> applyAttributes $3 (makeShapeIrrelevant $1 $ hide defaultArgInfo) $4 } | '..' '{{' Attributes1 CommaBIds DoubleCloseBrace {% Left <\$> applyAttributes $3 (makeShapeIrrelevant $1 $ makeInstance defaultArgInfo) $4 } {-------------------------------------------------------------------------- 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 (kwRange $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 } -- Parsing either an expression @e@ or a @(rewrite | with p <-) e1 | ... | en@. HoleContent :: { HoleContent } HoleContent : Expr { HoleContentExpr $1 } | WHS {% 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' Attributes Id 'where' Declarations0 {% onlyErased $2 >>= \erased -> return $ SomeWhere (getRange ($1,$4)) erased $3 PublicAccess $5 } | 'module' Attributes Underscore 'where' Declarations0 {% onlyErased $2 >>= \erased -> return $ SomeWhere (getRange ($1,$4)) erased $3 PublicAccess $5 } -- 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 } | Opaque { singleton $1 } | Unfolding { singleton $1 } {-------------------------------------------------------------------------- Individual declarations --------------------------------------------------------------------------} -- 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 WHS {% fmap (++ $3) (buildWithStmt $2) } | 'rewrite' UnnamedWithExprs WHS { Left (Rewrite $ fmap ((),) $2) : $3 } | 'using' UnnamedWithExprs WHS {% do eqn <- buildUsingStmt $2 pure $ Left eqn : $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)) defaultErased $2 $3 $5 $7 } | 'data' Attributes1 Id TypedUntypedBindings ':' Expr 'where' Declarations0 {% onlyErased (List1.toList $2) >>= \e -> return $ Data (getRange (($1,$2,$3,$4),($5,$6,$7,$8))) e $3 $4 $6 $8 } -- 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)) defaultErased $2 $3 $5 } | 'data' Attributes1 Id TypedUntypedBindings ':' Expr {% onlyErased (List1.toList $2) >>= \e -> return $ DataSig (getRange ($1,$2,$3,$4,$5,$6)) e $3 $4 $6 } -- 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)) defaultErased n dir $3 $5 ds } | 'record' Attributes1 Expr3NoCurly TypedUntypedBindings ':' Expr 'where' RecordDeclarations {% onlyErased (List1.toList $2) >>= \e -> exprToName $3 >>= \n -> let (dir, ds) = $8 in return $ Record (getRange (($1,$2,$3,$4),($5,$6,$7,$8))) e n dir $4 $6 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)) defaultErased n $3 $5 } | 'record' Attributes1 Expr3NoCurly TypedUntypedBindings ':' Expr {% onlyErased (List1.toList $2) >>= \e -> exprToName $3 >>= \n -> return $ RecordSig (getRange ($1,$2,$3,$4,$5,$6)) e n $4 $6 } Constructor :: { Declaration } Constructor : 'data' '_' 'where' Declarations0 { LoneConstructor (kwRange ($1,$2,$3)) $4 } -- Declaration of record constructor name. RecordConstructorName :: { (Name, IsInstance) } RecordConstructorName : 'constructor' Id { ($2, NotInstanceDef) } | 'instance' vopen 'constructor' Id close { ($4, InstanceDef (kwRange $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 empty -- no @instance@ keyword here _ -> NotInstanceDef toField (Arg info (TypeSig info' tac x t)) = FieldSig (inst info') tac x (Arg info t) in Field (kwRange $1) $ 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 (kwRange $1) (map toGeneralize $2) } -- Mutually recursive declarations. Mutual :: { Declaration } Mutual : 'mutual' Declarations0 { Mutual (kwRange $1) $2 } | 'interleaved' 'mutual' Declarations0 { InterleavedMutual (kwRange ($1,$2)) $3 } -- Abstract declarations. Abstract :: { Declaration } Abstract : 'abstract' Declarations0 { Abstract (kwRange $1) $2 } -- Private can only appear on the top-level (or rather the module level). Private :: { Declaration } Private : 'private' Declarations0 { Private (kwRange $1) UserWritten $2 } -- Instance declarations. Instance :: { Declaration } Instance : 'instance' Declarations0 { InstanceB (kwRange $1) $2 } -- Macro declarations. Macro :: { Declaration } Macro : 'macro' Declarations0 { Macro (kwRange $1) $2 } -- Postulates. Postulate :: { Declaration } Postulate : 'postulate' Declarations0 { Postulate (kwRange $1) $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 (kwRange $1) (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 :: { [WithHiding 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 (getRange ($2, $3)) m (Just (AsName (Right fresh) asR)) DontOpen defaultImportDir ; appStm m' es = Private empty Inserted [ ModuleMacro r defaultErased m' (SectionApp (getRange es) [] (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 empty Inserted [ ModuleMacro r defaultErased (noName $ beginningOf $ getRange m) (SectionApp (getRange (m , es)) [] m es) DoOpen dir ] } } | 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective { let r = getRange $2 in singleton $ Private empty Inserted [ ModuleMacro r defaultErased (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 $1 $2) } -- Module instantiation ModuleMacro :: { Declaration } ModuleMacro : 'module' Attributes ModuleName TypedUntypedBindings '=' ModuleApplication ImportDirective {% do { ma <- $6 (map addType $4) ; erased <- onlyErased $2 ; name <- ensureUnqual $3 ; return $ ModuleMacro (getRange ($1, $2, $3, ma, $7)) erased name ma DontOpen $7 } } | 'open' 'module' Attributes Id TypedUntypedBindings '=' ModuleApplication ImportDirective {% do { ma <- $7 (map addType $5) ; erased <- onlyErased $3 ; return $ ModuleMacro (getRange ($1, $2, $3, $4, ma, $8)) erased $4 ma DoOpen $8 } } -- Module Module :: { Declaration } Module : 'module' Attributes ModuleName TypedUntypedBindings 'where' Declarations0 {% onlyErased $2 >>= \erased -> return $ Module (getRange ($1,$2,$3,$4,$5,$6)) erased $3 (map addType $4) $6 } | 'module' Attributes Underscore TypedUntypedBindings 'where' Declarations0 {% onlyErased $2 >>= \erased -> return $ Module (getRange ($1,$2,$3,$4,$5,$6)) erased (QName $3) (map addType $4) $6 } 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 } | InjectiveForInferencePragma { $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 } | OverlapPragma { $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, map fst $3, $4)) (map snd $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)) (mkRText $3) (recoverLayout (DL.toList $4)) } CompilePragma :: { Pragma } CompilePragma : '{-#' 'COMPILE' string PragmaQName PragmaStrings '#-}' { CompilePragma (getRange ($1, $2, fst $3, $4, map fst $5, $6)) (mkRText $3) $4 (unwords (map snd $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 } OverlapPragma :: { Pragma } OverlapPragma : '{-#' 'OVERLAPPABLE' PragmaQNames1 '#-}' { OverlapPragma (getRange ($1,$2,$3,$4)) $3 Overlappable } | '{-#' 'OVERLAPPING' PragmaQNames1 '#-}' { OverlapPragma (getRange ($1,$2,$3,$4)) $3 Overlapping } | '{-#' 'OVERLAPS' PragmaQNames1 '#-}' { OverlapPragma (getRange ($1,$2,$3,$4)) $3 Overlaps } | '{-#' 'INCOHERENT' PragmaQNames1 '#-}' { OverlapPragma (getRange ($1,$2,$3,$4)) $3 Incoherent } InjectivePragma :: { Pragma } InjectivePragma : '{-#' 'INJECTIVE' PragmaQName '#-}' { InjectivePragma (getRange ($1,$2,$3,$4)) $3 } InjectiveForInferencePragma :: { Pragma } InjectiveForInferencePragma : '{-#' 'INJECTIVE_FOR_INFERENCE' PragmaQName '#-}' { InjectiveForInferencePragma (getRange ($1,$2,$3,$4)) $3 } DisplayPragma :: { Pragma } DisplayPragma : '{-#' 'DISPLAY' string PragmaStrings '#-}' {% let (r, s) = $3 in parseDisplayPragma (getRange ($1, $2, r, map fst $4, $5)) (iStart r) (unwords (s : map snd $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, map fst $3, $4)) (map snd $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 occs = reverse $4 in PolarityPragma (getRange ($1,$2,$3,occs,$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 :: { [Ranged Occurrence] } Polarities : {- empty -} { [] } | Polarities Polarity { $2 : $1 } Polarity :: { Ranged Occurrence } Polarity : string {% polarity $1 } {-------------------------------------------------------------------------- Sequences of declarations --------------------------------------------------------------------------} -- 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 :: { ([RecordDirective], [Declaration]) } RecordDeclarations : vopen RecordDirectives close { (reverse $2, []) } | vopen RecordDirectives semi Declarations1 close { (reverse $2, List1.toList $4) } | vopen Declarations1 close { ([], 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 } Opaque :: { Declaration } : 'opaque' Declarations0 { Opaque (kwRange $1) $2 } Unfolding :: { Declaration } : 'unfolding' UnfoldingNames { Unfolding (kwRange $1) $2 } UnfoldingNames :: { [QName] } UnfoldingNames : QId UnfoldingNames { $1:$2 } | {- empty -} { [] } -- 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 -- | Parse a display pragma. parseDisplayPragma :: Range -- ^ Range of the whole DISPLAY pragma. -> Position -- ^ Start of the name the thing we want to display. -> String -- ^ The DISPLAY pragma content. -> 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 #-}." {-------------------------------------------------------------------------- Happy stuff --------------------------------------------------------------------------} -- | Required by Happy. happyError :: Parser a happyError = parseError "" {-------------------------------------------------------------------------- Utility functions --------------------------------------------------------------------------} -- Utilites have been moved to Agda.Syntax.Parser.Helpers. -- -- Add Haskell functions used in the parser there, not here. }