summaryrefslogtreecommitdiff
path: root/src/GF/Grammar
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Grammar')
-rw-r--r--src/GF/Grammar/API.hs12
-rw-r--r--src/GF/Grammar/Lexer.x272
-rw-r--r--src/GF/Grammar/Parser.y719
-rw-r--r--src/GF/Grammar/ReservedWords.hs44
4 files changed, 993 insertions, 54 deletions
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
-
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 16:25:20 +0000