From a391c69fd3937cab699dbf18ec042c7eca93ac9a Mon Sep 17 00:00:00 2001 From: krasimir Date: Mon, 16 Mar 2009 14:10:30 +0000 Subject: use new parser which supports the syntax in GF.Grammar.Grammar directly --- src/GF/Grammar/API.hs | 12 +- src/GF/Grammar/Lexer.x | 272 +++++++++++++++ src/GF/Grammar/Parser.y | 719 ++++++++++++++++++++++++++++++++++++++++ src/GF/Grammar/ReservedWords.hs | 44 --- 4 files changed, 993 insertions(+), 54 deletions(-) create mode 100644 src/GF/Grammar/Lexer.x create mode 100644 src/GF/Grammar/Parser.y delete mode 100644 src/GF/Grammar/ReservedWords.hs (limited to 'src/GF/Grammar') diff --git a/src/GF/Grammar/API.hs b/src/GF/Grammar/API.hs index 76508d963..f1d70e470 100644 --- a/src/GF/Grammar/API.hs +++ b/src/GF/Grammar/API.hs @@ -1,22 +1,19 @@ module GF.Grammar.API ( Grammar, emptyGrammar, - pTerm, - ppTerm, checkTerm, computeTerm, showTerm, TermPrintStyle(..), TermPrintQual(..), ) where -import GF.Source.ParGF -import GF.Source.SourceToGrammar (transExp) -import GF.Grammar.Grammar import GF.Infra.Ident import GF.Infra.Modules (greatestResource) import GF.Compile.GetGrammar import GF.Grammar.Macros +import GF.Grammar.Parser import GF.Grammar.Printer +import GF.Grammar.Grammar import GF.Compile.Rename (renameSourceTerm) import GF.Compile.CheckGrammar (justCheckLTerm) @@ -33,11 +30,6 @@ type Grammar = SourceGrammar emptyGrammar :: Grammar emptyGrammar = emptySourceGrammar -pTerm :: String -> Err Term -pTerm s = do - e <- pExp $ myLexer (BS.pack s) - transExp e - checkTerm :: Grammar -> Term -> Err Term checkTerm gr t = do mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr diff --git a/src/GF/Grammar/Lexer.x b/src/GF/Grammar/Lexer.x new file mode 100644 index 000000000..bc1a2277f --- /dev/null +++ b/src/GF/Grammar/Lexer.x @@ -0,0 +1,272 @@ +-- -*- haskell -*- +-- This Alex file was machine-generated by the BNF converter +{ +module GF.Grammar.Lexer + ( Token(..), Posn(..) + , P, runP, lexer, getPosn, failLoc + , isReservedWord + ) where + +import GF.Infra.Ident +import GF.Data.Operations +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as Map + +} + + +$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME +$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME +$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME +$d = [0-9] -- digit +$i = [$l $d _ '] -- identifier character +$u = [\0-\255] -- universal: any character + +@rsyms = -- symbols and non-identifier-like reserved words + \; | \= | \{ | \} | \( | \) | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/ + +:- +"--" [.]* ; -- Toss single line comments +"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; + +$white+ ; +@rsyms { tok (eitherResIdent (T_Ident . identC)) } +\' ($u # \')* \' { tok (eitherResIdent (T_LString . BS.unpack)) } +(\_ | $l)($l | $d | \_ | \')* { tok (eitherResIdent (T_Ident . identC)) } + +\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \" { tok (T_String . unescapeInitTail . BS.unpack) } + +$d+ { tok (T_Integer . read . BS.unpack) } +$d+ \. $d+ (e (\-)? $d+)? { tok (T_Double . read . BS.unpack) } + +{ + +tok f p s = f s + +data Token + = T_exclmark + | T_patt + | T_int_label + | T_oparen + | T_cparen + | 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_obrack + | T_lam + | T_lamlam + | T_cbrack + | T_ocurly + | T_bar + | T_ccurly + | T_underscore + | T_at + | T_PType + | T_Str + | T_Strs + | T_Tok + | T_Type + | T_abstract + | T_case + | T_cat + | T_concrete + | T_data + | T_def + | T_flags + | T_fn + | T_fun + | T_in + | T_incomplete + | T_instance + | T_interface + | T_let + | T_lin + | T_lincat + | T_lindef + | T_of + | T_open + | T_oper + | T_param + | T_pattern + | T_pre + | T_printname + | T_resource + | T_strs + | T_table + | T_transfer + | T_variants + | T_where + | T_with + | T_String String -- string literals + | T_Integer Integer -- integer literals + | T_Double Double -- double precision float literals + | T_LString String + | T_Ident Ident + | T_EOF + +eitherResIdent :: (BS.ByteString -> Token) -> BS.ByteString -> Token +eitherResIdent tv s = + case Map.lookup s resWords of + Just t -> t + Nothing -> tv s + +isReservedWord :: BS.ByteString -> Bool +isReservedWord s = Map.member s resWords + +resWords = Map.fromList + [ b "!" T_exclmark + , b "#" T_patt + , b "$" T_int_label + , b "(" T_oparen + , b ")" T_cparen + , b "*" T_star + , b "**" T_starstar + , b "+" T_plus + , b "++" T_plusplus + , b "," T_comma + , b "-" T_minus + , b "->" T_rarrow + , b "." T_dot + , b "/" T_alt + , b ":" T_colon + , b ";" T_semicolon + , b "<" T_less + , b "=" T_equal + , b "=>" T_big_rarrow + , b ">" T_great + , b "?" T_questmark + , b "[" T_obrack + , b "]" T_cbrack + , b "\\" T_lam + , b "\\\\" T_lamlam + , b "{" T_ocurly + , b "}" T_ccurly + , b "|" T_bar + , b "_" T_underscore + , b "@" T_at + , b "PType" T_PType + , b "Str" T_Str + , b "Strs" T_Strs + , b "Tok" T_Tok + , b "Type" T_Type + , b "abstract" T_abstract + , b "case" T_case + , b "cat" T_cat + , b "concrete" T_concrete + , b "data" T_data + , b "def" T_def + , b "flags" T_flags + , b "fn" T_fn + , b "fun" T_fun + , b "in" T_in + , b "incomplete" T_incomplete + , b "instance" T_instance + , b "interface" T_interface + , b "let" T_let + , b "lin" T_lin + , b "lincat" T_lincat + , b "lindef" T_lindef + , b "of" T_of + , b "open" T_open + , b "oper" T_oper + , b "param" T_param + , b "pattern" T_pattern + , b "pre" T_pre + , b "printname" T_printname + , b "resource" T_resource + , b "strs" T_strs + , b "table" T_table + , b "transfer" T_transfer + , b "variants" T_variants + , b "where" T_where + , b "with" T_with + ] + where b s t = (BS.pack s, t) + +unescapeInitTail :: String -> String +unescapeInitTail = unesc . tail where + unesc s = case s of + '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs + '\\':'n':cs -> '\n' : unesc cs + '\\':'t':cs -> '\t' : unesc cs + '"':[] -> [] + c:cs -> c : unesc cs + _ -> [] + +------------------------------------------------------------------- +-- Alex wrapper code. +-- A modified "posn" wrapper. +------------------------------------------------------------------- + +data Posn = Pn {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + +alexMove :: Posn -> Char -> Posn +alexMove (Pn l c) '\n' = Pn (l+1) 1 +alexMove (Pn l c) _ = Pn l (c+1) + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (AI p _ s) = + case BS.uncons s of + Nothing -> Nothing + Just (c,s) -> + let p' = alexMove p c + in p' `seq` Just (c, (AI p' c s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (AI p c s) = c + +data AlexInput = AI {-# UNPACK #-} !Posn -- current position, + {-# UNPACK #-} !Char -- previous char + {-# UNPACK #-} !BS.ByteString -- current input string + +data ParseResult a + = POk AlexInput a + | PFailed Posn -- The position of the error + String -- The error message + +newtype P a = P { unP :: AlexInput -> ParseResult a } + +instance Monad P where + return a = a `seq` (P $ \s -> POk s a) + (P m) >>= k = P $ \ s -> case m s of + POk s1 a -> unP (k a) s1 + PFailed posn err -> PFailed posn err + fail msg = P $ \(AI posn _ _) -> PFailed posn msg + +runP :: P a -> BS.ByteString -> Either (Posn,String) a +runP (P f) txt = + case f (AI (Pn 1 0) ' ' txt) of + POk _ x -> Right x + PFailed pos msg -> Left (pos,msg) + +failLoc :: Posn -> String -> P a +failLoc pos msg = P $ \_ -> PFailed pos msg + +lexer :: (Token -> P a) -> P a +lexer cont = P go + where + go inp@(AI pos _ str) = + case alexScan inp 0 of + AlexEOF -> unP (cont T_EOF) inp + AlexError (AI pos _ _) -> PFailed pos "lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> unP (cont (act pos (BS.take len str))) inp' + +getPosn :: P Posn +getPosn = P $ \inp@(AI pos _ _) -> POk inp pos + +} diff --git a/src/GF/Grammar/Parser.y b/src/GF/Grammar/Parser.y new file mode 100644 index 000000000..6be4e0ced --- /dev/null +++ b/src/GF/Grammar/Parser.y @@ -0,0 +1,719 @@ +{ +{-# OPTIONS -fno-warn-overlapping-patterns #-} +module GF.Grammar.Parser + ( P, runP + , pModDef + , pModHeader + , pExp + ) where + +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Infra.Option +import GF.Data.Operations +import GF.Grammar.Predef +import GF.Grammar.Grammar +import GF.Grammar.Macros +import GF.Grammar.Lexer +import qualified Data.ByteString.Char8 as BS +import GF.Compile.Update (buildAnyTree) +} + +%name pModDef ModDef +%partial pModHeader ModHeader +%name pExp Exp + +-- 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_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 } + '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 } + 'fn' { T_fn } + '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 } + '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 } + 'transfer' { T_transfer } + 'variants' { T_variants } + 'where' { T_where } + 'with' { T_with } + +Integer { (T_Integer $$) } +Double { (T_Double $$) } +String { (T_String $$) } +LString { (T_LString $$) } +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) } + mapM_ (checkInfoType mtype) jments + defs <- case buildAnyTree id [(i,d) | (i,_,d) <- jments] of + Ok x -> return x + Bad msg -> fail msg + let poss = buildTree [(i,(fname,mkSrcSpan p)) | (i,p,_) <- jments] + fname = prIdent id ++ ".gf" + + mkSrcSpan :: (Posn, Posn) -> (Int,Int) + mkSrcSpan (Pn l1 _, Pn l2 _) = (l1,l2) + + return (id, ModInfo mtype mstat opts extends with opens [] defs poss) } + +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 [] emptyBinTree emptyBinTree) } + +ComplMod :: { ModuleStatus } +ComplMod + : {- empty -} { MSComplete } + | 'incomplete' { MSIncomplete } + +ModType :: { (ModuleType Ident,Ident) } +ModType + : 'abstract' Ident { (MTAbstract, $2) } + | 'resource' Ident { (MTResource, $2) } + | 'interface' Ident { (MTInterface, $2) } + | 'concrete' Ident 'of' Ident { (MTConcrete $4, $2) } + | 'instance' Ident 'of' Ident { (MTInstance $4, $2) } + | 'transfer' Ident ':' Open '->' Open { (MTTransfer $4 $6,$2) } + +ModHeaderBody :: { ( [(Ident,MInclude Ident)] + , Maybe (Ident,MInclude Ident,[(Ident,Ident)]) + , [OpenSpec Ident] + ) } +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 Ident] } +ModOpen + : { [] } + | 'open' ListOpen { $2 } + +ModBody :: { ( [(Ident,MInclude Ident)] + , Maybe (Ident,MInclude Ident,[(Ident,Ident)]) + , Maybe ([OpenSpec Ident],[(Ident,SrcSpan,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],[(Ident,SrcSpan,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,SrcSpan,Info)] Options] } +ListTopDef + : {- empty -} { [] } + | TopDef ListTopDef { $1 : $2 } + +ListOpen :: { [OpenSpec Ident] } +ListOpen + : Open { [$1] } + | Open ',' ListOpen { $1 : $3 } + +Open :: { OpenSpec Ident } +Open + : Ident { OSimple $1 } + | '(' Ident '=' Ident ')' { OQualif $2 $4 } + +ListInst :: { [(Ident,Ident)] } +ListInst + : Inst { [$1] } + | Inst ',' ListInst { $1 : $3 } + +Inst :: { (Ident,Ident) } +Inst + : '(' Ident '=' Ident ')' { ($2,$4) } + +ListIncluded :: { [(Ident,MInclude Ident)] } +ListIncluded + : Included { [$1] } + | Included ',' ListIncluded { $1 : $3 } + +Included :: { (Ident,MInclude Ident) } +Included + : Ident { ($1,MIAll ) } + | Ident '[' ListIdent ']' { ($1,MIOnly $3) } + | Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) } + +TopDef :: { Either [(Ident,SrcSpan,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, pos, CncCat (Just e) Nothing Nothing ) | (f,pos,e) <- $2] } + | 'lindef' ListTermDef { Left [(f, pos, CncCat Nothing (Just e) Nothing ) | (f,pos,e) <- $2] } + | 'lin' ListLinDef { Left $2 } + | 'printname' 'cat' ListTermDef { Left [(f, pos, CncCat Nothing Nothing (Just e)) | (f,pos,e) <- $3] } + | 'printname' 'fun' ListTermDef { Left [(f, pos, CncFun Nothing Nothing (Just e)) | (f,pos,e) <- $3] } + | 'flags' ListFlagDef { Right $2 } + +CatDef :: { [(Ident,SrcSpan,Info)] } +CatDef + : Posn Ident ListDDecl Posn { [($2, ($1,$4), AbsCat (Just $3) Nothing)] } + | Posn '[' Ident ListDDecl ']' Posn { listCatDef $3 ($1,$6) $4 0 } + | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) } + +FunDef :: { [(Ident,SrcSpan,Info)] } +FunDef + : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing) | fun <- $2] } + +DefDef :: { [(Ident,SrcSpan,Info)] } +DefDef + : Posn ListName '=' Exp Posn { [(f, ($1,$5),AbsFun Nothing (Just $4)) | f <- $2] } + | Posn Name ListPatt '=' Exp Posn { [($2,($1,$6),AbsFun Nothing (Just (Eqs [($3,$5)])))] } + +DataDef :: { [(Ident,SrcSpan,Info)] } +DataDef + : Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing (Just (map Cn $4))) : + [(fun, ($1,$5), AbsFun Nothing (Just EData)) | fun <- $4] } + | Posn ListIdent ':' Exp Posn { [(cat, ($1,$5), AbsCat Nothing (Just (map Cn $2))) | Ok (_,cat) <- [valCat $4]] ++ + [(fun, ($1,$5), AbsFun (Just $4) (Just EData)) | fun <- $2] } + +ParamDef :: { [(Ident,SrcSpan,Info)] } +ParamDef + : Posn Ident '=' ListParConstr Posn { ($2, ($1,$5), ResParam (Just ($4,Nothing))) : + [(f, ($1,$5), ResValue (Just (mkProdSimple co (Cn $2),Nothing))) | (f,co) <- $4] } + | Posn Ident Posn { [($2, ($1,$3), ResParam Nothing)] } + +OperDef :: { [(Ident,SrcSpan,Info)] } +OperDef + : Posn ListName ':' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload (Just $4) Nothing ] } + | Posn ListName '=' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload Nothing (Just $4)] } + | Posn Name ListArg '=' Exp Posn { [(i, ($1,$6), info) | i <- [$2], info <- mkOverload Nothing (Just (mkAbs $3 $5))] } + | Posn ListName ':' Exp '=' Exp Posn { [(i, ($1,$7), info) | i <- $2, info <- mkOverload (Just $4) (Just $6)] } + +LinDef :: { [(Ident,SrcSpan,Info)] } +LinDef + : Posn ListName '=' Exp Posn { [(f, ($1,$5), CncFun Nothing (Just $4) Nothing) | f <- $2] } + | Posn Name ListArg '=' Exp Posn { [($2, ($1,$6), CncFun Nothing (Just (mkAbs $3 $5)) Nothing)] } + +TermDef :: { [(Ident,SrcSpan,Term)] } +TermDef + : Posn ListName '=' Exp Posn { [(i,($1,$5),$4) | i <- $2] } + +FlagDef :: { Options } +FlagDef + : Posn Ident '=' Ident Posn {% case parseModuleOptions ["--" ++ prIdent $2 ++ "=" ++ prIdent $4] of + Ok x -> return x + Bad msg -> failLoc $1 msg } + +ListDataConstr :: { [Ident] } +ListDataConstr + : Ident { [$1] } + | Ident '|' ListDataConstr { $1 : $3 } + +ParConstr :: { Param } +ParConstr + : Ident ListDDecl { ($1,$2) } + +ListLinDef :: { [(Ident,SrcSpan,Info)] } +ListLinDef + : LinDef ';' { $1 } + | LinDef ';' ListLinDef { $1 ++ $3 } + +ListDefDef :: { [(Ident,SrcSpan,Info)] } +ListDefDef + : DefDef ';' { $1 } + | DefDef ';' ListDefDef { $1 ++ $3 } + +ListOperDef :: { [(Ident,SrcSpan,Info)] } +ListOperDef + : OperDef ';' { $1 } + | OperDef ';' ListOperDef { $1 ++ $3 } + +ListCatDef :: { [(Ident,SrcSpan,Info)] } +ListCatDef + : CatDef ';' { $1 } + | CatDef ';' ListCatDef { $1 ++ $3 } + +ListFunDef :: { [(Ident,SrcSpan,Info)] } +ListFunDef + : FunDef ';' { $1 } + | FunDef ';' ListFunDef { $1 ++ $3 } + +ListDataDef :: { [(Ident,SrcSpan,Info)] } +ListDataDef + : DataDef ';' { $1 } + | DataDef ';' ListDataDef { $1 ++ $3 } + +ListParamDef :: { [(Ident,SrcSpan,Info)] } +ListParamDef + : ParamDef ';' { $1 } + | ParamDef ';' ListParamDef { $1 ++ $3 } + +ListTermDef :: { [(Ident,SrcSpan,Term)] } +ListTermDef + : TermDef ';' { $1 } + | TermDef ';' ListTermDef { $1 ++ $3 } + +ListFlagDef :: { Options } +ListFlagDef + : FlagDef ';' { $1 } + | FlagDef ';' ListFlagDef { addOptions $1 $3 } + +ListParConstr :: { [Param] } +ListParConstr + : ParConstr { [$1] } + | ParConstr '|' ListParConstr { $1 : $3 } + +ListIdent :: { [Ident] } +ListIdent + : Ident { [$1] } + | Ident ',' ListIdent { $1 : $3 } + +Name :: { Ident } +Name + : Ident { $1 } + | '[' Ident ']' { mkListId $2 } + +ListName :: { [Ident] } +ListName + : Name { [$1] } + | Name ',' ListName { $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 } + | 'fn' '{' ListEquation '}' { Eqs $3 } + | '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 } + | Exp4 { $1 } + +Exp4 :: { Term } +Exp4 + : Exp4 Exp5 { App $1 $2 } + | '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' '{' Exp ';' ListAltern '}' { Alts ($3, $5) } + | 'strs' '{' ListExp '}' { Strs $3 } + | '#' Patt2 { EPatt $2 } + | 'pattern' Exp5 { EPattType $2 } + | 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 (int2meta 0) } + | '[' ']' { Empty } + | 'data' { EData } + | '[' Ident Exps ']' { foldl App (Vr (mkListId $2)) $3 } + | '[' String ']' { case $2 of + [] -> Empty + str -> foldr1 C (map K (words str)) } + | '{' ListLocDef '}' {% mkR $2 } + | '<' ListTupleComp '>' { R (tuple2record $2) } + | '<' Exp ':' Exp '>' { Typed $2 $4 } + | LString { K $1 } + | '(' 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 } + | Ident '.' Ident ListPatt { PP $1 $3 $4 } + | Patt2 '*' { PRep $1 } + | Ident '@' Patt2 { PAs $1 $3 } + | '-' Patt2 { PNeg $2 } + | Patt2 { $1 } + +Patt2 :: { Patt } +Patt2 + : '?' { PChar } + | '[' String ']' { PChars $2 } + | '#' Ident { PMacro $2 } + | '#' Ident '.' Ident { PM $2 $4 } + | '_' { wildPatt } + | Ident { PV $1 } + | '{' Ident '}' { PC $2 [] } + | Ident '.' Ident { PP $1 $3 [] } + | Integer { PInt $1 } + | Double { PFloat $1 } + | String { PString $1 } + | '{' ListPattAss '}' { PR $2 } + | '<' ListPattTupleComp '>' { (PR . tuple2recordPatt) $2 } + | '(' Patt ')' { $2 } + +Arg :: { Ident } +Arg + : '_' { identW } + | Ident { $1 } + +PattAss :: { [(Label,Patt)] } +PattAss + : ListIdent '=' Patt { [(LIdent (ident2bs i),$3) | i <- $1] } + +Label :: { Label } +Label + : Ident { LIdent (ident2bs $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 + : Patt2 { [$1] } + | Patt2 ListPatt { $1 : $2 } + +ListArg :: { [Ident] } +ListArg + : Arg { [$1] } + | Arg ListArg { $1 : $2 } + +Bind :: { Ident } +Bind + : Ident { $1 } + | '_' { identW } + +ListBind :: { [Ident] } +ListBind + : Bind { [$1] } + | Bind ',' ListBind { $1 : $3 } + +Decl :: { [Decl] } +Decl + : '(' ListBind ':' Exp ')' { [(x,$4) | x <- $2] } + | Exp4 { [mkDecl $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 } + +Equation :: { Equation } +Equation + : ListPatt '->' Exp { ($1,$3) } + +ListEquation :: { [Equation] } +ListEquation + : Equation { (:[]) $1 } + | Equation ';' ListEquation { (:) $1 $3 } + +Altern :: { (Term,Term) } +Altern + : Exp '/' Exp { ($1,$3) } + +ListAltern :: { [(Term,Term)] } +ListAltern + : Altern { [$1] } + | Altern ';' ListAltern { $1 : $3 } + +DDecl :: { [Decl] } +DDecl + : '(' ListBind ':' Exp ')' { [(x,$4) | x <- $2] } + | Exp6 { [mkDecl $1] } + +ListDDecl :: { [Decl] } +ListDDecl + : {- empty -} { [] } + | DDecl ListDDecl { $1 ++ $2 } + +Posn :: { Posn } +Posn + : {- empty -} {% getPosn } + + +{ + +happyError :: P a +happyError = fail "parse error" + +mkListId,mkConsId,mkBaseId :: Ident -> Ident +mkListId = prefixId (BS.pack "List") +mkConsId = prefixId (BS.pack "Cons") +mkBaseId = prefixId (BS.pack "Base") + +prefixId :: BS.ByteString -> Ident -> Ident +prefixId pref id = identC (BS.append pref (ident2bs id)) + +listCatDef id pos cont size = [catd,nilfund,consfund] + where + listId = mkListId id + baseId = mkBaseId id + consId = mkConsId id + + catd = (listId, pos, AbsCat (Just cont') (Just [Cn baseId,Cn consId])) + nilfund = (baseId, pos, AbsFun (Just niltyp) (Just EData)) + consfund = (consId, pos, AbsFun (Just constyp) (Just EData)) + + cont' = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont] + xs = map (Vr . fst) cont' + cd = mkDecl (mkApp (Vr id) xs) + lc = mkApp (Vr listId) xs + + niltyp = mkProdSimple (cont' ++ replicate size cd) lc + constyp = mkProdSimple (cont' ++ [cd, mkDecl 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" +++ prIdent 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" +++ prIdent lab --- manifest fields ?! + + tryR (lab,mty,Just t) = return (ident2label lab,(mty,t)) + tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ prIdent lab + +mkOverload pdt pdf@(Just df) = + case appForm df of + (keyw, ts@(_:_)) | isOverloading keyw -> + case last ts of + R fs -> [ResOverload [m | Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs]] + _ -> [ResOper pdt pdf] + _ -> [ResOper pdt pdf] + + -- to enable separare type signature --- not type-checked +mkOverload pdt@(Just 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 | prIdent keyw == "overload" -> True -- overload is a "soft keyword" + _ -> False + + +type SrcSpan = (Posn,Posn) + + +checkInfoType MTAbstract (id,pos,info) = + case info of + AbsCat _ _ -> return () + AbsFun _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in abstract module" +checkInfoType MTResource (id,pos,info) = + case info of + ResParam _ -> return () + ResValue _ -> return () + ResOper _ _ -> return () + ResOverload _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in resource module" +checkInfoType MTInterface (id,pos,info) = + case info of + ResParam _ -> return () + ResValue _ -> return () + ResOper _ _ -> return () + ResOverload _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in interface module" +checkInfoType (MTConcrete _) (id,pos,info) = + case info of + CncCat _ _ _ -> return () + CncFun _ _ _ -> return () + ResParam _ -> return () + ResValue _ -> return () + ResOper _ _ -> return () + ResOverload _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in concrete module" +checkInfoType (MTInstance _) (id,pos,info) = + case info of + ResParam _ -> return () + ResValue _ -> return () + ResOper _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in instance module" +checkInfoType (MTTransfer _ _) (id,pos,info) = + case info of + AbsCat _ _ -> return () + AbsFun _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in transfer module" + +} + diff --git a/src/GF/Grammar/ReservedWords.hs b/src/GF/Grammar/ReservedWords.hs deleted file mode 100644 index b440141d6..000000000 --- a/src/GF/Grammar/ReservedWords.hs +++ /dev/null @@ -1,44 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ReservedWords --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:28 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- reserved words of GF. (c) Aarne Ranta 19\/3\/2002 under Gnu GPL. --- modified by Markus Forsberg 9\/4. --- modified by AR 12\/6\/2003 for GF2 and GFC ------------------------------------------------------------------------------ - -module GF.Grammar.ReservedWords (isResWord, isResWordGFC) where - -import Data.List - - -isResWord :: String -> Bool -isResWord s = isInTree s resWordTree - -resWordTree :: BTree -resWordTree = --- mapTree fst $ sorted2tree $ flip zip (repeat ()) $ sort allReservedWords --- nowadays obtained from LexGF.hs - B "let" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "in" (B "fn" (B "flags" (B "def" N N) N) (B "grammar" (B "fun" N N) N)) (B "instance" (B "incomplete" (B "include" N N) N) (B "interface" N N)))) (B "pre" (B "open" (B "lindef" (B "lincat" (B "lin" N N) N) (B "of" (B "lintype" N N) N)) (B "param" (B "out" (B "oper" N N) N) (B "pattern" N N))) (B "transfer" (B "reuse" (B "resource" (B "printname" N N) N) (B "table" (B "strs" N N) N)) (B "where" (B "variants" (B "union" N N) N) (B "with" N N)))) - -isResWordGFC :: String -> Bool -isResWordGFC s = isInTree s $ - B "of" (B "fun" (B "concrete" (B "cat" (B "abstract" N N) N) (B "flags" N N)) (B "lin" (B "in" N N) (B "lincat" N N))) (B "resource" (B "param" (B "oper" (B "open" N N) N) (B "pre" N N)) (B "table" (B "strs" N N) (B "variants" N N))) - -data BTree = N | B String BTree BTree deriving (Show) - -isInTree :: String -> BTree -> Bool -isInTree x tree = case tree of - N -> False - B a left right - | x < a -> isInTree x left - | x > a -> isInTree x right - | x == a -> True - -- cgit v1.2.3