GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Added support for cf and ebnf formats

Browse Source
This commit is contained in:
aarne
2004-03-31 12:30:34 +00:00
parent 6719aedde3
commit 3f9b4e7855
17 changed files with 280 additions and 31 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/GF/API/IOGrammar.hs
View File

@@ -39,7 +39,11 @@ shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState
shellStateFromFiles opts st file = case fileSuffix file of
"gfcm" -> do
(_,_,cgr) <- compileOne opts (compileEnvShSt st []) file
ioeErr $ updateShellState opts st (cgr,(emptyMGrammar,[]))
ioeErr $ updateShellState opts st (cgr,(emptyMGrammar,[]))
s | elem s ["cf","ebnf"] -> do
let osb = addOptions (options [beVerbose]) opts
grts <- compileModule osb st file
ioeErr $ updateShellState opts st grts
_ -> do
let osb = if oElem showOld opts
then addOptions (options [beVerbose]) opts -- for old, no emit

4
src/GF/CF/CFtoGrammar.hs
View File

@@ -40,9 +40,9 @@ cf2rule (fun, (cat, items)) = (def,ldef) where
ldef = (f, CncFun
Nothing
(yes (mkAbs (map fst args)
(mkRecord linLabel [foldconcat (map mkIt args0)])))
(mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))
nope)
mkIt (v, CFNonterm _) = P (Vr v) (linLabel 0)
mkIt (v, CFNonterm _) = P (Vr v) theLinLabel
mkIt (_, CFTerm (RegAlts [a])) = K a
mkIt _ = K "" --- regexp not recognized in input CF ; use EBNF for this
foldconcat [] = K ""

177
src/GF/CF/EBNF.hs Normal file
View File

