msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

use new parser which supports the syntax in GF.Grammar.Grammar directly

Browse Source
This commit is contained in:
krasimir
2009-03-16 14:10:30 +00:00
parent 5597cff5cb
commit a391c69fd3
16 changed files with 1031 additions and 4915 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
GF.cabal
View File

@@ -617,9 +617,7 @@ executable gf
extensions: extensions:
main-is: GF.hs main-is: GF.hs
other-modules: other-modules:
GF.Grammar.ReservedWords
GF.Data.BacktrackM GF.Data.BacktrackM
GF.Source.LexGF
GF.Source.AbsGF GF.Source.AbsGF
GF.Source.PrintGF GF.Source.PrintGF
GF.JavaScript.AbsJS GF.JavaScript.AbsJS
@@ -632,7 +630,6 @@ executable gf
GF.Data.Assoc GF.Data.Assoc
GF.Compile.GenerateFCFG GF.Compile.GenerateFCFG
GF.Data.ErrM GF.Data.ErrM
GF.Source.ParGF
GF.Data.Operations GF.Data.Operations
GF.Infra.Ident GF.Infra.Ident
GF.Grammar.Predef GF.Grammar.Predef
@@ -647,6 +644,8 @@ executable gf
GF.Command.Parse GF.Command.Parse
GF.Command.Importing GF.Command.Importing
GF.Infra.Modules GF.Infra.Modules
GF.Grammar.Lexer
GF.Grammar.Parser
GF.Grammar.Grammar GF.Grammar.Grammar
GF.Source.GrammarToSource GF.Source.GrammarToSource
GF.Grammar.Values GF.Grammar.Values

2
next-lib/src/russian/StructuralRus.gf
View File

@@ -1,7 +1,7 @@
--# -path=.:../abstract:../common:../../prelude --# -path=.:../abstract:../common:../../prelude
concrete StructuralRus of Structural = CatRus ** concrete StructuralRus of Structural = CatRus **
open ResRus, MorphoRus, (P = ParadigmsRus), Prelude, NounRus, in { open ResRus, MorphoRus, (P = ParadigmsRus), Prelude, NounRus in {
flags optimize=all ; coding=utf8 ; flags optimize=all ; coding=utf8 ;

2
next-lib/src/thai/GrammarTha.gf
View File

@@ -12,7 +12,7 @@ concrete GrammarTha of Grammar =
-- ConjunctionTha, -- ConjunctionTha,
PhraseTha, PhraseTha,
-- TextX, -- TextX,
StructuralTha, StructuralTha
-- IdiomTha -- IdiomTha
** { ** {

9
src/GF/Compile/CheckGrammar.hs
View File

@@ -30,12 +30,12 @@ import GF.Infra.Modules
import GF.Compile.TypeCheck import GF.Compile.TypeCheck
import GF.Compile.Refresh import GF.Compile.Refresh
import GF.Grammar.Lexer
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.PrGrammar import GF.Grammar.PrGrammar
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.ReservedWords
import GF.Grammar.PatternMatch import GF.Grammar.PatternMatch
import GF.Grammar.AppPredefined import GF.Grammar.AppPredefined
import GF.Grammar.Lockfield (isLockLabel) import GF.Grammar.Lockfield (isLockLabel)
@@ -403,10 +403,9 @@ checkPrintname _ _ = return ()
-- | for grammars obtained otherwise than by parsing ---- update!! -- | for grammars obtained otherwise than by parsing ---- update!!
checkReservedId :: Ident -> Check () checkReservedId :: Ident -> Check ()
checkReservedId x = let c = prt x in checkReservedId x
if isResWord c | isReservedWord (ident2bs x) = checkWarn ("Warning: reserved word used as identifier:" +++ prt x)
then checkWarn ("Warning: reserved word used as identifier:" +++ c) | otherwise = return ()
else return ()
-- to normalize records and record types -- to normalize records and record types
labelIndex :: Type -> Label -> Int labelIndex :: Type -> Label -> Int

38
src/GF/Compile/GetGrammar.hs
View File

@@ -18,15 +18,10 @@ import GF.Data.Operations
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Modules import GF.Infra.Modules
import GF.Grammar.Grammar
import qualified GF.Source.AbsGF as A
import GF.Source.SourceToGrammar
---- import Macros
---- import Rename
import GF.Infra.Option import GF.Infra.Option
--- import Custom import GF.Grammar.Lexer
import GF.Source.ParGF import GF.Grammar.Parser
import qualified GF.Source.LexGF as L import GF.Grammar.Grammar
import GF.Compile.ReadFiles import GF.Compile.ReadFiles
@@ -37,22 +32,21 @@ import Control.Monad (foldM)
import System.Cmd (system) import System.Cmd (system)
getSourceModule :: Options -> FilePath -> IOE SourceModule getSourceModule :: Options -> FilePath -> IOE SourceModule
getSourceModule opts file0 = do getSourceModule opts file0 = ioe $
file <- foldM runPreprocessor file0 (flag optPreprocessors opts) catch (do file <- foldM runPreprocessor file0 (flag optPreprocessors opts)
string <- readFileIOE file content <- BS.readFile file
let tokens = myLexer string case runP pModDef content of
mo1 <- ioeErr $ errIn file0 $ pModDef tokens Left (Pn l c,msg) -> return (Bad (file++":"++show l++":"++show c++": "++msg))
mo2 <- ioeErr $ transModDef mo1 Right mo -> return (Ok (addOptionsToModule opts mo)))
return $ addOptionsToModule opts mo2 (\e -> return (Bad (show e)))
addOptionsToModule :: Options -> SourceModule -> SourceModule addOptionsToModule :: Options -> SourceModule -> SourceModule
addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts }) addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts })
-- FIXME: should use System.IO.openTempFile -- FIXME: should use System.IO.openTempFile
runPreprocessor :: FilePath -> String -> IOE FilePath runPreprocessor :: FilePath -> String -> IO FilePath
runPreprocessor file0 p = runPreprocessor file0 p = do
do let tmp = "_gf_preproc.tmp" let tmp = "_gf_preproc.tmp"
cmd = p +++ file0 ++ ">" ++ tmp cmd = p +++ file0 ++ ">" ++ tmp
ioeIO $ system cmd system cmd
-- ioeIO $ putStrLn $ "preproc" +++ cmd return tmp
return tmp

