-- -*- 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 }