@@ -0,0 +1,177 @@
module EBNF where
import Operations
import Parsers
import Comments
import CF
import CFIdent
import Grammar
import PrGrammar
import CFtoGrammar
import qualified AbsGF as A
import List (nub, partition)
-- AR 18/4/2000 - 31/3/2004
-- Extended BNF grammar with token type a
-- put a = String for simple applications
type EBNF = [ERule]
type ERule = (ECat, ERHS)
type ECat = (String,[Int])
type ETok = String
ebnfID = "EBNF" ---- make this parametric!
data ERHS =
ETerm ETok
| ENonTerm ECat
| ESeq ERHS ERHS
| EAlt ERHS ERHS
| EStar ERHS
| EPlus ERHS
| EOpt ERHS
| EEmpty
type CFRHS = [CFItem]
type CFJustRule = (CFCat, CFRHS)
ebnf2gf :: EBNF -> [A.TopDef]
ebnf2gf = cf2grammar . rules2CF . ebnf2cf
ebnf2cf :: EBNF -> [CFRule]
ebnf2cf ebnf = [(mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
mkCFF i (CFCat (_,c), _) = string2CFFun ebnfID ("Mk" ++ prt c ++ "_" ++ show i)
normEBNF :: EBNF -> [CFJustRule]
normEBNF erules = let
erules1 = [normERule ([i],r) | (i,r) <- zip [0..] erules]
erules2 = erules1 ---refreshECats erules1 --- this seems to be just bad !
erules3 = concat (map pickERules erules2)
erules4 = nubERules erules3
in [(mkCFCatE cat, map eitem2cfitem its) | (cat,itss) <- erules3, its <- itss]
refreshECats :: [NormERule] -> [NormERule]
refreshECats rules = [recas [i] rule | (i,rule) <- zip [0..] rules] where
recas ii (cat,its) = (updECat ii cat, [recss ii 0 s | s <- its])
recss ii n [] = []
recss ii n (s:ss) = recit (ii ++ [n]) s : recss ii (n+1) ss
recit ii it = case it of
EINonTerm cat -> EINonTerm (updECat ii cat)
EIStar (cat,t) -> EIStar (updECat ii cat, [recss ii 0 s | s <- t])
EIPlus (cat,t) -> EIPlus (updECat ii cat, [recss ii 0 s | s <- t])
EIOpt (cat,t) -> EIOpt (updECat ii cat, [recss ii 0 s | s <- t])
_ -> it
pickERules :: NormERule -> [NormERule]
pickERules rule@(cat,alts) = rule : concat (map pics (concat alts)) where
pics it = case it of
EIStar ru@(cat,t) -> mkEStarRules cat ++ pickERules ru
EIPlus ru@(cat,t) -> mkEPlusRules cat ++ pickERules ru
EIOpt ru@(cat,t) -> mkEOptRules cat ++ pickERules ru
_ -> []
mkEStarRules cat = [(cat', [[],[EINonTerm cat, EINonTerm cat']])]
where cat' = mkNewECat cat "Star"
mkEPlusRules cat = [(cat', [[EINonTerm cat],[EINonTerm cat, EINonTerm cat']])]
where cat' = mkNewECat cat "Plus"
mkEOptRules cat = [(cat', [[],[EINonTerm cat]])]
where cat' = mkNewECat cat "Opt"
nubERules :: [NormERule] -> [NormERule]
nubERules rules = nub optim where
optim = map (substERules (map mkSubst replaces)) irreducibles
(replaces,irreducibles) = partition reducible rules
reducible (cat,[items]) = isNewCat cat && all isOldIt items
reducible _ = False
isNewCat (_,ints) = ints == []
isOldIt (EITerm _) = True
isOldIt (EINonTerm cat) = not (isNewCat cat)
isOldIt _ = False
mkSubst (cat,its) = (cat, head its) -- def of reducible: its must be singleton
--- the optimization assumes each cat has at most one EBNF rule.
substERules :: [(ECat,[EItem])] -> NormERule -> NormERule
substERules g (cat,itss) = (cat, map sub itss) where
sub [] = []
sub (i@(EINonTerm cat') : ii) = case lookup cat g of
Just its -> its ++ sub ii
_ -> i : sub ii
sub (EIStar r : ii) = EIStar (substERules g r) : ii
sub (EIPlus r : ii) = EIPlus (substERules g r) : ii
sub (EIOpt r : ii) = EIOpt (substERules g r) : ii
eitem2cfitem :: EItem -> CFItem
eitem2cfitem it = case it of
EITerm a -> atomCFTerm $ tS a
EINonTerm cat -> CFNonterm (mkCFCatE cat)
EIStar (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Star"))
EIPlus (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Plus"))
EIOpt (cat,_) -> CFNonterm (mkCFCatE (mkNewECat cat "Opt"))
type NormERule = (ECat,[[EItem]]) -- disjunction of sequences of items
data EItem =
EITerm String
| EINonTerm ECat
| EIStar NormERule
| EIPlus NormERule
| EIOpt NormERule
deriving Eq
normERule :: ([Int],ERule) -> NormERule
normERule (ii,(cat,rhs)) =
(cat,[map (mkEItem (ii ++ [i])) r' | (i,r') <- zip [0..] (disjNorm rhs)]) where
disjNorm r = case r of
ESeq r1 r2 -> [x ++ y | x <- disjNorm r1, y <- disjNorm r2]
EAlt r1 r2 -> disjNorm r1 ++ disjNorm r2
EEmpty -> [[]]
_ -> [[r]]
mkEItem :: [Int] -> ERHS -> EItem
mkEItem ii rhs = case rhs of
ETerm a -> EITerm a
ENonTerm cat -> EINonTerm cat
EStar r -> EIStar (normERule (ii,(mkECat ii, r)))
EPlus r -> EIPlus (normERule (ii,(mkECat ii, r)))
EOpt r -> EIOpt (normERule (ii,(mkECat ii, r)))
_ -> EINonTerm ("?????",[])
-- _ -> error "should not happen in ebnf" ---
mkECat ints = ("C", ints)
prECat (c,[]) = c
prECat (c,ints) = c ++ "_" ++ prTList "_" (map show ints)
mkCFCatE :: ECat -> CFCat
mkCFCatE = string2CFCat ebnfID . prECat
updECat _ (c,[]) = (c,[])
updECat ii (c,_) = (c,ii)
mkNewECat (c,ii) str = (c ++ str,ii)
------ parser for EBNF grammars
pEBNFasGrammar :: String -> Err [A.TopDef]
pEBNFasGrammar = parseResultErr (pEBNF *** ebnf2gf) . remComments
pEBNF :: Parser Char EBNF
pEBNF = longestOfMany (pJ pERule)
pERule :: Parser Char ERule
pERule = pECat ... pJ (literals ":=" ||| literals "::=") +.. pERHS 0 ..+ jL ";"
pERHS :: Int -> Parser Char ERHS
pERHS 0 = pTList "|" (pERHS 1) *** foldr1 EAlt
pERHS 1 = longestOfMany (pJ (pERHS 2)) *** foldr ESeq EEmpty
pERHS 2 = pERHS 3 ... pJ pUnaryEOp *** (\ (a,f) -> f a)
pERHS 3 = pQuotedString *** ETerm
||| pECat *** ENonTerm ||| pParenth (pERHS 0)
pUnaryEOp :: Parser Char (ERHS -> ERHS)
pUnaryEOp =
lits "*" <<< EStar ||| lits "+" <<< EPlus ||| lits "?" <<< EOpt ||| succeed id
pECat = pIdent *** (\c -> (c,[]))

2
src/GF/CF/PPrCF.hs
View File

@@ -52,7 +52,7 @@ getCFRule :: String -> String -> Err CFRule
getCFRule mo s = getcf (wrds s) where
getcf ww | length ww > 2 && ww !! 2 `elem` ["->", "::="] =
Ok (string2CFFun mo (init fun), (string2CFCat mo cat, map mkIt its)) where
fun : cat : _ : its = words s
fun : cat : _ : its = ww
mkIt ('"':w@(_:_)) = atomCFTerm (string2CFTok (init w))
mkIt w = CFNonterm (string2CFCat mo w)
getcf _ = Bad (" invalid rule:" +++ s)

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

@@ -269,6 +269,8 @@ inferLType gr trm = case trm of
prtFail "cannot infer type of constant" trm
]
QC m ident | m==cPredef -> termWith trm $ checkErr (typPredefined ident)
QC m ident -> checks [
termWith trm $ checkErr (lookupResType gr m ident)
,
@@ -426,7 +428,7 @@ inferLType gr trm = case trm of
_ -> False
inferPatt p = case p of
PP q c ps -> checkErr $ lookupResType gr q c >>= valTypeCnc
PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc
_ -> infer (patt2term p) >>= return . snd
checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type)
@@ -560,7 +562,7 @@ checkLType env trm typ0 = do
pattContext :: LTEnv -> Type -> Patt -> Check Context
pattContext env typ p = case p of
PV x -> return [(x,typ)]
PP q c ps -> do
PP q c ps | q /= cPredef -> do
t <- checkErr $ lookupResType cnc q c
(cont,v) <- checkErr $ typeFormCnc t
checkCond ("wrong number of arguments for constructor in" +++ prt p)

14
src/GF/Compile/Compile.hs
View File

@@ -56,18 +56,22 @@ batchCompileOld f = compileOld defOpts f
compileModule :: Options -> ShellState -> FilePath ->
IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))
compileModule opts st0 file | oElem showOld opts || fileSuffix file == "cf" = do
compileModule opts st0 file | oElem showOld opts ||
elem suff ["cf","ebnf"] = do
let putp = putPointE opts
let path = [] ----
grammar1 <- if fileSuffix file == "cf"
then putp ("- parsing cf" +++ file) $ getCFGrammar opts file
else putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
grammar1 <- if suff == "cf"
then putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file
else if suff == "ebnf"
then putp ("- parsing" +++ suff +++ file) $ getEBNFGrammar opts file
else putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
let mods = modules grammar1
let env = compileEnvShSt st0 []
(_,sgr,cgr) <- foldM (comp putp path) env mods
return $ (reverseModules cgr, -- to preserve dependency order
(reverseModules sgr,[]))
where
suff = fileSuffix file
comp putp path env sm0 = do
(k',sm) <- makeSourceModule opts env sm0
cm <- putp " generating code... " $ generateModuleCode opts path sm
@@ -87,7 +91,7 @@ compileModule opts1 st0 file = do
let st = st0 --- if useFileOpt then emptyShellState else st0
let rfs = readFiles st
let file' = if useFileOpt then justFileName file else file -- to find file itself
files <- getAllFiles ps rfs file'
files <- getAllFiles opts ps rfs file'
ioeIO $ putStrLn $ "files to read:" +++ show files ----
let names = map justModuleName files
ioeIO $ putStrLn $ "modules to include:" +++ show names ----

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

@@ -18,6 +18,7 @@ import qualified LexGF as L
import PPrCF
import CFtoGrammar
import EBNF
import ReadFiles ----
@@ -86,9 +87,23 @@ oldLexer = map change . L.tokens where
getCFGrammar :: Options -> FilePath -> IOE SourceGrammar
getCFGrammar opts file = do
let mo = takeWhile (/='-') file
let mo = takeWhile (/='.') file
s <- ioeIO $ readFileIf file
cf <- ioeErr $ pCF mo s
defs <- return $ cf2grammar cf
let g = A.OldGr A.NoIncl defs
--- let ma = justModuleName file
--- let mc = 'C':ma ---
--- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
ioeErr $ transOldGrammar opts file g
getEBNFGrammar :: Options -> FilePath -> IOE SourceGrammar
getEBNFGrammar opts file = do
let mo = takeWhile (/='.') file
s <- ioeIO $ readFileIf file
defs <- ioeErr $ pEBNFasGrammar s
let g = A.OldGr A.NoIncl defs
--- let ma = justModuleName file
--- let mc = 'C':ma ---
--- let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
ioeErr $ transOldGrammar opts file g

1
src/GF/Compile/Rename.hs
View File

@@ -62,6 +62,7 @@ renameIdentTerm env@(act,imps) t =
m <- lookupErr m' qualifs
f <- lookupTree prt c m
return $ f c
QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
QC m' c -> do
m <- lookupErr m' qualifs
f <- lookupTree prt c m

4
src/GF/Grammar/AppPredefined.hs
View File

@@ -16,8 +16,8 @@ typPredefined :: Ident -> Err Type
typPredefined c@(IC f) = case f of
"Int" -> return typePType
"PBool" -> return typePType
--- "PFalse" -> -- hidden
--- "PTrue" ->
"PFalse" -> return $ cnPredef "PBool"
"PTrue" -> return $ cnPredef "PBool"
"dp" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
"drop" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
"eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")

2
src/GF/Grammar/Macros.hs
View File

@@ -290,6 +290,8 @@ eqStrIdent = (==)
tupleLabel i = LIdent $ "p" ++ show i
linLabel i = LIdent $ "s" ++ show i
theLinLabel = LIdent "s"
tuple2record :: [Term] -> [Assign]
tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]

9
src/GF/Grammar/PrGrammar.hs
View File

@@ -68,12 +68,17 @@ prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
instance Print A.Exp where prt = C.printTree
instance Print A.Term where prt = C.printTree
instance Print A.Case where prt = C.printTree
instance Print A.Atom where prt = C.printTree
instance Print A.CType where prt = C.printTree
instance Print A.Label where prt = C.printTree
instance Print A.Module where prt = C.printTree
instance Print A.Sort where prt = C.printTree
instance Print A.Atom where
prt = C.printTree
prt_ (A.AC c) = prt_ c
prt_ (A.AD c) = prt_ c
prt_ a = prt a
instance Print A.Patt where
prt = C.printTree
prt_ = prPatt
@@ -174,7 +179,7 @@ instance Print Atom where
prt (AtV i) = prt i
prt (AtL s) = s
prt (AtI i) = show i
prt_ (AtC f) = prQIdent_ f
prt_ (AtC (_,f)) = prt f
prt_ a = prt a
prQIdent :: QIdent -> String

29
src/GF/Infra/Comments.hs Normal file
View File

@@ -0,0 +1,29 @@
module Comments where
-- comment removal : line tails prefixed by -- as well as chunks in {- ... -}
remComments :: String -> String
remComments s =
case s of
'"':s2 -> '"':pass remComments s2 -- comment marks in quotes not removed!
'{':'-':cs -> readNested cs
'-':'-':cs -> readTail cs
c:cs -> c : remComments cs
[] -> []
where
readNested t =
case t of
'"':s2 -> '"':pass readNested s2
'-':'}':cs -> remComments cs
_:cs -> readNested cs
[] -> []
readTail t =
case t of
'\n':cs -> '\n':remComments cs
_:cs -> readTail cs
[] -> []
pass f t =
case t of
'"':s2 -> '"': f s2
c:s2 -> c:pass f s2
_ -> t

22
src/GF/Infra/ReadFiles.hs
View File

@@ -27,15 +27,15 @@ import List
type ModName = String
type ModEnv = [(ModName,ModTime)]
getAllFiles :: [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
getAllFiles ps env file = do
getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
getAllFiles opts ps env file = do
-- read module headers from all files recursively
ds0 <- getImports ps file
let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0]
ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds)
-- get a topological sorting of files: returns file names --- deletes paths
-- get a topological sorting of files: returns file names --- deletes paths
ds1 <- ioeErr $ either
return
(\ms -> Bad $ "circular modules" +++
@@ -44,12 +44,15 @@ getAllFiles ps env file = do
-- associate each file name with its path --- more optimal: save paths in ds1
let paths = [(f,p) | ((f,_),p) <- ds]
let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]]
if oElem fromSource opts
then return [gfFile (prefixPathName p f) | (p,f) <- pds1]
else do
ds2 <- ioeIO $ mapM (selectFormat env) pds1
ds2 <- ioeIO $ mapM (selectFormat env) pds1
let ds4 = needCompile (map fst ds0) ds2
return ds4
let ds4 = needCompile opts (map fst ds0) ds2
return ds4
-- to decide whether to read gf or gfc, or if in env; returns full file path
@@ -77,8 +80,9 @@ selectFormat env (p,f) = do
return $ (f, (p,stat))
needCompile :: [ModuleHeader] -> [(ModName,(InitPath,CompStatus))] -> [FullPath]
needCompile headers sfiles0 = paths $ res $ mark $ iter changed where
needCompile :: Options ->
[ModuleHeader] -> [(ModName,(InitPath,CompStatus))] -> [FullPath]
needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where
deps = [(snd m,map fst ms) | (m,ms) <- headers]
typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers]
@@ -117,10 +121,12 @@ needCompile headers sfiles0 = paths $ res $ mark $ iter changed where
-- if a compilable file depends on a resource, read gfr instead of gfc/env
-- but don't read gfr if already in env (by CSEnvR)
-- Also read res if the option "retain" is present
res cs = map mkRes cs where
mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of
MTyResource | not (null [m | (m,(_,CSComp)) <- cs,
Just ms <- [lookup m allDeps], elem f ms])
|| oElem retainOpers opts
-> (f,(path,CSRes))
_ -> x
mkRes x = x