27
src/GF/Compile/ReadFiles.hs
View File

@@ -29,9 +29,8 @@ import GF.Infra.Ident
import GF.Infra.Modules import GF.Infra.Modules
import GF.Data.Operations import GF.Data.Operations
import qualified GF.Source.AbsGF as S import qualified GF.Source.AbsGF as S
import GF.Source.LexGF import GF.Grammar.Lexer
import GF.Source.ParGF import GF.Grammar.Parser
import GF.Source.SourceToGrammar(transModDef)
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Binary import GF.Grammar.Binary
@@ -109,29 +108,13 @@ getAllFiles opts ps env file = do
CSEnv -> return (name, maybe [] snd mb_envmod) CSEnv -> return (name, maybe [] snd mb_envmod)
CSRead -> ioeIO $ fmap importsOfModule (decodeModHeader (replaceExtension file "gfo")) CSRead -> ioeIO $ fmap importsOfModule (decodeModHeader (replaceExtension file "gfo"))
CSComp -> do s <- ioeIO $ BS.readFile file CSComp -> do s <- ioeIO $ BS.readFile file
ioeErr ((liftM (importsOfModule . modHeaderToModDef) . pModHeader . myLexer) s) case runP pModHeader s of
Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
Right mo -> return (importsOfModule mo)
ioeErr $ testErr (mname == name) ioeErr $ testErr (mname == name)
("module name" +++ mname +++ "differs from file name" +++ name) ("module name" +++ mname +++ "differs from file name" +++ name)
return (name,st,t,imps,dropFileName file) return (name,st,t,imps,dropFileName file)
-- FIXME: this is pretty ugly, it's just to get around the difference
-- between ModHeader as returned when parsing just the module header
-- when looking for imports, and ModDef, which includes the whole module.
modHeaderToModDef :: S.ModHeader -> SourceModule
modHeaderToModDef (S.MModule2 x y z) =
errVal (error "error in modHeaderToModDef") $ transModDef $ S.MModule x y (modHeaderBodyToModBody z)
where
modHeaderBodyToModBody :: S.ModHeaderBody -> S.ModBody
modHeaderBodyToModBody b = case b of
S.MBody2 x y -> S.MBody x y []
S.MNoBody2 x -> S.MNoBody x
S.MWith2 x y -> S.MWith x y
S.MWithBody2 x y z -> S.MWithBody x y z []
S.MWithE2 x y z -> S.MWithE x y z
S.MWithEBody2 x y z w -> S.MWithEBody x y z w []
S.MReuse2 x -> S.MReuse x
S.MUnion2 x -> S.MUnion x
isGFO :: FilePath -> Bool isGFO :: FilePath -> Bool
isGFO = (== ".gfo") . takeExtensions isGFO = (== ".gfo") . takeExtensions

12
src/GF/Grammar/API.hs
View File

@@ -1,22 +1,19 @@
module GF.Grammar.API ( module GF.Grammar.API (
Grammar, Grammar,
emptyGrammar, emptyGrammar,
pTerm,
ppTerm,
checkTerm, checkTerm,
computeTerm, computeTerm,
showTerm, showTerm,
TermPrintStyle(..), TermPrintQual(..), TermPrintStyle(..), TermPrintQual(..),
) where ) where
import GF.Source.ParGF
import GF.Source.SourceToGrammar (transExp)
import GF.Grammar.Grammar
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Modules (greatestResource) import GF.Infra.Modules (greatestResource)
import GF.Compile.GetGrammar import GF.Compile.GetGrammar
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.Parser
import GF.Grammar.Printer import GF.Grammar.Printer
import GF.Grammar.Grammar
import GF.Compile.Rename (renameSourceTerm) import GF.Compile.Rename (renameSourceTerm)
import GF.Compile.CheckGrammar (justCheckLTerm) import GF.Compile.CheckGrammar (justCheckLTerm)
@@ -33,11 +30,6 @@ type Grammar = SourceGrammar
emptyGrammar :: Grammar emptyGrammar :: Grammar
emptyGrammar = emptySourceGrammar emptyGrammar = emptySourceGrammar
pTerm :: String -> Err Term
pTerm s = do
e <- pExp $ myLexer (BS.pack s)
transExp e
checkTerm :: Grammar -> Term -> Err Term checkTerm :: Grammar -> Term -> Err Term
checkTerm gr t = do checkTerm gr t = do
mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr

