mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
ffd7b27abd
Now you will get error messages like these:
example.gf:1:21:
Syntax error:
Unexpected token '}'.
Expected one of:
- '{'
- 'open'
- an identifier
844 lines
29 KiB
Plaintext
844 lines
29 KiB
Plaintext
-- -*- haskell -*-
|
|
{
|
|
{-# OPTIONS -fno-warn-overlapping-patterns #-}
|
|
module GF.Grammar.Parser
|
|
( P, runP, runPartial
|
|
, pModDef
|
|
, pModHeader
|
|
, pTerm
|
|
, pExp
|
|
, pTopDef
|
|
, pBNFCRules
|
|
, pEBNFRules
|
|
) where
|
|
|
|
import GF.Infra.Ident
|
|
import GF.Infra.Option
|
|
import GF.Data.Operations
|
|
import GF.Grammar.Predef
|
|
import GF.Grammar.Grammar
|
|
import GF.Grammar.BNFC
|
|
import GF.Grammar.EBNF
|
|
import GF.Grammar.Macros
|
|
import GF.Grammar.Lexer
|
|
import GF.Compile.Update (buildAnyTree)
|
|
import Data.List(intersperse)
|
|
import Data.Char(isAlphaNum)
|
|
import qualified Data.Map as Map
|
|
import PGF(mkCId)
|
|
|
|
}
|
|
|
|
%name pModDef ModDef
|
|
%name pTopDef TopDef
|
|
%partial pModHeader ModHeader
|
|
%partial pTerm Exp1
|
|
%name pExp Exp
|
|
%name pBNFCRules ListCFRule
|
|
%name pEBNFRules ListEBNFRule
|
|
|
|
%errorhandlertype explist
|
|
%error { happyError }
|
|
|
|
-- no lexer declaration
|
|
%monad { P } { >>= } { return }
|
|
%lexer { lexer } { T_EOF }
|
|
%tokentype { Token }
|
|
|
|
|
|
%token
|
|
'!' { T_exclmark }
|
|
'#' { T_patt }
|
|
'$' { T_int_label }
|
|
'(' { T_oparen }
|
|
')' { T_cparen }
|
|
'~' { T_tilde }
|
|
'*' { T_star }
|
|
'**' { T_starstar }
|
|
'+' { T_plus }
|
|
'++' { T_plusplus }
|
|
',' { T_comma }
|
|
'-' { T_minus }
|
|
'->' { T_rarrow }
|
|
'.' { T_dot }
|
|
'/' { T_alt }
|
|
':' { T_colon }
|
|
';' { T_semicolon }
|
|
'<' { T_less }
|
|
'=' { T_equal }
|
|
'=>' { T_big_rarrow}
|
|
'>' { T_great }
|
|
'?' { T_questmark }
|
|
'@' { T_at }
|
|
'[' { T_obrack }
|
|
']' { T_cbrack }
|
|
'{' { T_ocurly }
|
|
'}' { T_ccurly }
|
|
'\\' { T_lam }
|
|
'\\\\' { T_lamlam }
|
|
'_' { T_underscore}
|
|
'|' { T_bar }
|
|
'::=' { T_cfarrow }
|
|
'PType' { T_PType }
|
|
'Str' { T_Str }
|
|
'Strs' { T_Strs }
|
|
'Tok' { T_Tok }
|
|
'Type' { T_Type }
|
|
'abstract' { T_abstract }
|
|
'case' { T_case }
|
|
'cat' { T_cat }
|
|
'concrete' { T_concrete }
|
|
'data' { T_data }
|
|
'def' { T_def }
|
|
'flags' { T_flags }
|
|
'fun' { T_fun }
|
|
'in' { T_in }
|
|
'incomplete' { T_incomplete}
|
|
'instance' { T_instance }
|
|
'interface' { T_interface }
|
|
'let' { T_let }
|
|
'lin' { T_lin }
|
|
'lincat' { T_lincat }
|
|
'lindef' { T_lindef }
|
|
'linref' { T_linref }
|
|
'of' { T_of }
|
|
'open' { T_open }
|
|
'oper' { T_oper }
|
|
'param' { T_param }
|
|
'pattern' { T_pattern }
|
|
'pre' { T_pre }
|
|
'printname' { T_printname }
|
|
'resource' { T_resource }
|
|
'strs' { T_strs }
|
|
'table' { T_table }
|
|
'variants' { T_variants }
|
|
'where' { T_where }
|
|
'with' { T_with }
|
|
'coercions' { T_coercions }
|
|
'terminator' { T_terminator }
|
|
'separator' { T_separator }
|
|
'nonempty' { T_nonempty }
|
|
|
|
Integer { (T_Integer $$) }
|
|
Double { (T_Double $$) }
|
|
String { (T_String $$) }
|
|
Ident { (T_Ident $$) }
|
|
|
|
|
|
%%
|
|
|
|
ModDef :: { SourceModule }
|
|
ModDef
|
|
: ComplMod ModType '=' ModBody {%
|
|
do let mstat = $1
|
|
(mtype,id) = $2
|
|
(extends,with,content) = $4
|
|
(opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
|
|
jments <- mapM (checkInfoType mtype) jments
|
|
defs <- buildAnyTree id jments
|
|
return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs) }
|
|
|
|
ModHeader :: { SourceModule }
|
|
ModHeader
|
|
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
|
|
(mtype,id) = $2 ;
|
|
(extends,with,opens) = $4 }
|
|
in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
|
|
|
|
ComplMod :: { ModuleStatus }
|
|
ComplMod
|
|
: {- empty -} { MSComplete }
|
|
| 'incomplete' { MSIncomplete }
|
|
|
|
ModType :: { (ModuleType,ModuleName) }
|
|
ModType
|
|
: 'abstract' ModuleName { (MTAbstract, $2) }
|
|
| 'resource' ModuleName { (MTResource, $2) }
|
|
| 'interface' ModuleName { (MTInterface, $2) }
|
|
| 'concrete' ModuleName 'of' ModuleName { (MTConcrete $4, $2) }
|
|
| 'instance' ModuleName 'of' Included { (MTInstance $4, $2) }
|
|
|
|
ModHeaderBody :: { ( [(ModuleName,MInclude)]
|
|
, Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)])
|
|
, [OpenSpec]
|
|
) }
|
|
ModHeaderBody
|
|
: ListIncluded '**' Included 'with' ListInst '**' ModOpen { ($1, Just (fst $3,snd $3,$5), $7) }
|
|
| ListIncluded '**' Included 'with' ListInst { ($1, Just (fst $3,snd $3,$5), []) }
|
|
| ListIncluded '**' ModOpen { ($1, Nothing, $3) }
|
|
| ListIncluded { ($1, Nothing, []) }
|
|
| Included 'with' ListInst '**' ModOpen { ([], Just (fst $1,snd $1,$3), $5) }
|
|
| Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), []) }
|
|
| ModOpen { ([], Nothing, $1) }
|
|
|
|
ModOpen :: { [OpenSpec] }
|
|
ModOpen
|
|
: { [] }
|
|
| 'open' ListOpen { $2 }
|
|
|
|
ModBody :: { ( [(ModuleName,MInclude)]
|
|
, Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)])
|
|
, Maybe ([OpenSpec],[(Ident,Info)],Options)
|
|
) }
|
|
ModBody
|
|
: ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) }
|
|
| ListIncluded '**' Included 'with' ListInst { ($1, Just (fst $3,snd $3,$5), Nothing) }
|
|
| ListIncluded '**' ModContent { ($1, Nothing, Just $3) }
|
|
| ListIncluded { ($1, Nothing, Nothing) }
|
|
| Included 'with' ListInst '**' ModContent { ([], Just (fst $1,snd $1,$3), Just $5) }
|
|
| Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), Nothing) }
|
|
| ModContent { ([], Nothing, Just $1) }
|
|
| ModBody ';' { $1 }
|
|
|
|
ModContent :: { ([OpenSpec],[(Ident,Info)],Options) }
|
|
ModContent
|
|
: '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) }
|
|
| 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) }
|
|
|
|
ListTopDef :: { [Either [(Ident,Info)] Options] }
|
|
ListTopDef
|
|
: {- empty -} { [] }
|
|
| TopDef ListTopDef { $1 : $2 }
|
|
|
|
ListOpen :: { [OpenSpec] }
|
|
ListOpen
|
|
: Open { [$1] }
|
|
| Open ',' ListOpen { $1 : $3 }
|
|
|
|
Open :: { OpenSpec }
|
|
Open
|
|
: ModuleName { OSimple $1 }
|
|
| '(' ModuleName '=' ModuleName ')' { OQualif $2 $4 }
|
|
|
|
ListInst :: { [(ModuleName,ModuleName)] }
|
|
ListInst
|
|
: Inst { [$1] }
|
|
| Inst ',' ListInst { $1 : $3 }
|
|
|
|
Inst :: { (ModuleName,ModuleName) }
|
|
Inst
|
|
: '(' ModuleName '=' ModuleName ')' { ($2,$4) }
|
|
|
|
ListIncluded :: { [(ModuleName,MInclude)] }
|
|
ListIncluded
|
|
: Included { [$1] }
|
|
| Included ',' ListIncluded { $1 : $3 }
|
|
|
|
Included :: { (ModuleName,MInclude) }
|
|
Included
|
|
: ModuleName { ($1,MIAll ) }
|
|
| ModuleName '[' ListIdent ']' { ($1,MIOnly $3) }
|
|
| ModuleName '-' '[' ListIdent ']' { ($1,MIExcept $4) }
|
|
|
|
TopDef :: { Either [(Ident,Info)] Options }
|
|
TopDef
|
|
: 'cat' ListCatDef { Left $2 }
|
|
| 'fun' ListFunDef { Left $2 }
|
|
| 'def' ListDefDef { Left $2 }
|
|
| 'data' ListDataDef { Left $2 }
|
|
| 'param' ListParamDef { Left $2 }
|
|
| 'oper' ListOperDef { Left $2 }
|
|
| 'lincat' ListTermDef { Left [(f, CncCat (Just e) Nothing Nothing Nothing Nothing) | (f,e) <- $2] }
|
|
| 'lindef' ListTermDef { Left [(f, CncCat Nothing (Just e) Nothing Nothing Nothing) | (f,e) <- $2] }
|
|
| 'linref' ListTermDef { Left [(f, CncCat Nothing Nothing (Just e) Nothing Nothing) | (f,e) <- $2] }
|
|
| 'lin' ListLinDef { Left $2 }
|
|
| 'printname' 'cat' ListTermDef { Left [(f, CncCat Nothing Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
|
|
| 'printname' 'fun' ListTermDef { Left [(f, CncFun Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
|
|
| 'flags' ListFlagDef { Right $2 }
|
|
|
|
CatDef :: { [(Ident,Info)] }
|
|
CatDef
|
|
: Posn Ident ListDDecl Posn { [($2, AbsCat (Just (mkL $1 $4 $3)))] }
|
|
| Posn '[' Ident ListDDecl ']' Posn { listCatDef (mkL $1 $6 ($3,$4,0)) }
|
|
| Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef (mkL $1 $9 ($3,$4,fromIntegral $7)) }
|
|
|
|
FunDef :: { [(Ident,Info)] }
|
|
FunDef
|
|
: Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing (Just []) (Just True)) | fun <- $2] }
|
|
|
|
DefDef :: { [(Ident,Info)] }
|
|
DefDef
|
|
: Posn LhsNames '=' Exp Posn { [(f, AbsFun Nothing (Just 0) (Just [mkL $1 $5 ([],$4)]) Nothing) | f <- $2] }
|
|
| Posn LhsName ListPatt '=' Exp Posn { [($2,AbsFun Nothing (Just (length $3)) (Just [mkL $1 $6 ($3,$5)]) Nothing)] }
|
|
|
|
DataDef :: { [(Ident,Info)] }
|
|
DataDef
|
|
: Posn Ident '=' ListDataConstr Posn { ($2, AbsCat Nothing) :
|
|
[(fun, AbsFun Nothing Nothing Nothing (Just True)) | fun <- $4] }
|
|
| Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), AbsCat Nothing) :
|
|
[(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing (Just True)) | fun <- $2] }
|
|
|
|
ParamDef :: { [(Ident,Info)] }
|
|
ParamDef
|
|
: Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
|
|
[(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
|
|
| Posn LhsIdent Posn { [($2, ResParam Nothing Nothing)] }
|
|
|
|
OperDef :: { [(Ident,Info)] }
|
|
OperDef
|
|
: Posn LhsNames ':' Exp Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $5 $4)) Nothing ] }
|
|
| Posn LhsNames '=' Exp Posn { [(i, info) | i <- $2, info <- mkOverload Nothing (Just (mkL $1 $5 $4))] }
|
|
| Posn LhsName ListArg '=' Exp Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $6 (mkAbs $3 $5)))] }
|
|
| Posn LhsNames ':' Exp '=' Exp Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 $6))] }
|
|
|
|
LinDef :: { [(Ident,Info)] }
|
|
LinDef
|
|
: Posn LhsNames '=' Exp Posn { [(f, CncFun Nothing (Just (mkL $1 $5 $4)) Nothing Nothing) | f <- $2] }
|
|
| Posn LhsName ListArg '=' Exp Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing Nothing)] }
|
|
|
|
TermDef :: { [(Ident,L Term)] }
|
|
TermDef
|
|
: Posn LhsNames '=' Exp Posn { [(i,mkL $1 $5 $4) | i <- $2] }
|
|
|
|
FlagDef :: { Options }
|
|
FlagDef
|
|
: Posn Ident '=' Ident Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of
|
|
Ok x -> return x
|
|
Bad msg -> failLoc $1 msg }
|
|
| Posn Ident '=' Double Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ show $4] of
|
|
Ok x -> return x
|
|
Bad msg -> failLoc $1 msg }
|
|
|
|
ListDataConstr :: { [Ident] }
|
|
ListDataConstr
|
|
: Ident { [$1] }
|
|
| Ident '|' ListDataConstr { $1 : $3 }
|
|
|
|
ParConstr :: { L Param }
|
|
ParConstr
|
|
: Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) }
|
|
|
|
ListLinDef :: { [(Ident,Info)] }
|
|
ListLinDef
|
|
: LinDef ';' { $1 }
|
|
| LinDef ';' ListLinDef { $1 ++ $3 }
|
|
|
|
ListDefDef :: { [(Ident,Info)] }
|
|
ListDefDef
|
|
: DefDef ';' { $1 }
|
|
| DefDef ';' ListDefDef { $1 ++ $3 }
|
|
|
|
ListOperDef :: { [(Ident,Info)] }
|
|
ListOperDef
|
|
: OperDef ';' { $1 }
|
|
| OperDef ';' ListOperDef { $1 ++ $3 }
|
|
|
|
ListCatDef :: { [(Ident,Info)] }
|
|
ListCatDef
|
|
: CatDef ';' { $1 }
|
|
| CatDef ';' ListCatDef { $1 ++ $3 }
|
|
|
|
ListFunDef :: { [(Ident,Info)] }
|
|
ListFunDef
|
|
: FunDef ';' { $1 }
|
|
| FunDef ';' ListFunDef { $1 ++ $3 }
|
|
|
|
ListDataDef :: { [(Ident,Info)] }
|
|
ListDataDef
|
|
: DataDef ';' { $1 }
|
|
| DataDef ';' ListDataDef { $1 ++ $3 }
|
|
|
|
ListParamDef :: { [(Ident,Info)] }
|
|
ListParamDef
|
|
: ParamDef ';' { $1 }
|
|
| ParamDef ';' ListParamDef { $1 ++ $3 }
|
|
|
|
ListTermDef :: { [(Ident,L Term)] }
|
|
ListTermDef
|
|
: TermDef ';' { $1 }
|
|
| TermDef ';' ListTermDef { $1 ++ $3 }
|
|
|
|
ListFlagDef :: { Options }
|
|
ListFlagDef
|
|
: FlagDef ';' { $1 }
|
|
| FlagDef ';' ListFlagDef { addOptions $1 $3 }
|
|
|
|
ListParConstr :: { [L Param] }
|
|
ListParConstr
|
|
: ParConstr { [$1] }
|
|
| ParConstr '|' ListParConstr { $1 : $3 }
|
|
|
|
ListIdent :: { [Ident] }
|
|
ListIdent
|
|
: Ident { [$1] }
|
|
| Ident ',' ListIdent { $1 : $3 }
|
|
|
|
ListIdent2 :: { [Ident] }
|
|
ListIdent2
|
|
: Ident { [$1] }
|
|
| Ident ListIdent2 { $1 : $2 }
|
|
|
|
LhsIdent :: { Ident }
|
|
: Ident { $1 }
|
|
| Posn Sort {% failLoc $1 (showIdent $2++ " is a predefined constant, it can not be redefined") }
|
|
|
|
LhsName :: { Ident }
|
|
LhsName
|
|
: LhsIdent { $1 }
|
|
| '[' LhsIdent ']' { mkListId $2 }
|
|
|
|
LhsNames :: { [Ident] }
|
|
LhsNames
|
|
: LhsName { [$1] }
|
|
| LhsName ',' LhsNames { $1 : $3 }
|
|
|
|
LocDef :: { [(Ident, Maybe Type, Maybe Term)] }
|
|
LocDef
|
|
: ListIdent ':' Exp { [(lab,Just $3,Nothing) | lab <- $1] }
|
|
| ListIdent '=' Exp { [(lab,Nothing,Just $3) | lab <- $1] }
|
|
| ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] }
|
|
|
|
ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] }
|
|
ListLocDef
|
|
: {- empty -} { [] }
|
|
| LocDef { $1 }
|
|
| LocDef ';' ListLocDef { $1 ++ $3 }
|
|
|
|
Exp :: { Term }
|
|
Exp
|
|
: Exp1 '|' Exp { FV [$1,$3] }
|
|
| '\\' ListBind '->' Exp { mkAbs $2 $4 }
|
|
| '\\\\' ListBind '=>' Exp { mkCTable $2 $4 }
|
|
| Decl '->' Exp { mkProdSimple $1 $3 }
|
|
| Exp3 '=>' Exp { Table $1 $3 }
|
|
| 'let' '{' ListLocDef '}' 'in' Exp {%
|
|
do defs <- mapM tryLoc $3
|
|
return $ mkLet defs $6 }
|
|
| 'let' ListLocDef 'in' Exp {%
|
|
do defs <- mapM tryLoc $2
|
|
return $ mkLet defs $4 }
|
|
| Exp3 'where' '{' ListLocDef '}' {%
|
|
do defs <- mapM tryLoc $4
|
|
return $ mkLet defs $1 }
|
|
| 'in' Exp5 String { Example $2 $3 }
|
|
| Exp1 { $1 }
|
|
|
|
Exp1 :: { Term }
|
|
Exp1
|
|
: Exp2 '++' Exp1 { C $1 $3 }
|
|
| Exp2 { $1 }
|
|
|
|
Exp2 :: { Term }
|
|
Exp2
|
|
: Exp3 '+' Exp2 { Glue $1 $3 }
|
|
| Exp3 { $1 }
|
|
|
|
Exp3 :: { Term }
|
|
Exp3
|
|
: Exp3 '!' Exp4 { S $1 $3 }
|
|
| 'table' '{' ListCase '}' { T TRaw $3 }
|
|
| 'table' Exp6 '{' ListCase '}' { T (TTyped $2) $4 }
|
|
| 'table' Exp6 '[' ListExp ']' { V $2 $4 }
|
|
| Exp3 '*' Exp4 { case $1 of
|
|
RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)])
|
|
t -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)] }
|
|
| Exp3 '**' Exp4 { ExtR $1 $3 }
|
|
| Exp3 '**' '{' ListCase '}' { let v = identS "$vvv" in T TRaw ($4 ++ [(PV v, S $1 (Vr v))]) }
|
|
| Exp4 { $1 }
|
|
|
|
Exp4 :: { Term }
|
|
Exp4
|
|
: Exp4 Exp5 { App $1 $2 }
|
|
| Exp4 '{' Exp '}' { App $1 (ImplArg $3) }
|
|
| 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
|
|
Typed _ t -> TTyped t
|
|
_ -> TRaw
|
|
in S (T annot $5) $2 }
|
|
| 'variants' '{' ListExp '}' { FV $3 }
|
|
| 'pre' '{' ListCase '}' {% mkAlts $3 }
|
|
| 'pre' '{' String ';' ListAltern '}' { Alts (K $3) $5 }
|
|
| 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3) $5 }
|
|
| 'strs' '{' ListExp '}' { Strs $3 }
|
|
| '#' Patt3 { EPatt $2 }
|
|
| 'pattern' Exp5 { EPattType $2 }
|
|
| 'lincat' Ident Exp5 { ELincat $2 $3 }
|
|
| 'lin' Ident Exp5 { ELin $2 $3 }
|
|
| Exp5 { $1 }
|
|
|
|
Exp5 :: { Term }
|
|
Exp5
|
|
: Exp5 '.' Label { P $1 $3 }
|
|
| Exp6 { $1 }
|
|
|
|
Exp6 :: { Term }
|
|
Exp6
|
|
: Ident { Vr $1 }
|
|
| Sort { Sort $1 }
|
|
| String { K $1 }
|
|
| Integer { EInt $1 }
|
|
| Double { EFloat $1 }
|
|
| '?' { Meta 0 }
|
|
| '[' ']' { Empty }
|
|
| '[' Ident Exps ']' { foldl App (Vr (mkListId $2)) $3 }
|
|
| '[' String ']' { K $2 }
|
|
| '{' ListLocDef '}' {% mkR $2 }
|
|
| '<' ListTupleComp '>' { R (tuple2record $2) }
|
|
| '<' Exp ':' Exp '>' { Typed $2 $4 }
|
|
| '(' Exp ')' { $2 }
|
|
|
|
ListExp :: { [Term] }
|
|
ListExp
|
|
: {- empty -} { [] }
|
|
| Exp { [$1] }
|
|
| Exp ';' ListExp { $1 : $3 }
|
|
|
|
Exps :: { [Term] }
|
|
Exps
|
|
: {- empty -} { [] }
|
|
| Exp6 Exps { $1 : $2 }
|
|
|
|
Patt :: { Patt }
|
|
Patt
|
|
: Patt '|' Patt1 { PAlt $1 $3 }
|
|
| Patt '+' Patt1 { PSeq $1 $3 }
|
|
| Patt1 { $1 }
|
|
|
|
Patt1 :: { Patt }
|
|
Patt1
|
|
: Ident ListPatt { PC $1 $2 }
|
|
| ModuleName '.' Ident ListPatt { PP ($1,$3) $4 }
|
|
| Patt3 '*' { PRep $1 }
|
|
| Patt2 { $1 }
|
|
|
|
Patt2 :: { Patt }
|
|
Patt2
|
|
: Ident '@' Patt3 { PAs $1 $3 }
|
|
| '-' Patt3 { PNeg $2 }
|
|
| '~' Exp6 { PTilde $2 }
|
|
| Patt3 { $1 }
|
|
|
|
Patt3 :: { Patt }
|
|
Patt3
|
|
: '?' { PChar }
|
|
| '[' String ']' { PChars $2 }
|
|
| '#' Ident { PMacro $2 }
|
|
| '#' ModuleName '.' Ident { PM ($2,$4) }
|
|
| '_' { PW }
|
|
| Ident { PV $1 }
|
|
| ModuleName '.' Ident { PP ($1,$3) [] }
|
|
| Integer { PInt $1 }
|
|
| Double { PFloat $1 }
|
|
| String { PString $1 }
|
|
| '{' ListPattAss '}' { PR $2 }
|
|
| '<' ListPattTupleComp '>' { (PR . tuple2recordPatt) $2 }
|
|
| '(' Patt ')' { $2 }
|
|
|
|
PattAss :: { [(Label,Patt)] }
|
|
PattAss
|
|
: ListIdent '=' Patt { [(LIdent (ident2raw i),$3) | i <- $1] }
|
|
|
|
Label :: { Label }
|
|
Label
|
|
: Ident { LIdent (ident2raw $1) }
|
|
| '$' Integer { LVar (fromIntegral $2) }
|
|
|
|
Sort :: { Ident }
|
|
Sort
|
|
: 'Type' { cType }
|
|
| 'PType' { cPType }
|
|
| 'Tok' { cTok }
|
|
| 'Str' { cStr }
|
|
| 'Strs' { cStrs }
|
|
|
|
ListPattAss :: { [(Label,Patt)] }
|
|
ListPattAss
|
|
: {- empty -} { [] }
|
|
| PattAss { $1 }
|
|
| PattAss ';' ListPattAss { $1 ++ $3 }
|
|
|
|
ListPatt :: { [Patt] }
|
|
ListPatt
|
|
: PattArg { [$1] }
|
|
| PattArg ListPatt { $1 : $2 }
|
|
|
|
PattArg :: { Patt }
|
|
: Patt2 { $1 }
|
|
| '{' Patt '}' { PImplArg $2 }
|
|
|
|
Arg :: { [(BindType,Ident)] }
|
|
Arg
|
|
: Ident { [(Explicit,$1 )] }
|
|
| '_' { [(Explicit,identW)] }
|
|
| '{' ListIdent2 '}' { [(Implicit,v) | v <- $2] }
|
|
|
|
ListArg :: { [(BindType,Ident)] }
|
|
ListArg
|
|
: Arg { $1 }
|
|
| Arg ListArg { $1 ++ $2 }
|
|
|
|
Bind :: { [(BindType,Ident)] }
|
|
Bind
|
|
: Ident { [(Explicit,$1 )] }
|
|
| '_' { [(Explicit,identW)] }
|
|
| '{' ListIdent '}' { [(Implicit,v) | v <- $2] }
|
|
|
|
ListBind :: { [(BindType,Ident)] }
|
|
ListBind
|
|
: Bind { $1 }
|
|
| Bind ',' ListBind { $1 ++ $3 }
|
|
|
|
Decl :: { [Hypo] }
|
|
Decl
|
|
: '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] }
|
|
| Exp3 { [mkHypo $1] }
|
|
|
|
ListTupleComp :: { [Term] }
|
|
ListTupleComp
|
|
: {- empty -} { [] }
|
|
| Exp { [$1] }
|
|
| Exp ',' ListTupleComp { $1 : $3 }
|
|
|
|
ListPattTupleComp :: { [Patt] }
|
|
ListPattTupleComp
|
|
: {- empty -} { [] }
|
|
| Patt { [$1] }
|
|
| Patt ',' ListPattTupleComp { $1 : $3 }
|
|
|
|
Case :: { Case }
|
|
Case
|
|
: Patt '=>' Exp { ($1,$3) }
|
|
|
|
ListCase :: { [Case] }
|
|
ListCase
|
|
: Case { [$1] }
|
|
| Case ';' ListCase { $1 : $3 }
|
|
|
|
Altern :: { (Term,Term) }
|
|
Altern
|
|
: Exp '/' Exp { ($1,$3) }
|
|
|
|
ListAltern :: { [(Term,Term)] }
|
|
ListAltern
|
|
: Altern { [$1] }
|
|
| Altern ';' ListAltern { $1 : $3 }
|
|
|
|
DDecl :: { [Hypo] }
|
|
DDecl
|
|
: '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] }
|
|
| Exp6 { [mkHypo $1] }
|
|
|
|
ListDDecl :: { [Hypo] }
|
|
ListDDecl
|
|
: {- empty -} { [] }
|
|
| DDecl ListDDecl { $1 ++ $2 }
|
|
|
|
ListCFRule :: { [BNFCRule] }
|
|
ListCFRule
|
|
: CFRule { $1 }
|
|
| CFRule ListCFRule { $1 ++ $2 }
|
|
|
|
CFRule :: { [BNFCRule] }
|
|
CFRule
|
|
: Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])]
|
|
}
|
|
| Ident '::=' ListCFRHS ';' { let { cat = showIdent $1;
|
|
mkFun cat its =
|
|
case its of {
|
|
[] -> cat ++ "_";
|
|
_ -> concat $ intersperse "_" (cat : filter (not . null) (map clean its)) -- CLE style
|
|
};
|
|
clean sym =
|
|
case sym of {
|
|
Terminal c -> filter isAlphaNum c;
|
|
NonTerminal (t,_) -> t
|
|
}
|
|
} in map (\rhs -> BNFCRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3
|
|
}
|
|
| 'coercions' Ident Integer ';' { [BNFCCoercions (showIdent $2) $3]}
|
|
| 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] }
|
|
| 'separator' NonEmpty Ident String ';' { [BNFCSeparator $2 (showIdent $3) $4] }
|
|
|
|
ListCFRHS :: { [[BNFCSymbol]] }
|
|
ListCFRHS
|
|
: ListCFSymbol { [$1] }
|
|
| ListCFSymbol '|' ListCFRHS { $1 : $3 }
|
|
|
|
ListCFSymbol :: { [BNFCSymbol] }
|
|
ListCFSymbol
|
|
: {- empty -} { [] }
|
|
| CFSymbol ListCFSymbol { $1 : $2 }
|
|
|
|
CFSymbol :: { BNFCSymbol }
|
|
: String { Terminal $1 }
|
|
| Ident { NonTerminal (showIdent $1, False) }
|
|
| '[' Ident ']' { NonTerminal (showIdent $2, True) }
|
|
|
|
NonEmpty :: { Bool }
|
|
NonEmpty : 'nonempty' { True }
|
|
| {-empty-} { False }
|
|
|
|
|
|
ListEBNFRule :: { [ERule] }
|
|
ListEBNFRule
|
|
: EBNFRule { [$1] }
|
|
| EBNFRule ListEBNFRule { $1 : $2 }
|
|
|
|
EBNFRule :: { ERule }
|
|
: Ident '::=' ERHS0 ';' { ((showIdent $1,[]),$3) }
|
|
|
|
ERHS0 :: { ERHS }
|
|
: ERHS1 { $1 }
|
|
| ERHS1 '|' ERHS0 { EAlt $1 $3 }
|
|
|
|
ERHS1 :: { ERHS }
|
|
: ERHS2 { $1 }
|
|
| ERHS2 ERHS1 { ESeq $1 $2 }
|
|
|
|
ERHS2 :: { ERHS }
|
|
: ERHS3 '*' { EStar $1 }
|
|
| ERHS3 '+' { EPlus $1 }
|
|
| ERHS3 '?' { EOpt $1 }
|
|
| ERHS3 { $1 }
|
|
|
|
ERHS3 :: { ERHS }
|
|
: String { ETerm $1 }
|
|
| Ident { ENonTerm (showIdent $1,[]) }
|
|
| '(' ERHS0 ')' { $2 }
|
|
|
|
ModuleName :: { ModuleName }
|
|
: Ident { MN $1 }
|
|
|
|
Posn :: { Posn }
|
|
Posn
|
|
: {- empty -} {% getPosn }
|
|
|
|
|
|
{
|
|
|
|
happyError :: (Token, [String]) -> P a
|
|
happyError (t,strs) = fail $
|
|
"Syntax error:\n Unexpected " ++ showToken t ++ ".\n Expected one of:\n"
|
|
++ unlines (map ((" - "++).cleanupToken) strs)
|
|
|
|
where
|
|
cleanupToken "Ident" = "an identifier"
|
|
cleanupToken x = x
|
|
showToken (T_Ident i) = "identifier '" ++ showIdent i ++ "'"
|
|
showToken t = case Map.lookup t invMap of
|
|
Nothing -> show t
|
|
Just s -> "token '" ++ s ++"'"
|
|
|
|
mkListId,mkConsId,mkBaseId :: Ident -> Ident
|
|
mkListId = prefixIdent "List"
|
|
mkConsId = prefixIdent "Cons"
|
|
mkBaseId = prefixIdent "Base"
|
|
|
|
listCatDef :: L (Ident, Context, Int) -> [(Ident,Info)]
|
|
listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
|
|
where
|
|
listId = mkListId id
|
|
baseId = mkBaseId id
|
|
consId = mkConsId id
|
|
|
|
catd = (listId, AbsCat (Just (L loc cont')))
|
|
nilfund = (baseId, AbsFun (Just (L loc niltyp)) Nothing Nothing (Just True))
|
|
consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing (Just True))
|
|
|
|
cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont]
|
|
xs = map (\(b,x,t) -> Vr x) cont'
|
|
cd = mkHypo (mkApp (Vr id) xs)
|
|
lc = mkApp (Vr listId) xs
|
|
|
|
niltyp = mkProdSimple (cont' ++ replicate size cd) lc
|
|
constyp = mkProdSimple (cont' ++ [cd, mkHypo lc]) lc
|
|
|
|
mkId x i = if isWildIdent x then (varX i) else x
|
|
|
|
tryLoc (c,mty,Just e) = return (c,(mty,e))
|
|
tryLoc (c,_ ,_ ) = fail ("local definition of" +++ showIdent c +++ "without value")
|
|
|
|
mkR [] = return $ RecType [] --- empty record always interpreted as record type
|
|
mkR fs@(f:_) =
|
|
case f of
|
|
(lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType
|
|
_ -> mapM tryR fs >>= return . R
|
|
where
|
|
tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
|
|
tryRT (lab,_ ,_ ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
|
|
|
|
tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
|
|
tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab
|
|
|
|
mkOverload pdt pdf@(Just (L loc df)) =
|
|
case appForm df of
|
|
(keyw, ts@(_:_)) | isOverloading keyw ->
|
|
case last ts of
|
|
R fs -> [ResOverload [MN m | Vr m <- ts] [(L loc ty,L loc fu) | (_,(Just ty,fu)) <- fs]]
|
|
_ -> [ResOper pdt pdf]
|
|
_ -> [ResOper pdt pdf]
|
|
|
|
-- to enable separare type signature --- not type-checked
|
|
mkOverload pdt@(Just (L _ df)) pdf =
|
|
case appForm df of
|
|
(keyw, ts@(_:_)) | isOverloading keyw ->
|
|
case last ts of
|
|
RecType _ -> []
|
|
_ -> [ResOper pdt pdf]
|
|
_ -> [ResOper pdt pdf]
|
|
mkOverload pdt pdf = [ResOper pdt pdf]
|
|
|
|
isOverloading t =
|
|
case t of
|
|
Vr keyw | showIdent keyw == "overload" -> True -- overload is a "soft keyword"
|
|
_ -> False
|
|
|
|
checkInfoType mt jment@(id,info) =
|
|
case info of
|
|
AbsCat pcont -> ifAbstract mt (locPerh pcont)
|
|
AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
|
|
CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
|
|
CncFun _ pd ppn _ -> ifConcrete mt (locPerh pd ++ locPerh ppn)
|
|
ResParam pparam _ -> ifResource mt (locPerh pparam)
|
|
ResValue ty -> ifResource mt (locL ty)
|
|
ResOper pty pt -> ifOper mt pty pt
|
|
ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
|
|
where
|
|
locPerh = maybe [] locL
|
|
locAll xs = [loc | L loc x <- xs]
|
|
locL (L loc x) = [loc]
|
|
|
|
illegal (Local s e:_) = failLoc (Pn s 0) "illegal definition"
|
|
illegal _ = return jment
|
|
|
|
ifAbstract MTAbstract locs = return jment
|
|
ifAbstract _ locs = illegal locs
|
|
|
|
ifConcrete (MTConcrete _) locs = return jment
|
|
ifConcrete _ locs = illegal locs
|
|
|
|
ifResource (MTConcrete _) locs = return jment
|
|
ifResource (MTInstance _) locs = return jment
|
|
ifResource MTInterface locs = return jment
|
|
ifResource MTResource locs = return jment
|
|
ifResource _ locs = illegal locs
|
|
|
|
ifOper MTAbstract pty pt = return (id,AbsFun pty (fmap (const 0) pt) (Just (maybe [] (\(L l t) -> [L l ([],t)]) pt)) (Just False))
|
|
ifOper _ pty pt = return jment
|
|
|
|
mkAlts cs = case cs of
|
|
_:_ -> do
|
|
def <- mkDef (last cs)
|
|
alts <- mapM mkAlt (init cs)
|
|
return (Alts def alts)
|
|
_ -> fail "empty alts"
|
|
where
|
|
mkDef (_,t) = return t
|
|
mkAlt (p,t) = do
|
|
ss <- mkStrs p
|
|
return (t,ss)
|
|
mkStrs p = case p of
|
|
PAlt a b -> do
|
|
Strs as <- mkStrs a
|
|
Strs bs <- mkStrs b
|
|
return $ Strs $ as ++ bs
|
|
PString s -> return $ Strs [K s]
|
|
PV x -> return (Vr x) --- for macros; not yet complete
|
|
PMacro x -> return (Vr x) --- for macros; not yet complete
|
|
PM c -> return (Q c) --- for macros; not yet complete
|
|
_ -> fail "no strs from pattern"
|
|
|
|
mkL :: Posn -> Posn -> x -> L x
|
|
mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
|
|
|
|
}
|