2
src/GF/Source/SourceToGrammar.hs
View File

@@ -539,6 +539,8 @@ transOldGrammar opts name0 x = case x of
(beg,rest) = span (/='.') name
(topic,lang) = case rest of -- to avoid overwriting old files
".gf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".cf" -> ("Abs" ++ beg,"Cnc" ++ beg)
".ebnf" -> ("Abs" ++ beg,"Cnc" ++ beg)
[] -> ("Abs" ++ beg,"Cnc" ++ beg)
_:s -> (beg, takeWhile (/='.') s)

7
src/HelpFile
View File

@@ -19,14 +19,15 @@ i, import: i File
.gfc canonical GF
.gfr precompiled GF resource
.gfcm multilingual canonical GF
*.ebnf Extended BNF format
.ebnf Extended BNF format
.cf Context-free (BNF) format
options:
-old old: parse in GF<2.0 format
-v verbose: give lots of messages
-s silent: don't give error messages
-opt perform branch-sharing optimization
*-src source: ignore precompiled gfc and gfr files
-src source: ignore precompiled gfc and gfr files
-retain retain operations: read resource modules (needed in comm cc)
-nocf don't build context-free grammar (thus no parser)
-nocheckcirc don't eliminate circular rules from CF
-cflexer build an optimized parser with separate lexer trie
@@ -136,7 +137,7 @@ cc, compute_concrete: cc Ident Term
Compute a term by concrete syntax definitions.
The identifier Ident is a resource module name
needed to resolve constant.
N.B. You need the flag -src when importing the grammar, if you want
N.B. You need the flag -retain when importing the grammar, if you want
the oper definitions to be retained after compilation; otherwise this
command does not expand oper constants.
N.B.' The resulting Term is not a term in the sense of abstract syntax,

