{ -- | -- Module : Cryptol.Parser -- Copyright : (c) 2013-2016 Galois, Inc. -- License : BSD3 -- Maintainer : cryptol@galois.com -- Stability : provisional -- Portability : portable {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-} module Cryptol.Parser ( parseModule , parseProgram, parseProgramWith , parseExpr, parseExprWith , parseDecl, parseDeclWith , parseDecls, parseDeclsWith , parseLetDecl, parseLetDeclWith , parseRepl, parseReplWith , parseSchema, parseSchemaWith , parseModName, parseHelpName , ParseError(..), ppError , Layout(..) , Config(..), defaultConfig , guessPreProc, PreProc(..) ) where import Control.Applicative as A import Data.Maybe(fromMaybe) import Data.Text(Text) import qualified Data.Text as T import Control.Monad(liftM2,msum) import Cryptol.Parser.AST import Cryptol.Parser.Position import Cryptol.Parser.LexerUtils hiding (mkIdent) import Cryptol.Parser.ParserUtils import Cryptol.Parser.Unlit(PreProc(..), guessPreProc) import Cryptol.Utils.Ident(paramInstModName) import Paths_cryptol } {- state 196 contains 1 shift/reduce conflicts. `_` identifier conflicts with `_` in record update. We have `_` as an identifier for the cases where we parse types as expressions, for example `[ 12 .. _ ]`. -} %expect 1 %token NUM { $$@(Located _ (Token (Num {}) _))} FRAC { $$@(Located _ (Token (Frac {}) _))} STRLIT { $$@(Located _ (Token (StrLit {}) _))} CHARLIT { $$@(Located _ (Token (ChrLit {}) _))} IDENT { $$@(Located _ (Token (Ident [] _) _))} QIDENT { $$@(Located _ (Token Ident{} _))} SELECTOR { $$@(Located _ (Token (Selector _) _))} 'include' { Located $$ (Token (KW KW_include) _)} 'import' { Located $$ (Token (KW KW_import) _)} 'as' { Located $$ (Token (KW KW_as) _)} 'hiding' { Located $$ (Token (KW KW_hiding) _)} 'private' { Located $$ (Token (KW KW_private) _)} 'parameter' { Located $$ (Token (KW KW_parameter) _)} 'property' { Located $$ (Token (KW KW_property) _)} 'infix' { Located $$ (Token (KW KW_infix) _)} 'infixl' { Located $$ (Token (KW KW_infixl) _)} 'infixr' { Located $$ (Token (KW KW_infixr) _)} 'type' { Located $$ (Token (KW KW_type ) _)} 'newtype' { Located $$ (Token (KW KW_newtype) _)} 'module' { Located $$ (Token (KW KW_module ) _)} 'where' { Located $$ (Token (KW KW_where ) _)} 'let' { Located $$ (Token (KW KW_let ) _)} 'if' { Located $$ (Token (KW KW_if ) _)} 'then' { Located $$ (Token (KW KW_then ) _)} 'else' { Located $$ (Token (KW KW_else ) _)} 'x' { Located $$ (Token (KW KW_x) _)} 'primitive' { Located $$ (Token (KW KW_primitive) _)} 'constraint'{ Located $$ (Token (KW KW_constraint) _)} 'Prop' { Located $$ (Token (KW KW_Prop) _)} '[' { Located $$ (Token (Sym BracketL) _)} ']' { Located $$ (Token (Sym BracketR) _)} '<-' { Located $$ (Token (Sym ArrL ) _)} '..' { Located $$ (Token (Sym DotDot ) _)} '...' { Located $$ (Token (Sym DotDotDot) _)} '|' { Located $$ (Token (Sym Bar ) _)} '(' { Located $$ (Token (Sym ParenL ) _)} ')' { Located $$ (Token (Sym ParenR ) _)} ',' { Located $$ (Token (Sym Comma ) _)} ';' { Located $$ (Token (Sym Semi ) _)} -- '.' { Located $$ (Token (Sym Dot ) _)} '{' { Located $$ (Token (Sym CurlyL ) _)} '}' { Located $$ (Token (Sym CurlyR ) _)} '<|' { Located $$ (Token (Sym TriL ) _)} '|>' { Located $$ (Token (Sym TriR ) _)} '=' { Located $$ (Token (Sym EqDef ) _)} '`' { Located $$ (Token (Sym BackTick) _)} ':' { Located $$ (Token (Sym Colon ) _)} '->' { Located $$ (Token (Sym ArrR ) _)} '=>' { Located $$ (Token (Sym FatArrR ) _)} '\\' { Located $$ (Token (Sym Lambda ) _)} '_' { Located $$ (Token (Sym Underscore ) _)} 'v{' { Located $$ (Token (Virt VCurlyL) _)} 'v}' { Located $$ (Token (Virt VCurlyR) _)} 'v;' { Located $$ (Token (Virt VSemi) _)} '+' { Located $$ (Token (Op Plus) _)} '*' { Located $$ (Token (Op Mul) _)} '^^' { Located $$ (Token (Op Exp) _)} '-' { Located $$ (Token (Op Minus) _)} '~' { Located $$ (Token (Op Complement) _)} '#' { Located $$ (Token (Op Hash) _)} '@' { Located $$ (Token (Op At) _)} OP { $$@(Located _ (Token (Op (Other [] _)) _))} QOP { $$@(Located _ (Token (Op Other{} ) _))} DOC { $$@(Located _ (Token (White DocStr) _)) } %name vmodule vmodule %name program program %name programLayout program_layout %name expr expr %name decl decl %name decls decls %name declsLayout decls_layout %name letDecl let_decl %name repl repl %name schema schema %name modName modName %name helpName help_name %tokentype { Located Token } %monad { ParseM } %lexer { lexerP } { Located _ (Token EOF _) } {- If you add additional operators, please update the corresponding tables in the pretty printer. -} %right '->' %right '#' %% vmodule :: { Module PName } : 'module' modName 'where' 'v{' vmod_body 'v}' { mkModule $2 $5 } | 'module' modName '=' modName 'where' 'v{' vmod_body 'v}' { mkModuleInstance $2 $4 $7 } | 'v{' vmod_body 'v}' { mkAnonymousModule $2 } vmod_body :: { ([Located Import], [TopDecl PName]) } : vimports 'v;' vtop_decls { (reverse $1, reverse $3) } | vimports ';' vtop_decls { (reverse $1, reverse $3) } | vimports { (reverse $1, []) } | vtop_decls { ([], reverse $1) } | {- empty -} { ([], []) } vimports :: { [Located Import] } : vimports 'v;' import { $3 : $1 } | vimports ';' import { $3 : $1 } | import { [$1] } -- XXX replace rComb with uses of at import :: { Located Import } : 'import' modName mbAs mbImportSpec { Located { srcRange = rComb $1 $ fromMaybe (srcRange $2) $ msum [ fmap srcRange $4 , fmap srcRange $3 ] , thing = Import { iModule = thing $2 , iAs = fmap thing $3 , iSpec = fmap thing $4 } } } mbAs :: { Maybe (Located ModName) } : 'as' modName { Just $2 } | {- empty -} { Nothing } mbImportSpec :: { Maybe (Located ImportSpec) } : mbHiding '(' name_list ')'{ Just Located { srcRange = case $3 of { [] -> emptyRange ; xs -> rCombs (map srcRange xs) } , thing = $1 (reverse (map thing $3)) } } | {- empty -} { Nothing } name_list :: { [LIdent] } : name_list ',' ident { $3 : $1 } | ident { [$1] } | {- empty -} { [] } mbHiding :: { [Ident] -> ImportSpec } : 'hiding' { Hiding } | {- empty -} { Only } program :: { Program PName } : top_decls { Program (reverse $1) } | {- empty -} { Program [] } program_layout :: { Program PName } : 'v{' vtop_decls 'v}' { Program (reverse $2) } | 'v{''v}' { Program [] } top_decls :: { [TopDecl PName] } : top_decl ';' { $1 } | top_decls top_decl ';' { $2 ++ $1 } vtop_decls :: { [TopDecl PName] } : vtop_decl { $1 } | vtop_decls 'v;' vtop_decl { $3 ++ $1 } | vtop_decls ';' vtop_decl { $3 ++ $1 } vtop_decl :: { [TopDecl PName] } : decl { [exportDecl Nothing Public $1] } | doc decl { [exportDecl (Just $1) Public $2] } | mbDoc 'include' STRLIT {% (return . Include) `fmap` fromStrLit $3 } | mbDoc 'property' name apats '=' expr { [exportDecl $1 Public (mkProperty $3 $4 $6)] } | mbDoc 'property' name '=' expr { [exportDecl $1 Public (mkProperty $3 [] $5)] } | mbDoc newtype { [exportNewtype Public $1 $2] } | prim_bind { $1 } | private_decls { $1 } | parameter_decls { $1 } top_decl :: { [TopDecl PName] } : decl { [Decl (TopLevel {tlExport = Public, tlValue = $1 })] } | 'include' STRLIT {% (return . Include) `fmap` fromStrLit $2 } | prim_bind { $1 } private_decls :: { [TopDecl PName] } : 'private' 'v{' vtop_decls 'v}' { changeExport Private (reverse $3) } | doc 'private' 'v{' vtop_decls 'v}' { changeExport Private (reverse $4) } prim_bind :: { [TopDecl PName] } : mbDoc 'primitive' name ':' schema { mkPrimDecl $1 $3 $5 } | mbDoc 'primitive' '(' op ')' ':' schema { mkPrimDecl $1 $4 $7 } | mbDoc 'primitive' 'type' schema ':' kind {% mkPrimTypeDecl $1 $4 $6 } parameter_decls :: { [TopDecl PName] } : 'parameter' 'v{' par_decls 'v}' { reverse $3 } | doc 'parameter' 'v{' par_decls 'v}' { reverse $4 } -- Reversed par_decls :: { [TopDecl PName] } : par_decl { [$1] } | par_decls ';' par_decl { $3 : $1 } | par_decls 'v;' par_decl { $3 : $1 } par_decl :: { TopDecl PName } : mbDoc name ':' schema { mkParFun $1 $2 $4 } | mbDoc 'type' name ':' kind {% mkParType $1 $3 $5 } | mbDoc 'type' 'constraint' type {% fmap (DParameterConstraint . distrLoc) (mkProp $4) } doc :: { Located Text } : DOC { mkDoc (fmap tokenText $1) } mbDoc :: { Maybe (Located Text) } : doc { Just $1 } | {- empty -} { Nothing } decl :: { Decl PName } : vars_comma ':' schema { at (head $1,$3) $ DSignature (reverse $1) $3 } | ipat '=' expr { at ($1,$3) $ DPatBind $1 $3 } | '(' op ')' '=' expr { at ($1,$5) $ DPatBind (PVar $2) $5 } | var apats_indices '=' expr { at ($1,$4) $ mkIndexedDecl $1 $2 $4 } | apat pat_op apat '=' expr { at ($1,$5) $ DBind $ Bind { bName = $2 , bParams = [$1,$3] , bDef = at $5 (Located emptyRange (DExpr $5)) , bSignature = Nothing , bPragmas = [] , bMono = False , bInfix = True , bFixity = Nothing , bDoc = Nothing } } | 'type' name '=' type {% at ($1,$4) `fmap` mkTySyn $2 [] $4 } | 'type' name tysyn_params '=' type {% at ($1,$5) `fmap` mkTySyn $2 (reverse $3) $5 } | 'type' tysyn_param op tysyn_param '=' type {% at ($1,$6) `fmap` mkTySyn $3 [$2, $4] $6 } | 'type' 'constraint' name '=' type {% at ($2,$5) `fmap` mkPropSyn $3 [] $5 } | 'type' 'constraint' name tysyn_params '=' type {% at ($2,$6) `fmap` mkPropSyn $3 (reverse $4) $6 } | 'type' 'constraint' tysyn_param op tysyn_param '=' type {% at ($2,$7) `fmap` mkPropSyn $4 [$3, $5] $7 } | 'infixl' NUM ops {% mkFixity LeftAssoc $2 (reverse $3) } | 'infixr' NUM ops {% mkFixity RightAssoc $2 (reverse $3) } | 'infix' NUM ops {% mkFixity NonAssoc $2 (reverse $3) } | error {% expected "a declaration" } let_decl :: { Decl PName } : 'let' ipat '=' expr { at ($2,$4) $ DPatBind $2 $4 } | 'let' name apats_indices '=' expr { at ($2,$5) $ mkIndexedDecl $2 $3 $5 } newtype :: { Newtype PName } : 'newtype' qname '=' newtype_body { Newtype { nName = $2, nParams = [], nBody = $4 } } | 'newtype' qname tysyn_params '=' newtype_body { Newtype { nName = $2, nParams = $3, nBody = $5 } } newtype_body :: { [Named (Type PName)] } : '{' '}' { [] } | '{' field_types '}' { $2 } vars_comma :: { [ LPName ] } : var { [ $1] } | vars_comma ',' var { $3 : $1 } var :: { LPName } : name { $1 } | '(' op ')' { $2 } apats :: { [Pattern PName] } : apat { [$1] } | apats apat { $2 : $1 } indices :: { [Pattern PName] } : '@' indices1 { $2 } | {- empty -} { [] } indices1 :: { [Pattern PName] } : apat { [$1] } | indices1 '@' apat { $3 : $1 } apats_indices :: { ([Pattern PName], [Pattern PName]) } : apats indices { ($1, $2) } | '@' indices1 { ([], $2) } opt_apats_indices :: { ([Pattern PName], [Pattern PName]) } : {- empty -} { ([],[]) } | apats_indices { $1 } decls :: { [Decl PName] } : decl ';' { [$1] } | decls decl ';' { $2 : $1 } vdecls :: { [Decl PName] } : decl { [$1] } | vdecls 'v;' decl { $3 : $1 } | vdecls ';' decl { $3 : $1 } decls_layout :: { [Decl PName] } : 'v{' vdecls 'v}' { $2 } | 'v{' 'v}' { [] } repl :: { ReplInput PName } : expr { ExprInput $1 } | let_decl { LetInput $1 } | {- empty -} { EmptyInput } -------------------------------------------------------------------------------- -- Operators qop :: { LPName } : op { $1 } | QOP { let Token (Op (Other ns i)) _ = thing $1 in mkQual (mkModName ns) (mkInfix i) A.<$ $1 } op :: { LPName } : pat_op { $1 } | '#' { Located $1 $ mkUnqual $ mkInfix "#" } | '@' { Located $1 $ mkUnqual $ mkInfix "@" } pat_op :: { LPName } : other_op { $1 } -- special cases for operators that are re-used elsewhere | '*' { Located $1 $ mkUnqual $ mkInfix "*" } | '+' { Located $1 $ mkUnqual $ mkInfix "+" } | '-' { Located $1 $ mkUnqual $ mkInfix "-" } | '~' { Located $1 $ mkUnqual $ mkInfix "~" } | '^^' { Located $1 $ mkUnqual $ mkInfix "^^" } other_op :: { LPName } : OP { let Token (Op (Other [] str)) _ = thing $1 in mkUnqual (mkInfix str) A.<$ $1 } ops :: { [LPName] } : op { [$1] } | ops ',' op { $3 : $1 } -------------------------------------------------------------------------------- -- Expressions expr :: { Expr PName } : exprNoWhere { $1 } | expr 'where' whereClause { at ($1,$3) (EWhere $1 (thing $3)) } -- | An expression without a `where` clause exprNoWhere :: { Expr PName } : simpleExpr qop longRHS { at ($1,$3) (binOp $1 $2 $3) } | longRHS { $1 } | typedExpr { $1 } whereClause :: { Located [Decl PName] } : '{' '}' { Located (rComb $1 $2) [] } | '{' decls '}' { Located (rComb $1 $3) (reverse $2) } | 'v{' 'v}' { Located (rComb $1 $2) [] } | 'v{' vdecls 'v}' { let l2 = fromMaybe $3 (getLoc $2) in Located (rComb $1 l2) (reverse $2) } -- An expression with a type annotation typedExpr :: { Expr PName } : simpleExpr ':' type { at ($1,$3) (ETyped $1 $3) } -- A possibly infix expression (no where, no long application, no type annot) simpleExpr :: { Expr PName } : simpleExpr qop simpleRHS { at ($1,$3) (binOp $1 $2 $3) } | simpleRHS { $1 } -- An expression without an obvious end marker longExpr :: { Expr PName } : 'if' ifBranches 'else' exprNoWhere { at ($1,$4) $ mkIf (reverse $2) $4 } | '\\' apats '->' exprNoWhere { at ($1,$4) $ EFun (reverse $2) $4 } ifBranches :: { [(Expr PName, Expr PName)] } : ifBranch { [$1] } | ifBranches '|' ifBranch { $3 : $1 } ifBranch :: { (Expr PName, Expr PName) } : expr 'then' expr { ($1, $3) } simpleRHS :: { Expr PName } : '-' simpleApp { at ($1,$2) (ENeg $2) } | '~' simpleApp { at ($1,$2) (EComplement $2) } | simpleApp { $1 } longRHS :: { Expr PName } : '-' longApp { at ($1,$2) (ENeg $2) } | '~' longApp { at ($1,$2) (EComplement $2) } | longApp { $1 } -- Prefix application expression, ends with an atom. simpleApp :: { Expr PName } : aexprs { mkEApp $1 } -- Prefix application expression, may end with a long expression longApp :: { Expr PName } : simpleApp longExpr { at ($1,$2) (EApp $1 $2) } | longExpr { $1 } | simpleApp { $1 } aexprs :: { [Expr PName] } : aexpr { [$1] } | aexprs aexpr { $2 : $1 } -- Expression atom (needs no parens) aexpr :: { Expr PName } : no_sel_aexpr { $1 } | sel_expr { $1 } no_sel_aexpr :: { Expr PName } : qname { at $1 $ EVar (thing $1) } | NUM { at $1 $ numLit (thing $1) } | FRAC { at $1 $ fracLit (thing $1) } | STRLIT { at $1 $ ELit $ ECString $ getStr $1 } | CHARLIT { at $1 $ ELit $ ECChar $ getChr $1 } | '_' { at $1 $ EVar $ mkUnqual $ mkIdent "_" } | '(' expr ')' { at ($1,$3) $ EParens $2 } | '(' tuple_exprs ')' { at ($1,$3) $ ETuple (reverse $2) } | '(' ')' { at ($1,$2) $ ETuple [] } | '{' '}' {% mkRecord (rComb $1 $2) ERecord [] } | '{' rec_expr '}' {% case $2 of { Left upd -> pure $ at ($1,$3) upd; Right fs -> mkRecord (rComb $1 $3) ERecord fs; }} | '[' ']' { at ($1,$2) $ EList [] } | '[' list_expr ']' { at ($1,$3) $2 } | '`' tick_ty { at ($1,$2) $ ETypeVal $2 } | '(' qop ')' { at ($1,$3) $ EVar $ thing $2 } | '<|' '|>' {% mkPoly (rComb $1 $2) [] } | '<|' poly_terms '|>' {% mkPoly (rComb $1 $3) $2 } sel_expr :: { Expr PName } : no_sel_aexpr selector { at ($1,$2) $ ESel $1 (thing $2) } | sel_expr selector { at ($1,$2) $ ESel $1 (thing $2) } selector :: { Located Selector } : SELECTOR { mkSelector `fmap` $1 } poly_terms :: { [(Bool, Integer)] } : poly_term { [$1] } | poly_terms '+' poly_term { $3 : $1 } poly_term :: { (Bool, Integer) } : NUM {% polyTerm (srcRange $1) (getNum $1) 0 } | 'x' {% polyTerm $1 1 1 } | 'x' '^^' NUM {% polyTerm (rComb $1 (srcRange $3)) 1 (getNum $3) } tuple_exprs :: { [Expr PName] } : expr ',' expr { [ $3, $1] } | tuple_exprs ',' expr { $3 : $1 } rec_expr :: { Either (Expr PName) [Named (Expr PName)] } : aexpr '|' field_exprs { Left (EUpd (Just $1) (reverse $3)) } | '_' '|' field_exprs { Left (EUpd Nothing (reverse $3)) } | field_exprs {% Right `fmap` mapM ufToNamed $1 } field_exprs :: { [UpdField PName] } : field_expr { [$1] } | field_exprs ',' field_expr { $3 : $1 } field_expr :: { UpdField PName } : field_path opt_apats_indices field_how expr { UpdField $3 $1 (mkIndexedExpr $2 $4) } field_path :: { [Located Selector] } : aexpr {% exprToFieldPath $1 } field_how :: { UpdHow } : '=' { UpdSet } | '->' { UpdFun } list_expr :: { Expr PName } : expr '|' list_alts { EComp $1 (reverse $3) } | expr { EList [$1] } | tuple_exprs { EList (reverse $1) } {- The `expr` in the four productions that follow should be `type`. This, however, leads to ambiguity because the syntax for types and expressions overlaps and we need more than 1 look-ahead to resolve what is being parsed. For this reason, we use `expr` temporarily and then convert it to the corresponding type in the AST. -} | expr '..' expr {% eFromTo $2 $1 Nothing $3 } | expr ',' expr '..' expr {% eFromTo $4 $1 (Just $3) $5 } | expr '...' { EInfFrom $1 Nothing } | expr ',' expr '...' { EInfFrom $1 (Just $3) } list_alts :: { [[Match PName]] } : matches { [ reverse $1 ] } | list_alts '|' matches { reverse $3 : $1 } matches :: { [Match PName] } : match { [$1] } | matches ',' match { $3 : $1 } match :: { Match PName } : pat '<-' expr { Match $1 $3 } -------------------------------------------------------------------------------- pat :: { Pattern PName } : ipat ':' type { at ($1,$3) $ PTyped $1 $3 } | ipat { $1 } ipat :: { Pattern PName } : ipat '#' ipat { at ($1,$3) $ PSplit $1 $3 } | apat { $1 } apat :: { Pattern PName } : name { PVar $1 } | '_' { at $1 $ PWild } | '(' ')' { at ($1,$2) $ PTuple [] } | '(' pat ')' { at ($1,$3) $2 } | '(' tuple_pats ')' { at ($1,$3) $ PTuple (reverse $2) } | '[' ']' { at ($1,$2) $ PList [] } | '[' pat ']' { at ($1,$3) $ PList [$2] } | '[' tuple_pats ']' { at ($1,$3) $ PList (reverse $2) } | '{' '}' {% mkRecord (rComb $1 $2) PRecord [] } | '{' field_pats '}' {% mkRecord (rComb $1 $3) PRecord $2 } tuple_pats :: { [Pattern PName] } : pat ',' pat { [$3, $1] } | tuple_pats ',' pat { $3 : $1 } field_pat :: { Named (Pattern PName) } : ident '=' pat { Named { name = $1, value = $3 } } field_pats :: { [Named (Pattern PName)] } : field_pat { [$1] } | field_pats ',' field_pat { $3 : $1 } -------------------------------------------------------------------------------- schema :: { Schema PName } : type { at $1 $ mkSchema [] [] $1 } | schema_vars type { at ($1,$2) $ mkSchema (thing $1) [] $2 } | schema_quals type { at ($1,$2) $ mkSchema [] (thing $1) $2 } | schema_vars schema_quals type { at ($1,$3) $ mkSchema (thing $1) (thing $2) $3 } schema_vars :: { Located [TParam PName] } : '{' '}' { Located (rComb $1 $2) [] } | '{' schema_params '}' { Located (rComb $1 $3) (reverse $2) } schema_quals :: { Located [Prop PName] } : schema_quals schema_qual { at ($1,$2) $ fmap (++ thing $2) $1 } | schema_qual { $1 } schema_qual :: { Located [Prop PName] } : type '=>' {% fmap (\x -> at (x,$2) x) (mkProp $1) } kind :: { Located Kind } : '#' { Located $1 KNum } | '*' { Located $1 KType } | 'Prop' { Located $1 KProp } | kind '->' kind { combLoc KFun $1 $3 } schema_param :: { TParam PName } : ident {% mkTParam $1 Nothing } | ident ':' kind {% mkTParam (at ($1,$3) $1) (Just (thing $3)) } schema_params :: { [TParam PName] } : schema_param { [$1] } | schema_params ',' schema_param { $3 : $1 } tysyn_param :: { TParam PName } : ident {% mkTParam $1 Nothing } | '(' ident ':' kind ')' {% mkTParam (at ($1,$5) $2) (Just (thing $4)) } tysyn_params :: { [TParam PName] } : tysyn_param { [$1] } | tysyn_params tysyn_param { $2 : $1 } type :: { Type PName } : infix_type '->' type { at ($1,$3) $ TFun $1 $3 } | infix_type { $1 } infix_type :: { Type PName } : infix_type op app_type { at ($1,$3) $ TInfix $1 $2 defaultFixity $3 } | app_type { $1 } app_type :: { Type PName } : dimensions atype { at ($1,$2) $ foldr TSeq $2 (reverse (thing $1)) } | qname atypes { at ($1,head $2) $ TUser (thing $1) (reverse $2) } | atype { $1 } atype :: { Type PName } : qname { at $1 $ TUser (thing $1) [] } | '(' qop ')' { at $1 $ TUser (thing $2) [] } | NUM { at $1 $ TNum (getNum $1) } | CHARLIT { at $1 $ TChar (getChr $1) } | '[' type ']' { at ($1,$3) $ TSeq $2 TBit } | '(' type ')' { at ($1,$3) $ TParens $2 } | '(' ')' { at ($1,$2) $ TTuple [] } | '(' tuple_types ')' { at ($1,$3) $ TTuple (reverse $2) } | '{' '}' {% mkRecord (rComb $1 $2) TRecord [] } | '{' field_types '}' {% mkRecord (rComb $1 $3) TRecord $2 } | '_' { at $1 TWild } atypes :: { [ Type PName ] } : atype { [ $1 ] } | atypes atype { $2 : $1 } dimensions :: { Located [Type PName] } : '[' type ']' { Located (rComb $1 $3) [ $2 ] } | dimensions '[' type ']' { at ($1,$4) (fmap ($3 :) $1) } tuple_types :: { [Type PName] } : type ',' type { [ $3, $1] } | tuple_types ',' type { $3 : $1 } field_type :: { Named (Type PName) } : ident ':' type { Named { name = $1, value = $3 } } field_types :: { [Named (Type PName)] } : field_type { [$1] } | field_types ',' field_type { $3 : $1 } ident :: { Located Ident } : IDENT { let Token (Ident _ str) _ = thing $1 in $1 { thing = mkIdent str } } | 'x' { Located { srcRange = $1, thing = mkIdent "x" } } | 'private' { Located { srcRange = $1, thing = mkIdent "private" } } | 'as' { Located { srcRange = $1, thing = mkIdent "as" } } | 'hiding' { Located { srcRange = $1, thing = mkIdent "hiding" } } name :: { LPName } : ident { fmap mkUnqual $1 } smodName :: { Located ModName } : ident { fmap (mkModName . (:[]) . identText) $1 } | QIDENT { let Token (Ident ns i) _ = thing $1 in mkModName (ns ++ [i]) A.<$ $1 } modName :: { Located ModName } : smodName { $1 } | '`' smodName { fmap paramInstModName $2 } qname :: { Located PName } : name { $1 } | QIDENT { let Token (Ident ns i) _ = thing $1 in mkQual (mkModName ns) (mkIdent i) A.<$ $1 } help_name :: { Located PName } : qname { $1 } | qop { $1 } | '(' qop ')' { $2 } {- The types that can come after a back-tick: either a type demotion, or an explicit type application. -} tick_ty :: { Type PName } : qname { at $1 $ TUser (thing $1) [] } | NUM { at $1 $ TNum (getNum $1) } | '(' type ')' {% validDemotedType (rComb $1 $3) $2 } | '{' '}' { at ($1,$2) (TTyApp []) } | '{' field_ty_vals '}' { at ($1,$3) (TTyApp (reverse $2)) } | '{' type '}' { anonTyApp (getLoc ($1,$3)) [$2] } | '{' tuple_types '}' { anonTyApp (getLoc ($1,$3)) (reverse $2) } -- This for explicit type applications (e.g., f ` { front = 3 }) field_ty_val :: { Named (Type PName) } : ident '=' type { Named { name = $1, value = $3 } } field_ty_vals :: { [Named (Type PName)] } : field_ty_val { [$1] } | field_ty_vals ',' field_ty_val { $3 : $1 } { parseModName :: String -> Maybe ModName parseModName txt = case parseString defaultConfig { cfgModuleScope = False } modName txt of Right a -> Just (thing a) Left _ -> Nothing parseHelpName :: String -> Maybe PName parseHelpName txt = case parseString defaultConfig { cfgModuleScope = False } helpName txt of Right a -> Just (thing a) Left _ -> Nothing addImplicitIncludes :: Config -> Program PName -> Program PName addImplicitIncludes cfg (Program ds) = Program $ map path (cfgAutoInclude cfg) ++ ds where path p = Include Located { srcRange = rng, thing = p } rng = Range { source = cfgSource cfg, from = start, to = start } parseProgramWith :: Config -> Text -> Either ParseError (Program PName) parseProgramWith cfg s = case res s of Left err -> Left err Right a -> Right (addImplicitIncludes cfg a) where res = parse cfg $ case cfgLayout cfg of Layout -> programLayout NoLayout -> program parseModule :: Config -> Text -> Either ParseError (Module PName) parseModule cfg = parse cfg { cfgModuleScope = True } vmodule parseProgram :: Layout -> Text -> Either ParseError (Program PName) parseProgram l = parseProgramWith defaultConfig { cfgLayout = l } parseExprWith :: Config -> Text -> Either ParseError (Expr PName) parseExprWith cfg = parse cfg { cfgModuleScope = False } expr parseExpr :: Text -> Either ParseError (Expr PName) parseExpr = parseExprWith defaultConfig parseDeclWith :: Config -> Text -> Either ParseError (Decl PName) parseDeclWith cfg = parse cfg { cfgModuleScope = False } decl parseDecl :: Text -> Either ParseError (Decl PName) parseDecl = parseDeclWith defaultConfig parseDeclsWith :: Config -> Text -> Either ParseError [Decl PName] parseDeclsWith cfg = parse cfg { cfgModuleScope = ms } decls' where (ms, decls') = case cfgLayout cfg of Layout -> (True, declsLayout) NoLayout -> (False, decls) parseDecls :: Text -> Either ParseError [Decl PName] parseDecls = parseDeclsWith defaultConfig parseLetDeclWith :: Config -> Text -> Either ParseError (Decl PName) parseLetDeclWith cfg = parse cfg { cfgModuleScope = False } letDecl parseLetDecl :: Text -> Either ParseError (Decl PName) parseLetDecl = parseLetDeclWith defaultConfig parseReplWith :: Config -> Text -> Either ParseError (ReplInput PName) parseReplWith cfg = parse cfg { cfgModuleScope = False } repl parseRepl :: Text -> Either ParseError (ReplInput PName) parseRepl = parseReplWith defaultConfig parseSchemaWith :: Config -> Text -> Either ParseError (Schema PName) parseSchemaWith cfg = parse cfg { cfgModuleScope = False } schema parseSchema :: Text -> Either ParseError (Schema PName) parseSchema = parseSchemaWith defaultConfig -- vim: ft=haskell }