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

fix the handling of separators in BNFC which are not nonempty

Browse Source
This commit is contained in:
krasimir
2016-03-22 13:13:35 +00:00
parent 4fb187b49c
commit 3e8ec361d8
4 changed files with 23 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF/Command/Importing.hs
View File

@@ -56,7 +56,7 @@ importCF opts files get convert = impCF
startCat <- case rules of startCat <- case rules of
(Rule cat _ _ : _) -> return cat (Rule cat _ _ : _) -> return cat
_ -> fail "empty CFG" _ -> fail "empty CFG"
let pgf = cf2pgf (last files) (uniqueFuns (mkCFG startCat Set.empty rules)) let pgf = cf2pgf (last files) (mkCFG startCat Set.empty rules)
probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf
return $ setProbabilities probs return $ setProbabilities probs
$ if flag optOptimizePGF opts then optimizePGF pgf else pgf $ if flag optOptimizePGF opts then optimizePGF pgf else pgf

2
src/compiler/GF/Compiler.hs
View File

@@ -91,7 +91,7 @@ compileCFFiles opts fs = do
startCat <- case rules of startCat <- case rules of
(Rule cat _ _ : _) -> return cat (Rule cat _ _ : _) -> return cat
_ -> fail "empty CFG" _ -> fail "empty CFG"
let pgf = cf2pgf (last fs) (uniqueFuns (mkCFG startCat Set.empty rules)) let pgf = cf2pgf (last fs) (mkCFG startCat Set.empty rules)
unless (flag optStopAfterPhase opts == Compile) $ unless (flag optStopAfterPhase opts == Compile) $
do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf

26
src/compiler/GF/Grammar/BNFC.hs
View File