7
src/HelpFile.hs
View File

@@ -32,14 +32,15 @@ txtHelpFile =
"\n .gfc canonical GF" ++
"\n .gfr precompiled GF resource " ++
"\n .gfcm multilingual canonical GF" ++
"\n *.ebnf Extended BNF format" ++
"\n .ebnf Extended BNF format" ++
"\n .cf Context-free (BNF) format" ++
"\n options:" ++
"\n -old old: parse in GF<2.0 format" ++
"\n -v verbose: give lots of messages " ++
"\n -s silent: don't give error messages" ++
"\n -opt perform branch-sharing optimization" ++
"\n *-src source: ignore precompiled gfc and gfr files " ++
"\n -src source: ignore precompiled gfc and gfr files" ++
"\n -retain retain operations: read resource modules (needed in comm cc) " ++
"\n -nocf don't build context-free grammar (thus no parser)" ++
"\n -nocheckcirc don't eliminate circular rules from CF " ++
"\n -cflexer build an optimized parser with separate lexer trie" ++
@@ -149,7 +150,7 @@ txtHelpFile =
"\n Compute a term by concrete syntax definitions." ++
"\n The identifier Ident is a resource module name " ++
"\n needed to resolve constant. " ++
"\n N.B. You need the flag -src when importing the grammar, if you want " ++
"\n N.B. You need the flag -retain when importing the grammar, if you want " ++
"\n the oper definitions to be retained after compilation; otherwise this" ++
"\n command does not expand oper constants." ++
"\n N.B.' The resulting Term is not a term in the sense of abstract syntax," ++

2
src/Today.hs
View File

@@ -1 +1 @@
module Today where today = "Fri Mar 26 19:27:07 CET 2004"
module Today where today = "Wed Mar 31 15:13:46 CEST 2004"