272
src/GF/Grammar/Lexer.x Normal file
View File

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

719
src/GF/Grammar/Parser.y Normal file
View File

@@ -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"
}

44
src/GF/Grammar/ReservedWords.hs
View File

@@ -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

6
src/GF/Infra/UseIO.hs
View File

@@ -175,9 +175,3 @@ putPointE v opts msg act = do
else when (verbAtLeast opts v) $ putStrLnE "" else when (verbAtLeast opts v) $ putStrLnE ""
return a return a
-- ((do {s <- readFile f; return (return s)}) )
readFileIOE :: FilePath -> IOE BS.ByteString
readFileIOE f = ioe $ catch (BS.readFile f >>= return . return)
(\e -> return (Bad (show e)))

350
src/GF/Source/LexGF.hs
View File

File diff suppressed because one or more lines are too long

144
src/GF/Source/LexGF.x
View File

@@ -1,144 +0,0 @@
-- -*- haskell -*-
-- This Alex file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module GF.Source.LexGF where
import qualified Data.ByteString.Char8 as BS
}
$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 (\p s -> PT p (eitherResIdent (TV . share) s)) }
\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
(\_ | $l)($l | $d | \_ | \')* { tok (\p s -> PT p (eitherResIdent (T_PIdent . share) s)) }
$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
$d+ { tok (\p s -> PT p (TI $ share s)) }
$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
{
tok f p s = f p s
share :: BS.ByteString -> BS.ByteString
share = id
data Tok =
TS !BS.ByteString !Int -- reserved words and symbols
| TL !BS.ByteString -- string literals
| TI !BS.ByteString -- integer literals
| TV !BS.ByteString -- identifiers
| TD !BS.ByteString -- double precision float literals
| TC !BS.ByteString -- character literals
| T_LString !BS.ByteString
| T_PIdent !BS.ByteString
deriving (Eq,Show,Ord)
data Token =
PT Posn Tok
| Err Posn
deriving (Eq,Show,Ord)
tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
tokenPos _ = "end of file"
posLineCol (Pn _ l c) = (l,c)
mkPosToken t@(PT p _) = (posLineCol p, prToken t)
prToken t = case t of
PT _ (TS s _) -> s
PT _ (TL s) -> s
PT _ (TI s) -> s
PT _ (TV s) -> s
PT _ (TD s) -> s
PT _ (TC s) -> s
PT _ (T_LString s) -> s
PT _ (T_PIdent s) -> s
data BTree = N | B BS.ByteString Tok BTree BTree deriving (Show)
eitherResIdent :: (BS.ByteString -> Tok) -> BS.ByteString -> Tok
eitherResIdent tv s = treeFind resWords
where
treeFind N = tv s
treeFind (B a t left right) | s < a = treeFind left
| s > a = treeFind right
| s == a = t
resWords = b "def" 39 (b "=>" 20 (b "++" 10 (b "(" 5 (b "$" 3 (b "#" 2 (b "!" 1 N N) N) (b "%" 4 N N)) (b "**" 8 (b "*" 7 (b ")" 6 N N) N) (b "+" 9 N N))) (b "/" 15 (b "->" 13 (b "-" 12 (b "," 11 N N) N) (b "." 14 N N)) (b "<" 18 (b ";" 17 (b ":" 16 N N) N) (b "=" 19 N N)))) (b "[" 30 (b "PType" 25 (b "@" 23 (b "?" 22 (b ">" 21 N N) N) (b "Lin" 24 N N)) (b "Tok" 28 (b "Strs" 27 (b "Str" 26 N N) N) (b "Type" 29 N N))) (b "case" 35 (b "_" 33 (b "]" 32 (b "\\" 31 N N) N) (b "abstract" 34 N N)) (b "concrete" 37 (b "cat" 36 N N) (b "data" 38 N N))))) (b "package" 58 (b "let" 49 (b "in" 44 (b "fun" 42 (b "fn" 41 (b "flags" 40 N N) N) (b "grammar" 43 N N)) (b "instance" 47 (b "incomplete" 46 (b "include" 45 N N) N) (b "interface" 48 N N))) (b "of" 54 (b "lindef" 52 (b "lincat" 51 (b "lin" 50 N N) N) (b "lintype" 53 N N)) (b "oper" 56 (b "open" 55 N N) (b "out" 57 N N)))) (b "transfer" 68 (b "resource" 63 (b "pre" 61 (b "pattern" 60 (b "param" 59 N N) N) (b "printname" 62 N N)) (b "table" 66 (b "strs" 65 (b "reuse" 64 N N) N) (b "tokenizer" 67 N N))) (b "with" 73 (b "variants" 71 (b "var" 70 (b "union" 69 N N) N) (b "where" 72 N N)) (b "|" 75 (b "{" 74 N N) (b "}" 76 N N)))))
where b s n = let bs = BS.pack s
in B bs (TS bs n)
unescapeInitTail :: BS.ByteString -> BS.ByteString
unescapeInitTail = BS.pack . unesc . tail . BS.unpack 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 !Int !Int !Int
deriving (Eq, Show,Ord)
alexStartPos :: Posn
alexStartPos = Pn 0 1 1
alexMove :: Posn -> Char -> Posn
alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
type AlexInput = (Posn, -- current position,
Char, -- previous char
BS.ByteString) -- current input string
tokens :: BS.ByteString -> [Token]
tokens str = go (alexStartPos, '\n', str)
where
go :: AlexInput -> [Token]
go inp@(pos, _, str) =
case alexScan inp 0 of
AlexEOF -> []
AlexError (pos, _, _) -> [Err pos]
AlexSkip inp' len -> go inp'
AlexToken inp' len act -> act pos (BS.take len str) : (go inp')
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p, _, s) =
case BS.uncons s of
Nothing -> Nothing
Just (c,s) ->
let p' = alexMove p c
in p' `seq` Just (c, (p', c, s))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p, c, s) = c
}