@@ -55,7 +55,7 @@ isSepTerm _ = False
transformRules :: SepMap -> BNFCRule -> [ParamCFRule] transformRules :: SepMap -> BNFCRule -> [ParamCFRule]
transformRules sepMap (BNFCRule c smbs@(s:ss) r) = Rule (c,[0]) cfSmbs r : rls transformRules sepMap (BNFCRule c smbs@(s:ss) r) = Rule (c,[0]) cfSmbs r : rls
where smbs' = map transformSymb smbs where smbs' = map (transformSymb sepMap) smbs
cfSmbs = [snd s | s <- smbs'] cfSmbs = [snd s | s <- smbs']
ids = filter (/= "") [fst s | s <- smbs'] ids = filter (/= "") [fst s | s <- smbs']
rls = concatMap (createListRules sepMap) ids rls = concatMap (createListRules sepMap) ids
@@ -71,10 +71,14 @@ fRules c n = Rule (c',[0]) ss rn
ss = [NonTerminal (c ++ show (n+1),[0])] ss = [NonTerminal (c ++ show (n+1),[0])]
rn = CFObj (mkCId $ "coercion_" ++ c') [] rn = CFObj (mkCId $ "coercion_" ++ c') []
transformSymb :: BNFCSymbol -> (String, ParamCFSymbol) transformSymb :: SepMap -> BNFCSymbol -> (String, ParamCFSymbol)
transformSymb s = case s of transformSymb sepMap s = case s of
NonTerminal (c,False) -> ("", NonTerminal (c,[0])) NonTerminal (c,False) -> ("", NonTerminal (c,[0]))
NonTerminal (c,True ) -> (c , NonTerminal $ ("List" ++ c,[0])) NonTerminal (c,True ) -> let needsCoercion =
case lookup c sepMap of
Just (ne, isSep, symb) -> isSep && symb /= "" && not ne
Nothing -> False
in (c , NonTerminal ("List" ++ c,if needsCoercion then [0,1] else [0]))
Terminal t -> ("", Terminal t) Terminal t -> ("", Terminal t)
createListRules :: SepMap -> String -> [ParamCFRule] createListRules :: SepMap -> String -> [ParamCFRule]
@@ -84,15 +88,23 @@ createListRules sepMap c =
Nothing -> createListRules' False True "" c Nothing -> createListRules' False True "" c
createListRules':: IsNonempty -> IsSeparator -> SepTermSymb -> String -> [ParamCFRule] createListRules':: IsNonempty -> IsSeparator -> SepTermSymb -> String -> [ParamCFRule]
createListRules' ne isSep symb c = ruleCons : [ruleBase] createListRules' ne isSep symb c = ruleBase : ruleCons
where ruleBase = Rule ("List" ++ c,[0]) smbs rn where ruleBase = Rule ("List" ++ c,[0]) smbs rn
where smbs = if isSep where smbs = if isSep
then [NonTerminal (c,[0]) | ne] then [NonTerminal (c,[0]) | ne]
else [NonTerminal (c,[0]) | ne] ++ else [NonTerminal (c,[0]) | ne] ++
[Terminal symb | symb /= "" && ne] [Terminal symb | symb /= "" && ne]
rn = CFObj (mkCId $ "Base" ++ c) [] rn = CFObj (mkCId $ "Base" ++ c) []
ruleCons = Rule ("List" ++ c,[0]) smbs rn ruleCons
where smbs = [NonTerminal (c,[0])] ++ | isSep && symb /= "" && not ne = [Rule ("List" ++ c,[1]) smbs0 rn
,Rule ("List" ++ c,[1]) smbs1 rn]
| otherwise = [Rule ("List" ++ c,[0]) smbs rn]
where smbs0 =[NonTerminal (c,[0])] ++
[NonTerminal ("List" ++ c,[0])]
smbs1 =[NonTerminal (c,[0])] ++
[Terminal symb] ++
[NonTerminal ("List" ++ c,[1])]
smbs = [NonTerminal (c,[0])] ++
[Terminal symb | symb /= ""] ++ [Terminal symb | symb /= ""] ++
[NonTerminal ("List" ++ c,[0])] [NonTerminal ("List" ++ c,[0])]
rn = CFObj (mkCId $ "Cons" ++ c) [] rn = CFObj (mkCId $ "Cons" ++ c) []

10
src/compiler/GF/Grammar/CFG.hs
View File

@@ -226,15 +226,9 @@ mkCFG start ext rs = Grammar { cfgStartCat = start, cfgExternalCats = ext, cfgRu
groupProds :: (Ord c,Ord t) => [Rule c t] -> Map c (Set (Rule c t)) groupProds :: (Ord c,Ord t) => [Rule c t] -> Map c (Set (Rule c t))
groupProds = Map.fromListWith Set.union . map (\r -> (ruleLhs r,Set.singleton r)) groupProds = Map.fromListWith Set.union . map (\r -> (ruleLhs r,Set.singleton r))
uniqueFuns :: (Ord c,Ord t) => Grammar c t -> Grammar c t uniqueFuns :: [Rule c t] -> [Rule c t]
uniqueFuns cfg = Grammar {cfgStartCat = cfgStartCat cfg uniqueFuns = snd . mapAccumL uniqueFun Set.empty
,cfgExternalCats = cfgExternalCats cfg
,cfgRules = Map.fromList (snd (mapAccumL uniqueFunSet Set.empty (Map.toList (cfgRules cfg))))
}
where where
uniqueFunSet funs (cat,rules) =
let (funs',rules') = mapAccumL uniqueFun funs (Set.toList rules)
in (funs',(cat,Set.fromList rules'))
uniqueFun funs (Rule cat items (CFObj fun args)) = (Set.insert fun' funs,Rule cat items (CFObj fun' args)) uniqueFun funs (Rule cat items (CFObj fun args)) = (Set.insert fun' funs,Rule cat items (CFObj fun' args))
where where
fun' = head [fun'|suffix<-"":map show ([2..]::[Int]), fun' = head [fun'|suffix<-"":map show ([2..]::[Int]),