cryptol-2.2.0: src/Cryptol/Parser.y
{
{-# LANGUAGE Trustworthy #-}
module Cryptol.Parser
( parseModule
, parseProgram, parseProgramWith
, parseExpr, parseExprWith
, parseDecl, parseDeclWith
, parseDecls, parseDeclsWith
, parseLetDecl, parseLetDeclWith
, parseRepl, parseReplWith
, parseSchema, parseSchemaWith
, parseModName
, ParseError(..), ppError
, Layout(..)
, Config(..), defaultConfig
, guessPreProc, PreProc(..)
) where
import Data.Maybe(fromMaybe)
import Control.Monad(liftM2,msum)
import Cryptol.Prims.Syntax
import Cryptol.Parser.AST
import Cryptol.Parser.Position
import Cryptol.Parser.LexerUtils
import Cryptol.Parser.ParserUtils
import Cryptol.Parser.Unlit(PreProc(..), guessPreProc)
import Paths_cryptol
}
%token
NUM { $$@(Located _ (Token (Num {}) _))}
IDENT { $$@(Located _ (Token (Ident {}) _))}
STRLIT { $$@(Located _ (Token (StrLit {}) _))}
CHARLIT { $$@(Located _ (Token (ChrLit {}) _))}
'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) _)}
'property' { Located $$ (Token (KW KW_property) _)}
'False' { Located $$ (Token (KW KW_False ) _)}
'True' { Located $$ (Token (KW KW_True ) _)}
'Arith' { Located $$ (Token (KW KW_Arith ) _)}
'Bit' { Located $$ (Token (KW KW_Bit ) _)}
'Cmp' { Located $$ (Token (KW KW_Cmp ) _)}
'error' { Located $$ (Token (KW KW_error ) _)}
'fin' { Located $$ (Token (KW KW_fin ) _)}
'inf' { Located $$ (Token (KW KW_inf ) _)}
'lg2' { Located $$ (Token (KW KW_lg2 ) _)}
'lengthFromThen' { Located $$ (Token (KW KW_lengthFromThen) _)}
'lengthFromThenTo' { Located $$ (Token (KW KW_lengthFromThenTo) _)}
'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 ) _)}
'min' { Located $$ (Token (KW KW_min ) _)}
'max' { Located $$ (Token (KW KW_max ) _)}
'zero' { Located $$ (Token (KW KW_zero ) _)}
'join' { Located $$ (Token (KW KW_join ) _)}
'reverse' { Located $$ (Token (KW KW_reverse) _)}
'split' { Located $$ (Token (KW KW_split ) _)}
'splitAt' { Located $$ (Token (KW KW_splitAt) _)}
'transpose' { Located $$ (Token (KW KW_transpose) _)}
'x' { Located $$ (Token (KW KW_x) _)}
'pmult' { Located $$ (Token (KW KW_pmult) _)}
'pmod' { Located $$ (Token (KW KW_pmod) _)}
'pdiv' { Located $$ (Token (KW KW_pdiv) _)}
'random' { Located $$ (Token (KW KW_random) _)}
'[' { 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 ColonColon) _)}
'->' { 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 Minus ) _)}
'*' { Located $$ (Token (Op Mul ) _)}
'/' { Located $$ (Token (Op Div ) _)}
'^^' { Located $$ (Token (Op Exp ) _)}
'%' { Located $$ (Token (Op Mod ) _)}
'^' { Located $$ (Token (Op Xor ) _)}
'||' { Located $$ (Token (Op Disj ) _)}
'&&' { Located $$ (Token (Op Conj ) _)}
'!=' { Located $$ (Token (Op NotEqual ) _)}
'==' { Located $$ (Token (Op Equal ) _)}
'!==' { Located $$ (Token (Op NotEqualFun ) _)}
'===' { Located $$ (Token (Op EqualFun ) _)}
'>' { Located $$ (Token (Op GreaterThan ) _)}
'<' { Located $$ (Token (Op LessThan ) _)}
'<=' { Located $$ (Token (Op LEQ ) _)}
'>=' { Located $$ (Token (Op GEQ ) _)}
'>>' { Located $$ (Token (Op ShiftR ) _)}
'<<' { Located $$ (Token (Op ShiftL ) _)}
'>>>' { Located $$ (Token (Op RotR ) _)}
'<<<' { Located $$ (Token (Op RotL ) _)}
'~' { Located $$ (Token (Op Complement ) _)}
'@' { Located $$ (Token (Op At ) _)}
'@@' { Located $$ (Token (Op AtAt ) _)}
'!' { Located $$ (Token (Op Bang ) _)}
'!!' { Located $$ (Token (Op BangBang ) _)}
'#' { Located $$ (Token (Op Hash ) _)}
%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
%tokentype { Located Token }
%monad { ParseM }
%lexer { lexerP } { Located _ (Token EOF _) }
{- If you add additional operators, please update the corresponding
tables in the pretty printer. -}
%nonassoc '=>'
%right '->'
%left 'where'
%nonassoc 'then' 'else'
%nonassoc ':'
%left '||'
%left '&&'
%nonassoc '==' '!=' '===' '!=='
%nonassoc '<' '>' '<=' '>='
%left '^'
%right '#'
%left '<<' '>>' '<<<' '>>>'
%left '+' '-'
%left '*' '/' '%'
%right '^^'
%left '@' '@@' '!' '!!'
%right NEG '~'
%%
vmodule :: { Module }
: 'module' modName 'where' 'v{' vmod_body 'v}'
{ let (is,ts) = $5 in Module $2 is ts }
| 'v{' vmod_body 'v}'
{ let { (is,ts) = $2
-- XXX make a location from is and ts
; modName = Located { srcRange = emptyRange
, thing = ModName ["Main"]
}
} in Module modName is ts }
vmod_body :: { ([Located Import], [TopDecl]) }
: 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 :: { [LName] }
: name_list ',' name { $3 : $1 }
| name { [$1] }
| {- empty -} { [] }
mbHiding :: { [Name] -> ImportSpec }
: 'hiding' { Hiding }
| {- empty -} { Only }
program :: { Program }
: top_decls { Program (reverse $1) }
| {- empty -} { Program [] }
program_layout :: { Program }
: 'v{' vtop_decls 'v}' { Program (reverse $2) }
| 'v{''v}' { Program [] }
top_decls :: { [TopDecl] }
: top_decl ';' { [$1] }
| top_decls top_decl ';' { $2 : $1 }
vtop_decls :: { [TopDecl] }
: vtop_decl { $1 }
| vtop_decls 'v;' vtop_decl { $3 ++ $1 }
| vtop_decls ';' vtop_decl { $3 ++ $1 }
vtop_decl :: { [TopDecl] }
: decl { [exportDecl Public $1] }
| 'private' 'v{' vtop_decls 'v}' { changeExport Private (reverse $3) }
| 'include' STRLIT {% (return . Include) `fmap` fromStrLit $2 }
| 'property' name apats '=' expr { [exportDecl Public (mkProperty $2 $3 $5)]}
| 'property' name '=' expr { [exportDecl Public (mkProperty $2 [] $4)]}
| newtype { [exportNewtype Public $1] }
top_decl :: { TopDecl }
: decl { Decl (TopLevel {tlExport = Public, tlValue = $1}) }
| 'include' STRLIT {% Include `fmap` fromStrLit $2 }
decl :: { Decl }
: vars_comma ':' schema { at (head $1,$3) $ DSignature (map (fmap mkUnqual) (reverse $1)) $3 }
| apat '=' expr { at ($1,$3) $ DPatBind $1 $3 }
| name apats '=' expr { at ($1,$4) $
DBind $ Bind { bName = fmap mkUnqual $1
, bParams = reverse $2
, bDef = $4
, bSignature = Nothing
, bPragmas = []
, bMono = False
} }
| 'type' name '=' type {% at ($1,$4) `fmap` mkTySyn $2 [] $4 }
| 'type' name tysyn_params '=' type
{% at ($1,$5) `fmap` mkTySyn $2 (reverse $3) $5 }
let_decl :: { Decl }
: 'let' apat '=' expr { at ($2,$4) $ DPatBind $2 $4 }
| 'let' name apats '=' expr { at ($2,$5) $
DBind $ Bind { bName = fmap mkUnqual $2
, bParams = reverse $3
, bDef = $5
, bSignature = Nothing
, bPragmas = []
, bMono = False
} }
newtype :: { Newtype }
: '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] }
: '{' '}' { [] }
| '{' field_types '}' { $2 }
vars_comma :: { [ LName ] }
: name { [ $1] }
| vars_comma ',' name { $3 : $1 }
apats :: { [Pattern] }
: apat { [$1] }
| apats apat { $2 : $1 }
decls :: { [Decl] }
: decl ';' { [$1] }
| decls decl ';' { $2 : $1 }
vdecls :: { [Decl] }
: decl { [$1] }
| vdecls 'v;' decl { $3 : $1 }
| vdecls ';' decl { $3 : $1 }
decls_layout :: { [Decl] }
: 'v{' vdecls 'v}' { $2 }
| 'v{' 'v}' { [] }
repl :: { ReplInput }
: expr { ExprInput $1 }
| let_decl { LetInput $1 }
--------------------------------------------------------------------------------
-- if a then b else c : [10]
expr :: { Expr }
: iexpr { $1 }
| expr 'where' '{' '}' { at ($1,$4) $ EWhere $1 [] }
| expr 'where' '{' decls '}' { at ($1,$5) $ EWhere $1 (reverse $4) }
| expr 'where' 'v{' 'v}' { at ($1,$2) $ EWhere $1 [] }
| expr 'where' 'v{' vdecls 'v}' { at ($1,$4) $ EWhere $1 (reverse $4) }
ifBranches :: { [(Expr, Expr)] }
: ifBranch { [$1] }
| ifBranches '|' ifBranch { $3 : $1 }
ifBranch :: { (Expr, Expr) }
: expr 'then' expr { ($1, $3) }
iexpr :: { Expr }
: aexprs { mkEApp $1 }
| iexpr ':' type { at ($1,$3) $ ETyped $1 $3 }
| 'if' ifBranches 'else' iexpr { at ($1,$4) $ mkIf $2 $4 }
| '\\' apats '->' iexpr { at ($1,$4) $ EFun (reverse $2) $4 }
| iexpr '@' iexpr { binOp $1 (op ECAt $2) $3 }
| iexpr '@@' iexpr { binOp $1 (op ECAtRange $2) $3 }
| iexpr '!' iexpr { binOp $1 (op ECAtBack $2) $3 }
| iexpr '!!' iexpr { binOp $1 (op ECAtRangeBack $2) $3 }
| iexpr '#' iexpr { binOp $1 (op ECCat $2) $3 }
| iexpr '+' iexpr { binOp $1 (op ECPlus $2) $3 }
| iexpr '-' iexpr { binOp $1 (op ECMinus $2) $3 }
| iexpr '*' iexpr { binOp $1 (op ECMul $2) $3 }
| iexpr '/' iexpr { binOp $1 (op ECDiv $2) $3 }
| iexpr '%' iexpr { binOp $1 (op ECMod $2) $3 }
| iexpr '^^' iexpr { binOp $1 (op ECExp $2) $3 }
| iexpr '^' iexpr { binOp $1 (op ECXor $2) $3 }
| iexpr '||' iexpr { binOp $1 (op ECOr $2) $3 }
| iexpr '&&' iexpr { binOp $1 (op ECAnd $2) $3 }
| iexpr '==' iexpr { binOp $1 (op ECEq $2) $3 }
| iexpr '!=' iexpr { binOp $1 (op ECNotEq $2) $3 }
| iexpr '===' iexpr { binOp $1 (op ECFunEq $2) $3 }
| iexpr '!==' iexpr { binOp $1 (op ECFunNotEq $2) $3 }
| iexpr '>' iexpr { binOp $1 (op ECGt $2) $3 }
| iexpr '<' iexpr { binOp $1 (op ECLt $2) $3 }
| iexpr '<=' iexpr { binOp $1 (op ECLtEq $2) $3 }
| iexpr '>=' iexpr { binOp $1 (op ECGtEq $2) $3 }
| iexpr '<<' iexpr { binOp $1 (op ECShiftL $2) $3 }
| iexpr '>>' iexpr { binOp $1 (op ECShiftR $2) $3 }
| iexpr '<<<' iexpr { binOp $1 (op ECRotL $2) $3 }
| iexpr '>>>' iexpr { binOp $1 (op ECRotR $2) $3 }
| '-' iexpr %prec NEG { unOp (op ECNeg $1) $2 }
| '~' iexpr { unOp (op ECCompl $1) $2 }
aexprs :: { [Expr] }
: aexpr { [$1] }
| aexprs aexpr { $2 : $1 }
aexpr :: { Expr }
: qname { at $1 $ EVar (thing $1) }
| 'min' { at $1 $ ECon ECMin }
| 'max' { at $1 $ ECon ECMax }
| 'lg2' { at $1 $ ECon ECLg2 }
| 'zero' { at $1 $ ECon ECZero }
| 'join' { at $1 $ ECon ECJoin }
| 'split' { at $1 $ ECon ECSplit }
| 'splitAt' { at $1 $ ECon ECSplitAt }
| NUM { at $1 $ numLit (tokenType (thing $1)) }
| STRLIT { at $1 $ ELit $ ECString $ getStr $1 }
| CHARLIT { at $1 $ ELit $ ECNum (getNum $1) CharLit }
| 'False' { at $1 $ ECon ECFalse }
| 'True' { at $1 $ ECon ECTrue }
| 'error' { at $1 $ ECon ECError }
| 'reverse' { at $1 $ ECon ECReverse }
| 'transpose' { at $1 $ ECon ECTranspose }
| 'pmult' { at $1 $ ECon ECPMul }
| 'pdiv' { at $1 $ ECon ECPDiv }
| 'pmod' { at $1 $ ECon ECPMod }
| 'random' { at $1 $ ECon ECRandom }
| '(' expr ')' { at ($1,$3) $2 }
| '(' tuple_exprs ')' { at ($1,$3) $ ETuple (reverse $2) }
| '(' ')' { at ($1,$2) $ ETuple [] }
| '{' '}' { at ($1,$2) $ ERecord [] }
| '{' field_exprs '}' { at ($1,$3) $ ERecord (reverse $2) }
| '[' ']' { at ($1,$2) $ EList [] }
| '[' list_expr ']' { at ($1,$3) $2 }
| '`' tick_ty { at ($1,$2) $ ETypeVal $2 }
| aexpr '.' selector { at ($1,$3) $ ESel $1 (thing $3) }
| '(' '@' ')' { at ($1,$3) $ ECon ECAt }
| '(' '@@' ')' { at ($1,$3) $ ECon ECAtRange }
| '(' '!' ')' { at ($1,$3) $ ECon ECAtBack }
| '(' '!!' ')' { at ($1,$3) $ ECon ECAtRangeBack }
| '(' '#' ')' { at ($1,$3) $ ECon ECCat }
| '(' '+' ')' { at ($1,$3) $ ECon ECPlus }
| '(' '-' ')' { at ($1,$3) $ ECon ECMinus }
| '(' '*' ')' { at ($1,$3) $ ECon ECMul }
| '(' '/' ')' { at ($1,$3) $ ECon ECDiv }
| '(' '%' ')' { at ($1,$3) $ ECon ECMod }
| '(' '^^' ')' { at ($1,$3) $ ECon ECExp }
| '(' '^' ')' { at ($1,$3) $ ECon ECXor }
| '(' '||' ')' { at ($1,$3) $ ECon ECOr }
| '(' '&&' ')' { at ($1,$3) $ ECon ECAnd }
| '(' '==' ')' { at ($1,$3) $ ECon ECEq }
| '(' '!=' ')' { at ($1,$3) $ ECon ECNotEq }
| '(' '===' ')' { at ($1,$3) $ ECon ECFunEq }
| '(' '!==' ')' { at ($1,$3) $ ECon ECFunNotEq }
| '(' '>' ')' { at ($1,$3) $ ECon ECGt }
| '(' '<' ')' { at ($1,$3) $ ECon ECLt }
| '(' '<=' ')' { at ($1,$3) $ ECon ECLtEq }
| '(' '>=' ')' { at ($1,$3) $ ECon ECGtEq }
| '(' '<<' ')' { at ($1,$3) $ ECon ECShiftL }
| '(' '>>' ')' { at ($1,$3) $ ECon ECShiftR }
| '(' '<<<' ')' { at ($1,$3) $ ECon ECRotL }
| '(' '>>>' ')' { at ($1,$3) $ ECon ECRotR }
| '<|' '|>' {% mkPoly (rComb $1 $2) [] }
| '<|' poly_terms '|>' {% mkPoly (rComb $1 $3) $2 }
-- | error {%^ customError "expr" }
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) }
selector :: { Located Selector }
: name { fmap (`RecordSel` Nothing) $1 }
| NUM {% mkTupleSel (srcRange $1) (getNum $1) }
tuple_exprs :: { [Expr] }
: expr ',' expr { [ $3, $1] }
| tuple_exprs ',' expr { $3 : $1 }
field_expr :: { Named Expr }
: name '=' expr { Named { name = $1, value = $3 } }
| name apats '=' expr { Named { name = $1, value = EFun (reverse $2) $4 } }
field_exprs :: { [Named Expr] }
: field_expr { [$1] }
| field_exprs ',' field_expr { $3 : $1 }
list_expr :: { Expr }
: 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 '..' {% eFromTo $2 $1 Nothing Nothing }
| expr '..' expr {% eFromTo $2 $1 Nothing (Just $3) }
| expr ',' expr '..' {% eFromTo $4 $1 (Just $3) Nothing }
| expr ',' expr '..' expr {% eFromTo $4 $1 (Just $3) (Just $5) }
| expr '...' { EInfFrom $1 Nothing }
| expr ',' expr '...' { EInfFrom $1 (Just $3) }
list_alts :: { [[Match]] }
: matches { [ reverse $1 ] }
| list_alts '|' matches { reverse $3 : $1 }
matches :: { [Match] }
: match { [$1] }
| matches ',' match { $3 : $1 }
match :: { Match }
: pat '<-' expr { Match $1 $3 }
--------------------------------------------------------------------------------
pat :: { Pattern }
: ipat ':' type { at ($1,$3) $ PTyped $1 $3 }
| ipat { $1 }
ipat
: ipat '#' ipat { at ($1,$3) $ PSplit $1 $3 }
| apat { $1 }
apat :: { Pattern }
: 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) }
| '{' '}' { at ($1,$2) $ PRecord [] }
| '{' field_pats '}' { at ($1,$3) $ PRecord (reverse $2) }
tuple_pats :: { [Pattern] }
: pat ',' pat { [$3, $1] }
| tuple_pats ',' pat { $3 : $1 }
field_pat :: { Named Pattern }
: name '=' pat { Named { name = $1, value = $3 } }
field_pats :: { [Named Pattern] }
: field_pat { [$1] }
| field_pats ',' field_pat { $3 : $1 }
--------------------------------------------------------------------------------
schema :: { Schema }
: 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] }
: '{' '}' { Located (rComb $1 $2) [] }
| '{' schema_params '}' { Located (rComb $1 $3) (reverse $2) }
schema_quals :: { Located [Prop] }
: '(' ')' '=>' { Located (rComb $1 $3) [] }
| prop '=>' { Located
(rComb (fromMaybe $2 (getLoc $1)) $2) [$1] }
| '(' props ')' '=>' { Located (rComb $1 $4) (reverse $2) }
kind :: { Located Kind }
: '#' { Located $1 KNum }
| '*' { Located $1 KType }
schema_param :: { TParam }
: name {% mkTParam $1 Nothing }
| name ':' kind {% mkTParam (at ($1,$3) $1) (Just (thing $3)) }
schema_params :: { [TParam] }
: schema_param { [$1] }
| schema_params ',' schema_param { $3 : $1 }
tysyn_param :: { TParam }
: name {% mkTParam $1 Nothing }
| '(' name ':' kind ')' {% mkTParam (at ($1,$5) $2) (Just (thing $4)) }
tysyn_params :: { [TParam] }
: tysyn_param { [$1] }
| tysyn_params tysyn_param { $2 : $1 }
prop :: { Prop }
: type '==' type { at ($1,$3) $ CEqual $1 $3 }
| type '<=' type { at ($1,$3) $ CGeq $3 $1 }
| type '>=' type { at ($1,$3) $ CGeq $1 $3 }
| 'fin' atype { at ($1,$2) $ CFin $2 }
| 'Arith' atype { at ($1,$2) $ CArith $2 }
| 'Cmp' atype { at ($1,$2) $ CCmp $2 }
props :: { [Prop] }
: prop { [$1] }
| props ',' prop { $3 : $1 }
type :: { Type }
: type '->' type { at ($1,$3) $ TFun $1 $3 }
| type '+' type { at ($1,$3) $ TApp TCAdd [$1, $3] }
| type '-' type { at ($1,$3) $ TApp TCSub [$1, $3] }
| type '*' type { at ($1,$3) $ TApp TCMul [$1, $3] }
| type '/' type { at ($1,$3) $ TApp TCDiv [$1, $3] }
| type '%' type { at ($1,$3) $ TApp TCMod [$1, $3] }
| type '^^' type { at ($1,$3) $ TApp TCExp [$1, $3] }
| app_type { $1 }
app_type :: { Type }
: 'lg2' atype { at ($1,$2) $ TApp TCLg2 [$2] }
| 'lengthFromThen' atype atype { at ($1,$3) $ TApp TCLenFromThen [$2,$3] }
| 'lengthFromThenTo' atype atype
atype { at ($1,$4) $ TApp TCLenFromThen [$2,$3,$4] }
| 'min' atype atype { at ($1,$3) $ TApp TCMin [$2,$3] }
| 'max' atype atype { at ($1,$3) $ TApp TCMax [$2,$3] }
| 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 }
: qname { at $1 $ TUser (thing $1) [] }
| 'Bit' { at $1 $ TBit }
| 'inf' { at $1 $ TInf }
| NUM { at $1 $ TNum (getNum $1) }
| CHARLIT { at $1 $ TChar (toEnum $ fromInteger
$ getNum $1) }
| '[' type ']' { at ($1,$3) $ TSeq $2 TBit }
| '(' type ')' { at ($1,$3) $2 }
| '(' ')' { at ($1,$2) $ TTuple [] }
| '(' tuple_types ')' { at ($1,$3) $ TTuple (reverse $2) }
| '{' '}' { at ($1,$2) $ TRecord [] }
| '{' field_types '}' { at ($1,$3) $ TRecord (reverse $2) }
| '_' { at $1 TWild }
atypes :: { [ Type ] }
: atype { [ $1 ] }
| atypes atype { $2 : $1 }
dimensions :: { Located [Type] }
: '[' type ']' { Located (rComb $1 $3) [ $2 ] }
| dimensions '[' type ']' { at ($1,$4) (fmap ($3 :) $1) }
tuple_types :: { [Type] }
: type ',' type { [ $3, $1] }
| tuple_types ',' type { $3 : $1 }
field_type :: { Named Type }
: name ':' type { Named { name = $1, value = $3 } }
field_types :: { [Named Type] }
: field_type { [$1] }
| field_types ',' field_type { $3 : $1 }
qname_parts :: { [LName] } -- Reversed!
: name { [$1] }
| qname_parts '::' name { $3 : $1 }
name :: { LName }
: IDENT { $1 { thing = getName $1 } }
| 'x' { Located { srcRange = $1, thing = Name "x" }}
| 'private' { Located { srcRange = $1, thing = Name "private" } }
| 'as' { Located { srcRange = $1, thing = Name "as" } }
| 'hiding' { Located { srcRange = $1, thing = Name "hiding" } }
modName :: { Located ModName }
: qname_parts { mkModName $1 }
qname :: { Located QName }
: qname_parts { mkQName $1 }
{- The types that can come after a back-tick: either a type demotion,
or an explicit type application. Explicit type applications are converted
to records, which cannot be demoted. -}
tick_ty :: { Type }
: qname { at $1 $ TUser (thing $1) [] }
| NUM { at $1 $ TNum (getNum $1) }
| '(' type ')' {% validDemotedType (rComb $1 $3) $2 }
| '{' '}' { at ($1,$2) (TRecord []) }
| '{' field_ty_vals '}' { at ($1,$3) (TRecord (reverse $2)) }
| '{' type '}' { anonRecord (getLoc ($1,$3)) [$2] }
| '{' tuple_types '}' { anonRecord (getLoc ($1,$3)) (reverse $2) }
-- This for explicit type applications (e.g., f ` { front = 3 })
field_ty_val :: { Named Type }
: name '=' type { Named { name = $1, value = $3 } }
field_ty_vals :: { [Named Type] }
: field_ty_val { [$1] }
| field_ty_vals ',' field_ty_val { $3 : $1 }
{
parseModName :: String -> Maybe ModName
parseModName txt =
case parse defaultConfig { cfgModuleScope = False } modName txt of
Right a -> Just (thing a)
Left _ -> Nothing
addImplicitIncludes :: Config -> Program -> Program
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 -> String -> Either ParseError Program
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 -> String -> Either ParseError Module
parseModule cfg = parse cfg { cfgModuleScope = True } vmodule
parseProgram :: Layout -> String -> Either ParseError Program
parseProgram l = parseProgramWith defaultConfig { cfgLayout = l }
parseExprWith :: Config -> String -> Either ParseError Expr
parseExprWith cfg = parse cfg { cfgModuleScope = False } expr
parseExpr :: String -> Either ParseError Expr
parseExpr = parseExprWith defaultConfig
parseDeclWith :: Config -> String -> Either ParseError Decl
parseDeclWith cfg = parse cfg { cfgModuleScope = False } decl
parseDecl :: String -> Either ParseError Decl
parseDecl = parseDeclWith defaultConfig
parseDeclsWith :: Config -> String -> Either ParseError [Decl]
parseDeclsWith cfg = parse cfg { cfgModuleScope = ms } decls'
where (ms, decls') = case cfgLayout cfg of
Layout -> (True, declsLayout)
NoLayout -> (False, decls)
parseDecls :: String -> Either ParseError [Decl]
parseDecls = parseDeclsWith defaultConfig
parseLetDeclWith :: Config -> String -> Either ParseError Decl
parseLetDeclWith cfg = parse cfg { cfgModuleScope = False } letDecl
parseLetDecl :: String -> Either ParseError Decl
parseLetDecl = parseLetDeclWith defaultConfig
parseReplWith :: Config -> String -> Either ParseError ReplInput
parseReplWith cfg = parse cfg { cfgModuleScope = False } repl
parseRepl :: String -> Either ParseError ReplInput
parseRepl = parseReplWith defaultConfig
parseSchemaWith :: Config -> String -> Either ParseError Schema
parseSchemaWith cfg = parse cfg { cfgModuleScope = False } schema
parseSchema :: String -> Either ParseError Schema
parseSchema = parseSchemaWith defaultConfig
-- vim: ft=haskell
}