3660
src/GF/Source/ParGF.hs
View File

File diff suppressed because one or more lines are too long

643
src/GF/Source/ParGF.y
View File

@@ -1,643 +0,0 @@
-- This Happy file was machine-generated by the BNF converter
{
{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
module GF.Source.ParGF where
import GF.Source.AbsGF
import GF.Source.LexGF
import GF.Data.ErrM
import qualified Data.ByteString.Char8 as BS
}
%name pGrammar Grammar
%name pModDef ModDef
%name pOldGrammar OldGrammar
%partial pModHeader ModHeader
%name pExp Exp
-- no lexer declaration
%monad { Err } { thenM } { returnM }
%tokentype { Token }
%token
'!' { PT _ (TS _ 1) }
'#' { PT _ (TS _ 2) }
'$' { PT _ (TS _ 3) }
'%' { PT _ (TS _ 4) }
'(' { PT _ (TS _ 5) }
')' { PT _ (TS _ 6) }
'*' { PT _ (TS _ 7) }
'**' { PT _ (TS _ 8) }
'+' { PT _ (TS _ 9) }
'++' { PT _ (TS _ 10) }
',' { PT _ (TS _ 11) }
'-' { PT _ (TS _ 12) }
'->' { PT _ (TS _ 13) }
'.' { PT _ (TS _ 14) }
'/' { PT _ (TS _ 15) }
':' { PT _ (TS _ 16) }
';' { PT _ (TS _ 17) }
'<' { PT _ (TS _ 18) }
'=' { PT _ (TS _ 19) }
'=>' { PT _ (TS _ 20) }
'>' { PT _ (TS _ 21) }
'?' { PT _ (TS _ 22) }
'@' { PT _ (TS _ 23) }
'Lin' { PT _ (TS _ 24) }
'PType' { PT _ (TS _ 25) }
'Str' { PT _ (TS _ 26) }
'Strs' { PT _ (TS _ 27) }
'Tok' { PT _ (TS _ 28) }
'Type' { PT _ (TS _ 29) }
'[' { PT _ (TS _ 30) }
'\\' { PT _ (TS _ 31) }
']' { PT _ (TS _ 32) }
'_' { PT _ (TS _ 33) }
'abstract' { PT _ (TS _ 34) }
'case' { PT _ (TS _ 35) }
'cat' { PT _ (TS _ 36) }
'concrete' { PT _ (TS _ 37) }
'data' { PT _ (TS _ 38) }
'def' { PT _ (TS _ 39) }
'flags' { PT _ (TS _ 40) }
'fn' { PT _ (TS _ 41) }
'fun' { PT _ (TS _ 42) }
'grammar' { PT _ (TS _ 43) }
'in' { PT _ (TS _ 44) }
'include' { PT _ (TS _ 45) }
'incomplete' { PT _ (TS _ 46) }
'instance' { PT _ (TS _ 47) }
'interface' { PT _ (TS _ 48) }
'let' { PT _ (TS _ 49) }
'lin' { PT _ (TS _ 50) }
'lincat' { PT _ (TS _ 51) }
'lindef' { PT _ (TS _ 52) }
'lintype' { PT _ (TS _ 53) }
'of' { PT _ (TS _ 54) }
'open' { PT _ (TS _ 55) }
'oper' { PT _ (TS _ 56) }
'out' { PT _ (TS _ 57) }
'package' { PT _ (TS _ 58) }
'param' { PT _ (TS _ 59) }
'pattern' { PT _ (TS _ 60) }
'pre' { PT _ (TS _ 61) }
'printname' { PT _ (TS _ 62) }
'resource' { PT _ (TS _ 63) }
'reuse' { PT _ (TS _ 64) }
'strs' { PT _ (TS _ 65) }
'table' { PT _ (TS _ 66) }
'tokenizer' { PT _ (TS _ 67) }
'transfer' { PT _ (TS _ 68) }
'union' { PT _ (TS _ 69) }
'var' { PT _ (TS _ 70) }
'variants' { PT _ (TS _ 71) }
'where' { PT _ (TS _ 72) }
'with' { PT _ (TS _ 73) }
'{' { PT _ (TS _ 74) }
'|' { PT _ (TS _ 75) }
'}' { PT _ (TS _ 76) }
L_integ { PT _ (TI $$) }
L_quoted { PT _ (TL $$) }
L_doubl { PT _ (TD $$) }
L_LString { PT _ (T_LString $$) }
L_PIdent { PT _ (T_PIdent _) }
L_err { _ }
%%
Integer :: { Integer } : L_integ { (read (BS.unpack $1)) :: Integer }
String :: { String } : L_quoted { BS.unpack $1 }
Double :: { Double } : L_doubl { (read (BS.unpack $1)) :: Double }
LString :: { LString} : L_LString { LString ($1)}
PIdent :: { PIdent} : L_PIdent { PIdent (mkPosToken $1)}
Grammar :: { Grammar }
Grammar : ListModDef { Gr (reverse $1) }
ListModDef :: { [ModDef] }
ListModDef : {- empty -} { [] }
| ListModDef ModDef { flip (:) $1 $2 }
ModDef :: { ModDef }
ModDef : ModDef ';' { $1 }
| 'grammar' PIdent '=' '{' 'abstract' '=' PIdent ';' ListConcSpec '}' { MMain $2 $7 $9 }
| ComplMod ModType '=' ModBody { MModule $1 $2 $4 }
ConcSpec :: { ConcSpec }
ConcSpec : PIdent '=' ConcExp { ConcSpec $1 $3 }
ListConcSpec :: { [ConcSpec] }
ListConcSpec : {- empty -} { [] }
| ConcSpec { (:[]) $1 }
| ConcSpec ';' ListConcSpec { (:) $1 $3 }
ConcExp :: { ConcExp }
ConcExp : PIdent ListTransfer { ConcExp $1 (reverse $2) }
ListTransfer :: { [Transfer] }
ListTransfer : {- empty -} { [] }
| ListTransfer Transfer { flip (:) $1 $2 }
Transfer :: { Transfer }
Transfer : '(' 'transfer' 'in' Open ')' { TransferIn $4 }
| '(' 'transfer' 'out' Open ')' { TransferOut $4 }
ModHeader :: { ModHeader }
ModHeader : ComplMod ModType '=' ModHeaderBody { MModule2 $1 $2 $4 }
ModHeaderBody :: { ModHeaderBody }
ModHeaderBody : Extend Opens { MBody2 $1 $2 }
| ListIncluded { MNoBody2 $1 }
| Included 'with' ListOpen { MWith2 $1 $3 }
| Included 'with' ListOpen '**' Opens { MWithBody2 $1 $3 $5 }
| ListIncluded '**' Included 'with' ListOpen { MWithE2 $1 $3 $5 }
| ListIncluded '**' Included 'with' ListOpen '**' Opens { MWithEBody2 $1 $3 $5 $7 }
| 'reuse' PIdent { MReuse2 $2 }
| 'union' ListIncluded { MUnion2 $2 }
ModType :: { ModType }
ModType : 'abstract' PIdent { MTAbstract $2 }
| 'resource' PIdent { MTResource $2 }
| 'interface' PIdent { MTInterface $2 }
| 'concrete' PIdent 'of' PIdent { MTConcrete $2 $4 }
| 'instance' PIdent 'of' PIdent { MTInstance $2 $4 }
| 'transfer' PIdent ':' Open '->' Open { MTTransfer $2 $4 $6 }
ModBody :: { ModBody }
ModBody : Extend Opens '{' ListTopDef '}' { MBody $1 $2 (reverse $4) }
| ListIncluded { MNoBody $1 }
| Included 'with' ListOpen { MWith $1 $3 }
| Included 'with' ListOpen '**' Opens '{' ListTopDef '}' { MWithBody $1 $3 $5 (reverse $7) }
| ListIncluded '**' Included 'with' ListOpen { MWithE $1 $3 $5 }
| ListIncluded '**' Included 'with' ListOpen '**' Opens '{' ListTopDef '}' { MWithEBody $1 $3 $5 $7 (reverse $9) }
| 'reuse' PIdent { MReuse $2 }
| 'union' ListIncluded { MUnion $2 }
ListTopDef :: { [TopDef] }
ListTopDef : {- empty -} { [] }
| ListTopDef TopDef { flip (:) $1 $2 }
Extend :: { Extend }
Extend : ListIncluded '**' { Ext $1 }
| {- empty -} { NoExt }
ListOpen :: { [Open] }
ListOpen : {- empty -} { [] }
| Open { (:[]) $1 }
| Open ',' ListOpen { (:) $1 $3 }
Opens :: { Opens }
Opens : {- empty -} { NoOpens }
| 'open' ListOpen 'in' { OpenIn $2 }
Open :: { Open }
Open : PIdent { OName $1 }
| '(' QualOpen PIdent ')' { OQualQO $2 $3 }
| '(' QualOpen PIdent '=' PIdent ')' { OQual $2 $3 $5 }
ComplMod :: { ComplMod }
ComplMod : {- empty -} { CMCompl }
| 'incomplete' { CMIncompl }
QualOpen :: { QualOpen }
QualOpen : {- empty -} { QOCompl }
| 'incomplete' { QOIncompl }
| 'interface' { QOInterface }
ListIncluded :: { [Included] }
ListIncluded : {- empty -} { [] }
| Included { (:[]) $1 }
| Included ',' ListIncluded { (:) $1 $3 }
Included :: { Included }
Included : PIdent { IAll $1 }
| PIdent '[' ListPIdent ']' { ISome $1 $3 }
| PIdent '-' '[' ListPIdent ']' { IMinus $1 $4 }
Def :: { Def }
Def : ListName ':' Exp { DDecl $1 $3 }
| ListName '=' Exp { DDef $1 $3 }
| Name ListPatt '=' Exp { DPatt $1 $2 $4 }
| ListName ':' Exp '=' Exp { DFull $1 $3 $5 }
TopDef :: { TopDef }
TopDef : 'cat' ListCatDef { DefCat $2 }
| 'fun' ListFunDef { DefFun $2 }
| 'data' ListFunDef { DefFunData $2 }
| 'def' ListDef { DefDef $2 }
| 'data' ListDataDef { DefData $2 }
| 'transfer' ListDef { DefTrans $2 }
| 'param' ListParDef { DefPar $2 }
| 'oper' ListDef { DefOper $2 }
| 'lincat' ListPrintDef { DefLincat $2 }
| 'lindef' ListDef { DefLindef $2 }
| 'lin' ListDef { DefLin $2 }
| 'printname' 'cat' ListPrintDef { DefPrintCat $3 }
| 'printname' 'fun' ListPrintDef { DefPrintFun $3 }
| 'flags' ListFlagDef { DefFlag $2 }
| 'printname' ListPrintDef { DefPrintOld $2 }
| 'lintype' ListDef { DefLintype $2 }
| 'pattern' ListDef { DefPattern $2 }
| 'package' PIdent '=' '{' ListTopDef '}' ';' { DefPackage $2 (reverse $5) }
| 'var' ListDef { DefVars $2 }
| 'tokenizer' PIdent ';' { DefTokenizer $2 }
CatDef :: { CatDef }
CatDef : PIdent ListDDecl { SimpleCatDef $1 (reverse $2) }
| '[' PIdent ListDDecl ']' { ListCatDef $2 (reverse $3) }
| '[' PIdent ListDDecl ']' '{' Integer '}' { ListSizeCatDef $2 (reverse $3) $6 }
FunDef :: { FunDef }
FunDef : ListPIdent ':' Exp { FunDef $1 $3 }
DataDef :: { DataDef }
DataDef : PIdent '=' ListDataConstr { DataDef $1 $3 }
DataConstr :: { DataConstr }
DataConstr : PIdent { DataId $1 }
| PIdent '.' PIdent { DataQId $1 $3 }
ListDataConstr :: { [DataConstr] }
ListDataConstr : {- empty -} { [] }
| DataConstr { (:[]) $1 }
| DataConstr '|' ListDataConstr { (:) $1 $3 }
ParDef :: { ParDef }
ParDef : PIdent '=' ListParConstr { ParDefDir $1 $3 }
| PIdent '=' '(' 'in' PIdent ')' { ParDefIndir $1 $5 }
| PIdent { ParDefAbs $1 }
ParConstr :: { ParConstr }
ParConstr : PIdent ListDDecl { ParConstr $1 (reverse $2) }
PrintDef :: { PrintDef }
PrintDef : ListName '=' Exp { PrintDef $1 $3 }
FlagDef :: { FlagDef }
FlagDef : PIdent '=' PIdent { FlagDef $1 $3 }
ListDef :: { [Def] }
ListDef : Def ';' { (:[]) $1 }
| Def ';' ListDef { (:) $1 $3 }
ListCatDef :: { [CatDef] }
ListCatDef : CatDef ';' { (:[]) $1 }
| CatDef ';' ListCatDef { (:) $1 $3 }
ListFunDef :: { [FunDef] }
ListFunDef : FunDef ';' { (:[]) $1 }
| FunDef ';' ListFunDef { (:) $1 $3 }
ListDataDef :: { [DataDef] }
ListDataDef : DataDef ';' { (:[]) $1 }
| DataDef ';' ListDataDef { (:) $1 $3 }
ListParDef :: { [ParDef] }
ListParDef : ParDef ';' { (:[]) $1 }
| ParDef ';' ListParDef { (:) $1 $3 }
ListPrintDef :: { [PrintDef] }
ListPrintDef : PrintDef ';' { (:[]) $1 }
| PrintDef ';' ListPrintDef { (:) $1 $3 }
ListFlagDef :: { [FlagDef] }
ListFlagDef : FlagDef ';' { (:[]) $1 }
| FlagDef ';' ListFlagDef { (:) $1 $3 }
ListParConstr :: { [ParConstr] }
ListParConstr : {- empty -} { [] }
| ParConstr { (:[]) $1 }
| ParConstr '|' ListParConstr { (:) $1 $3 }
ListPIdent :: { [PIdent] }
ListPIdent : PIdent { (:[]) $1 }
| PIdent ',' ListPIdent { (:) $1 $3 }
Name :: { Name }
Name : PIdent { IdentName $1 }
| '[' PIdent ']' { ListName $2 }
ListName :: { [Name] }
ListName : Name { (:[]) $1 }
| Name ',' ListName { (:) $1 $3 }
LocDef :: { LocDef }
LocDef : ListPIdent ':' Exp { LDDecl $1 $3 }
| ListPIdent '=' Exp { LDDef $1 $3 }
| ListPIdent ':' Exp '=' Exp { LDFull $1 $3 $5 }
ListLocDef :: { [LocDef] }
ListLocDef : {- empty -} { [] }
| LocDef { (:[]) $1 }
| LocDef ';' ListLocDef { (:) $1 $3 }
Exp6 :: { Exp }
Exp6 : PIdent { EIdent $1 }
| '{' PIdent '}' { EConstr $2 }
| '%' PIdent '%' { ECons $2 }
| Sort { ESort $1 }
| String { EString $1 }
| Integer { EInt $1 }
| Double { EFloat $1 }
| '?' { EMeta }
| '[' ']' { EEmpty }
| 'data' { EData }
| '[' PIdent Exps ']' { EList $2 $3 }
| '[' String ']' { EStrings $2 }
| '{' ListLocDef '}' { ERecord $2 }
| '<' ListTupleComp '>' { ETuple $2 }
| '(' 'in' PIdent ')' { EIndir $3 }
| '<' Exp ':' Exp '>' { ETyped $2 $4 }
| '(' Exp ')' { $2 }
| LString { ELString $1 }
Exp5 :: { Exp }
Exp5 : Exp5 '.' Label { EProj $1 $3 }
| '{' PIdent '.' PIdent '}' { EQConstr $2 $4 }
| '%' PIdent '.' PIdent { EQCons $2 $4 }
| Exp6 { $1 }
Exp4 :: { Exp }
Exp4 : Exp4 Exp5 { EApp $1 $2 }
| 'table' '{' ListCase '}' { ETable $3 }
| 'table' Exp6 '{' ListCase '}' { ETTable $2 $4 }
| 'table' Exp6 '[' ListExp ']' { EVTable $2 $4 }
| 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 }
| 'variants' '{' ListExp '}' { EVariants $3 }
| 'pre' '{' Exp ';' ListAltern '}' { EPre $3 $5 }
| 'strs' '{' ListExp '}' { EStrs $3 }
| PIdent '@' Exp6 { EConAt $1 $3 }
| '#' Patt2 { EPatt $2 }
| 'pattern' Exp5 { EPattType $2 }
| Exp5 { $1 }
| 'Lin' PIdent { ELin $2 }
Exp3 :: { Exp }
Exp3 : Exp3 '!' Exp4 { ESelect $1 $3 }
| Exp3 '*' Exp4 { ETupTyp $1 $3 }
| Exp3 '**' Exp4 { EExtend $1 $3 }
| Exp4 { $1 }
Exp2 :: { Exp }
Exp2 : Exp3 '+' Exp2 { EGlue $1 $3 }
| Exp3 { $1 }
Exp1 :: { Exp }
Exp1 : Exp2 '++' Exp1 { EConcat $1 $3 }
| Exp2 { $1 }
Exp :: { Exp }
Exp : Exp1 '|' Exp { EVariant $1 $3 }
| '\\' ListBind '->' Exp { EAbstr $2 $4 }
| '\\' '\\' ListBind '=>' Exp { ECTable $3 $5 }
| Decl '->' Exp { EProd $1 $3 }
| Exp3 '=>' Exp { ETType $1 $3 }
| 'let' '{' ListLocDef '}' 'in' Exp { ELet $3 $6 }
| 'let' ListLocDef 'in' Exp { ELetb $2 $4 }
| Exp3 'where' '{' ListLocDef '}' { EWhere $1 $4 }
| 'fn' '{' ListEquation '}' { EEqs $3 }
| 'in' Exp5 String { EExample $2 $3 }
| Exp1 { $1 }
ListExp :: { [Exp] }
ListExp : {- empty -} { [] }
| Exp { (:[]) $1 }
| Exp ';' ListExp { (:) $1 $3 }
Exps :: { Exps }
Exps : {- empty -} { NilExp }
| Exp6 Exps { ConsExp $1 $2 }
Patt2 :: { Patt }
Patt2 : '?' { PChar }
| '[' String ']' { PChars $2 }
| '#' PIdent { PMacro $2 }
| '#' PIdent '.' PIdent { PM $2 $4 }
| '_' { PW }
| PIdent { PV $1 }
| '{' PIdent '}' { PCon $2 }
| PIdent '.' PIdent { PQ $1 $3 }
| Integer { PInt $1 }
| Double { PFloat $1 }
| String { PStr $1 }
| '{' ListPattAss '}' { PR $2 }
| '<' ListPattTupleComp '>' { PTup $2 }
| '(' Patt ')' { $2 }
Patt1 :: { Patt }
Patt1 : PIdent ListPatt { PC $1 $2 }
| PIdent '.' PIdent ListPatt { PQC $1 $3 $4 }
| Patt2 '*' { PRep $1 }
| PIdent '@' Patt2 { PAs $1 $3 }
| '-' Patt2 { PNeg $2 }
| Patt2 { $1 }
Patt :: { Patt }
Patt : Patt '|' Patt1 { PDisj $1 $3 }
| Patt '+' Patt1 { PSeq $1 $3 }
| Patt1 { $1 }
PattAss :: { PattAss }
PattAss : ListPIdent '=' Patt { PA $1 $3 }
Label :: { Label }
Label : PIdent { LIdent $1 }
| '$' Integer { LVar $2 }
Sort :: { Sort }
Sort : 'Type' { Sort_Type }
| 'PType' { Sort_PType }
| 'Tok' { Sort_Tok }
| 'Str' { Sort_Str }
| 'Strs' { Sort_Strs }
ListPattAss :: { [PattAss] }
ListPattAss : {- empty -} { [] }
| PattAss { (:[]) $1 }
| PattAss ';' ListPattAss { (:) $1 $3 }
ListPatt :: { [Patt] }
ListPatt : Patt2 { (:[]) $1 }
| Patt2 ListPatt { (:) $1 $2 }
Bind :: { Bind }
Bind : PIdent { BIdent $1 }
| '_' { BWild }
ListBind :: { [Bind] }
ListBind : {- empty -} { [] }
| Bind { (:[]) $1 }
| Bind ',' ListBind { (:) $1 $3 }
Decl :: { Decl }
Decl : '(' ListBind ':' Exp ')' { DDec $2 $4 }
| Exp4 { DExp $1 }
TupleComp :: { TupleComp }
TupleComp : Exp { TComp $1 }
PattTupleComp :: { PattTupleComp }
PattTupleComp : Patt { PTComp $1 }
ListTupleComp :: { [TupleComp] }
ListTupleComp : {- empty -} { [] }
| TupleComp { (:[]) $1 }
| TupleComp ',' ListTupleComp { (:) $1 $3 }
ListPattTupleComp :: { [PattTupleComp] }
ListPattTupleComp : {- empty -} { [] }
| PattTupleComp { (:[]) $1 }
| PattTupleComp ',' ListPattTupleComp { (:) $1 $3 }
Case :: { Case }
Case : Patt '=>' Exp { Case $1 $3 }
ListCase :: { [Case] }
ListCase : Case { (:[]) $1 }
| Case ';' ListCase { (:) $1 $3 }
Equation :: { Equation }
Equation : ListPatt '->' Exp { Equ $1 $3 }
ListEquation :: { [Equation] }
ListEquation : {- empty -} { [] }
| Equation { (:[]) $1 }
| Equation ';' ListEquation { (:) $1 $3 }
Altern :: { Altern }
Altern : Exp '/' Exp { Alt $1 $3 }
ListAltern :: { [Altern] }
ListAltern : {- empty -} { [] }
| Altern { (:[]) $1 }
| Altern ';' ListAltern { (:) $1 $3 }
DDecl :: { DDecl }
DDecl : '(' ListBind ':' Exp ')' { DDDec $2 $4 }
| Exp6 { DDExp $1 }
ListDDecl :: { [DDecl] }
ListDDecl : {- empty -} { [] }
| ListDDecl DDecl { flip (:) $1 $2 }
OldGrammar :: { OldGrammar }
OldGrammar : Include ListTopDef { OldGr $1 (reverse $2) }
Include :: { Include }
Include : {- empty -} { NoIncl }
| 'include' ListFileName { Incl $2 }
FileName :: { FileName }
FileName : String { FString $1 }
| PIdent { FIdent $1 }
| '/' FileName { FSlash $2 }
| '.' FileName { FDot $2 }
| '-' FileName { FMinus $2 }
| PIdent FileName { FAddId $1 $2 }
ListFileName :: { [FileName] }
ListFileName : FileName ';' { (:[]) $1 }
| FileName ';' ListFileName { (:) $1 $3 }
{
returnM :: a -> Err a
returnM = return
thenM :: Err a -> (a -> Err b) -> Err b
thenM = (>>=)
happyError :: [Token] -> Err a
happyError ts =
Bad $ "syntax error at " ++ tokenPos ts ++
case ts of
[] -> []
[Err _] -> " due to lexer error"
_ -> " before " ++ unwords (map (BS.unpack . prToken) (take 4 ts))
myLexer = tokens
}

