GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

1 files changed, 82 insertions, 0 deletions

diff --git a/src-3.0/GF/Conversion/RemoveSingletons.hs b/src-3.0/GF/Conversion/RemoveSingletons.hs
new file mode 100644
index 000000000..4b9992a4d
--- /dev/null
+++ b/src-3.0/GF/Conversion/RemoveSingletons.hs
@@ -0,0 +1,82 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/11 10:28:16 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.5 $
+--
+-- Instantiating all types which only have one single element.
+--
+-- Should be merged into 'GF.Conversion.FiniteToSimple'
+-----------------------------------------------------------------------------
+
+module GF.Conversion.RemoveSingletons where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Conversion.Types
+
+import GF.Data.SortedList
+import GF.Data.Assoc
+
+import Data.List (mapAccumL)
+
+convertGrammar :: SGrammar -> SGrammar
+convertGrammar grammar = if singles == emptyAssoc then grammar
+			 else tracePrt "RemoveSingletons - non-singleton rules" (prt . length) $
+			      map (convertRule singles) grammar
+    where singles = calcSingletons grammar
+
+convertRule :: Assoc SCat (SyntaxForest Fun, Maybe STerm) -> SRule -> SRule
+convertRule singles rule@(Rule (Abs _ decls _) _)
+    = if all (Nothing ==) singleArgs then rule
+      else instantiateSingles singleArgs rule
+    where singleArgs = map (lookupAssoc singles . decl2cat) decls
+
+instantiateSingles :: [Maybe (SyntaxForest Fun, Maybe STerm)] -> SRule -> SRule
+instantiateSingles singleArgs (Rule (Abs decl decls (Name fun profile)) (Cnc lcat lcats lterm))
+    = Rule (Abs decl decls' (Name fun profile')) (Cnc lcat lcats' lterm')
+    where (decls', lcats') = unzip [ (d, l) | (Nothing, d, l) <- zip3 singleArgs decls lcats ]
+	  profile'  = map (fmap fst) exProfile `composeProfiles` profile
+	  newArgs   = map (fmap snd) exProfile
+	  lterm'    = fmap (instantiateLin newArgs) lterm
+	  exProfile = snd $ mapAccumL mkProfile 0 singleArgs
+	  mkProfile nr (Just trm) = (nr, Constant trm)
+	  mkProfile nr (Nothing)  = (nr+1, Unify [nr])
+
+instantiateLin :: [Profile (Maybe STerm)] -> STerm -> STerm
+instantiateLin newArgs = inst
+    where inst (Arg nr cat path) 
+	      = case newArgs !! nr of
+		  Unify [nr']          -> Arg nr' cat path
+		  Constant (Just term) -> termFollowPath path term
+		  Constant Nothing     -> error "RemoveSingletons.instantiateLin: This should not happen (argument has no linearization)"
+	  inst (cn :^ terms) = cn :^ map inst terms
+	  inst (Rec rec)     = Rec [ (lbl, inst term) | (lbl, term) <- rec ]
+	  inst (term :. lbl) = inst term +. lbl
+	  inst (Tbl tbl)     = Tbl [ (pat, inst term) | (pat, term) <- tbl ]
+	  inst (term :! sel) = inst term +! inst sel
+	  inst (Variants ts) = variants (map inst ts)
+	  inst (t1 :++ t2)   = inst t1 ?++ inst t2
+	  inst term          = term
+
+----------------------------------------------------------------------
+
+calcSingletons :: SGrammar -> Assoc SCat (SyntaxForest Fun, Maybe STerm)
+calcSingletons rules = listAssoc singleCats
+    where singleCats = tracePrt "RemoveSingletons - singleton cats" (prtSep " ") $
+		       [ (cat, (constantNameToForest name, lin)) | 
+			 (cat, [([], name, lin)]) <- rulesByCat ]
+	  rulesByCat = groupPairs $ nubsort
+		       [ (decl2cat cat, (args, name, lin)) | 
+			 Rule (Abs cat args name) (Cnc _ _ lin) <- rules ]
+
+
+