{ #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 , splitOnDots -- only used by the internal test-suite ) where import Prelude hiding ( null ) import Control.Applicative ( (<|>) ) import Control.Monad import Data.Bifunctor (first, second) import Data.Char 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 $$ } '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 } | '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 :: { [(Interval, String)] } ForeignCode : {- empty -} { [] } | string ForeignCode { $1 : $2 } | '{-#' ForeignCode '#-}' ForeignCode { [($1, "{-#")] ++ $2 ++ [($3, "#-}")] ++ $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.fromList $ 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' 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 $3 $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 } SimpleIds :: { [RString] } SimpleIds : SimpleId { [$1] } | SimpleIds SimpleId {$1 ++ [$2]} HoleNames :: { [NamedArg HoleName] } HoleNames : { [] } | HoleNames HoleName {$1 ++ [$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 } | '(' '\\' SimpleId '->' SimpleId ')' { LambdaHole $3 $5 } | '(' '\\' '_' '->' SimpleId ')' { LambdaHole (Ranged (getRange $3) "_") $5 } SimpleHole :: { HoleName } SimpleHole : SimpleId { ExprHole $1 } | '\\' SimpleId '->' SimpleId { LambdaHole $2 $4 } | '\\' '_' '->' SimpleId { LambdaHole (Ranged (getRange $3) "_") $4 } -- Variable name hole to be implemented later. -- Discard the interval. SimpleId :: { RString } SimpleId : id { Ranged (getRange $ fst $1) (stringToRawName $ snd $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 } | 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 $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 } 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 = maybe failure (return . Attr (getRange x) y) $ exprToAttribute x where 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) }