13
src/GFI.hs
View File

@@ -7,7 +7,9 @@ import GF.Command.Commands
import GF.Command.Abstract import GF.Command.Abstract
import GF.Command.Parse import GF.Command.Parse
import GF.Data.ErrM import GF.Data.ErrM
import GF.Grammar.API -- for cc command import GF.Grammar.API
import GF.Grammar.Lexer
import GF.Grammar.Parser
import GF.Infra.Dependencies import GF.Infra.Dependencies
import GF.Infra.UseIO import GF.Infra.UseIO
import GF.Infra.Option import GF.Infra.Option
@@ -24,6 +26,7 @@ import Data.Char
import Data.Maybe import Data.Maybe
import Data.List(isPrefixOf) import Data.List(isPrefixOf)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import qualified Text.ParserCombinators.ReadP as RP import qualified Text.ParserCombinators.ReadP as RP
import System.Cmd import System.Cmd
import System.CPUTime import System.CPUTime
@@ -104,9 +107,11 @@ loop opts gfenv0 = do
pOpts style q ws = (style,q,unwords ws) pOpts style q ws = (style,q,unwords ws)
(style,q,s) = pOpts TermPrintDefault Qualified ws (style,q,s) = pOpts TermPrintDefault Qualified ws
case pTerm s >>= checkTerm sgr >>= computeTerm sgr of case runP pExp (BS.pack s) of
Ok x -> putStrLn $ enc (showTerm style q x) Left (_,msg) -> putStrLn msg
Bad s -> putStrLn $ enc s Right t -> case checkTerm sgr t >>= computeTerm sgr of
Ok x -> putStrLn $ enc (showTerm style q x)
Bad s -> putStrLn $ enc s
loopNewCPU gfenv loopNewCPU gfenv
"dg":ws -> do "dg":ws -> do
writeFile "_gfdepgraph.dot" (depGraph sgr) writeFile "_gfdepgraph.dot" (depGraph sgr)