From 3e8ec361d8a30017dbb420d2a6755a04f0cf9883 Mon Sep 17 00:00:00 2001 From: krasimir Date: Tue, 22 Mar 2016 13:13:35 +0000 Subject: [PATCH] fix the handling of separators in BNFC which are not nonempty --- src/compiler/GF/Command/Importing.hs | 2 +- src/compiler/GF/Compiler.hs | 2 +- src/compiler/GF/Grammar/BNFC.hs | 26 +++++++++++++++++++------- src/compiler/GF/Grammar/CFG.hs | 10 ++-------- 4 files changed, 23 insertions(+), 17 deletions(-) diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs index f4e51e3e7..59f84e409 100644 --- a/src/compiler/GF/Command/Importing.hs +++ b/src/compiler/GF/Command/Importing.hs @@ -56,7 +56,7 @@ importCF opts files get convert = impCF startCat <- case rules of (Rule cat _ _ : _) -> return cat _ -> 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 return $ setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index a057f074f..7fbaed9e4 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -91,7 +91,7 @@ compileCFFiles opts fs = do startCat <- case rules of (Rule cat _ _ : _) -> return cat _ -> 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) $ do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf diff --git a/src/compiler/GF/Grammar/BNFC.hs b/src/compiler/GF/Grammar/BNFC.hs index dbc3d8edf..9d0915072 100644 --- a/src/compiler/GF/Grammar/BNFC.hs +++ b/src/compiler/GF/Grammar/BNFC.hs @@ -55,7 +55,7 @@ isSepTerm _ = False transformRules :: SepMap -> BNFCRule -> [ParamCFRule] 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'] ids = filter (/= "") [fst s | s <- smbs'] rls = concatMap (createListRules sepMap) ids @@ -71,10 +71,14 @@ fRules c n = Rule (c',[0]) ss rn ss = [NonTerminal (c ++ show (n+1),[0])] rn = CFObj (mkCId $ "coercion_" ++ c') [] -transformSymb :: BNFCSymbol -> (String, ParamCFSymbol) -transformSymb s = case s of +transformSymb :: SepMap -> BNFCSymbol -> (String, ParamCFSymbol) +transformSymb sepMap s = case s of 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) createListRules :: SepMap -> String -> [ParamCFRule] @@ -84,15 +88,23 @@ createListRules sepMap c = Nothing -> createListRules' False True "" c 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 smbs = if isSep then [NonTerminal (c,[0]) | ne] else [NonTerminal (c,[0]) | ne] ++ [Terminal symb | symb /= "" && ne] rn = CFObj (mkCId $ "Base" ++ c) [] - ruleCons = Rule ("List" ++ c,[0]) smbs rn - where smbs = [NonTerminal (c,[0])] ++ + ruleCons + | 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 /= ""] ++ [NonTerminal ("List" ++ c,[0])] rn = CFObj (mkCId $ "Cons" ++ c) [] diff --git a/src/compiler/GF/Grammar/CFG.hs b/src/compiler/GF/Grammar/CFG.hs index 0a8d48b4f..aac13bcba 100644 --- a/src/compiler/GF/Grammar/CFG.hs +++ b/src/compiler/GF/Grammar/CFG.hs @@ -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 = Map.fromListWith Set.union . map (\r -> (ruleLhs r,Set.singleton r)) -uniqueFuns :: (Ord c,Ord t) => Grammar c t -> Grammar c t -uniqueFuns cfg = Grammar {cfgStartCat = cfgStartCat cfg - ,cfgExternalCats = cfgExternalCats cfg - ,cfgRules = Map.fromList (snd (mapAccumL uniqueFunSet Set.empty (Map.toList (cfgRules cfg)))) - } +uniqueFuns :: [Rule c t] -> [Rule c t] +uniqueFuns = snd . mapAccumL uniqueFun Set.empty 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)) where fun' = head [fun'|suffix<-"":map show ([2..]::[Int]),