fix the handling of separators in BNFC which are not nonempty

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]),