"Committed_by_peb"

5 files changed, 19 insertions, 256 deletions

diff --git a/src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs b/src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs
index a0bac995c..81328ad15 100644
--- a/src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs
+++ b/src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs
@@ -1,20 +1,21 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : AddCoercions
+-- Module      : ConvertGFCtoMCFG.Coercions
 -- Maintainer  : PL
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:53 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
+-- Adding coercion functions to a MCFG if necessary.
 -----------------------------------------------------------------------------
 
 
 module GF.Parsing.ConvertGFCtoMCFG.Coercions (addCoercions) where
 
-import Tracing
+import GF.System.Tracing
 import GF.Printing.PrintParser
 import GF.Printing.PrintSimplifiedTerm
 -- import PrintGFC
@@ -33,7 +34,7 @@ addCoercions :: MCFGrammar -> MCFGrammar
 addCoercions rules = coercions ++ rules
     where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | 
 					Rule head args lins _ <- rules, 
-					let lbls = [ lbl | Lin lbl _ <- lins ] ]
+					let lbls = [ lbl | Lin lbl _ <- lins ] ]
 	  allHeadSet = nubsort allHeads
 	  allArgSet  = union   allArgs <\\> map fst allHeadSet
 	  coercions = tracePrt "#coercions total" (prt . length) $
diff --git a/src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs b/src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs
index 34ce30ad1..d6ac60ec0 100644
--- a/src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs
+++ b/src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:53 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Converting GFC grammars to MCFG grammars, nondeterministically.
 --
@@ -20,8 +20,7 @@
 
 module GF.Parsing.ConvertGFCtoMCFG.Nondet (convertGrammar) where
 
-import Tracing
-import IOExts (unsafePerformIO)
+import GF.System.Tracing
 import GF.Printing.PrintParser
 import GF.Printing.PrintSimplifiedTerm
 -- import PrintGFC
diff --git a/src/GF/Parsing/ConvertGFCtoMCFG/Old.hs b/src/GF/Parsing/ConvertGFCtoMCFG/Old.hs
index bd94198c4..826fcdc39 100644
--- a/src/GF/Parsing/ConvertGFCtoMCFG/Old.hs
+++ b/src/GF/Parsing/ConvertGFCtoMCFG/Old.hs
@@ -1,15 +1,15 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : ConvertGFCtoMCFG
+-- Module      : ConvertGFCtoMCFG.Old
 -- Maintainer  : PL
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:44:39 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
--- Converting GFC grammars to MCFG grammars.
+-- Converting GFC grammars to MCFG grammars. (Old variant)
 --
 -- the resulting grammars might be /very large/
 --
@@ -20,7 +20,7 @@
 
 module GF.Parsing.ConvertGFCtoMCFG.Old (convertGrammar) where
 
-import Tracing
+import GF.System.Tracing
 import GF.Printing.PrintParser
 import GF.Printing.PrintSimplifiedTerm
 --import PrintGFC
diff --git a/src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs b/src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs
index de3ad7d5f..6e2e62cdd 100644
--- a/src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs
+++ b/src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:54 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Converting GFC grammars to MCFG grammars, nondeterministically.
 --
@@ -20,8 +20,8 @@
 
 module GF.Parsing.ConvertGFCtoMCFG.Strict (convertGrammar) where
 
-import Tracing
-import IOExts (unsafePerformIO)
+import GF.System.Tracing
+-- import IOExts (unsafePerformIO)
 import GF.Printing.PrintParser
 import GF.Printing.PrintSimplifiedTerm
 -- import PrintGFC
@@ -113,7 +113,7 @@ enumerateArg (A cat nr) = do env <- readEnv
 substitutePaths :: GrammarEnv -> [STerm] -> Term -> STerm
 substitutePaths env arguments trm  = subst trm
     where subst (con `Con` terms) = con `SCon` map subst terms
-	  subst (R record)        = SRec [ (lbl, subst term) | lbl `Ass` term <- record ]
+	  subst (R record)        = SRec [ (lbl, subst term) | lbl `Ass` term <- record ]
 	  subst (term `P` lbl)    = subst term +. lbl
 	  subst (T ptype table)   = STbl [ (pattern2sterm pat, subst term) | 
 					   pats `Cas` term <- table, pat <- pats ]
diff --git a/src/GF/Parsing/ConvertGFCtoMCFG/Utils.hs b/src/GF/Parsing/ConvertGFCtoMCFG/Utils.hs
deleted file mode 100644
index 4fd91e894..000000000
--- a/src/GF/Parsing/ConvertGFCtoMCFG/Utils.hs
+++ /dev/null
@@ -1,237 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : ConvertGFCtoMCFGnondet
--- Maintainer  : PL
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/03/21 22:31:54 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
---
--- Converting GFC grammars to MCFG grammars, nondeterministically.
---
--- the resulting grammars might be /very large/
---
--- the conversion is only equivalent if the GFC grammar has a context-free backbone.
--- (also, the conversion might fail if the GFC grammar has dependent or higher-order types)
------------------------------------------------------------------------------
-
-
-module GF.Conversion.ConvertGFCtoMCFG.Utils where
-
-import Tracing
-import IOExts (unsafePerformIO)
-import GF.Printing.PrintParser
-import GF.Printing.PrintSimplifiedTerm
--- import PrintGFC
--- import qualified PrGrammar as PG
-
-import Monad
-import Ident (Ident(..))
-import AbsGFC
-import GFC
-import Look
-import Operations
-import qualified Modules as M
-import CMacros (defLinType)
-import MkGFC (grammar2canon)
-import GF.Parsing.Parser
-import GF.Parsing.GrammarTypes 
-import GF.Parsing.MCFGrammar (Grammar, Rule(..), Lin(..))
-import GF.Data.SortedList
--- import Maybe (listToMaybe)
-import List (groupBy) -- , transpose)
-
-import GF.Data.BacktrackM
-
-----------------------------------------------------------------------
-
-type GrammarEnv  = (CanonGrammar, Ident)
-
-buildConversion :: (Def -> BacktrackM GrammarEnv state MCFRule)
-		-> GrammarEnv -> MCFGrammar
-buildConversion cnvDef env = trace2 "language" (prt (snd gram)) $
-			     trace2 "modules" (prtSep " " modnames) $
-			     tracePrt "#mcf-rules total" (prt . length) $
-			     solutions conversion env undefined
-    where Gr modules = grammar2canon (fst gram)
-	  modnames   = uncurry M.allExtends gram
-	  conversion = member modules >>= convertModule
-	  convertModule (Mod (MTCnc modname _) _ _ _ defs)
-	      | modname `elem` modnames = member defs >>= cnvDef cnvtype
-	  convertModule _ = failure
-
-
-----------------------------------------------------------------------
--- strict conversion
-
-extractArg :: [STerm] -> ArgVar -> CnvMonad MCFCat
-extractArg args (A cat nr) = emcfCat cat (args !! fromInteger nr)
-
-emcfCat :: Cat -> STerm -> CnvMonad MCFCat
-emcfCat cat term = do env <- readEnv
-		      member $ map (MCFCat cat) $ parPaths env (lookupCType env cat) term
-
-enumerateArg :: ArgVar -> CnvMonad STerm
-enumerateArg (A cat nr) = do env <- readEnv
-			     let ctype = lookupCType env cat
-			     enumerate (SArg (fromInteger nr) cat emptyPath) ctype
-    where enumerate arg (TStr) = return arg 
-	  enumerate arg ctype@(Cn _) = do env <- readEnv 
-					  member $ groundTerms env ctype
-	  enumerate arg (RecType rtype) 
-	      = liftM SRec $ sequence [ liftM ((,) lbl) $ 
-					enumerate (arg +. lbl) ctype |
-					lbl `Lbg` ctype <- rtype ]
-	  enumerate arg (Table stype ctype)
-	      = do env <- readEnv
-		   state <- readState
-		   liftM STbl $ sequence [ liftM ((,) sel) $ 
-					   enumerate (arg +! sel) ctype |
-					   sel <- solutions (enumerate err stype) env state ]
-	      where err = error "enumerate: parameter type should not be string"
-
--- Substitute each instantiated parameter path for its instantiation
-substitutePaths :: GrammarEnv -> [STerm] -> Term -> STerm
-substitutePaths env arguments trm  = subst trm
-    where subst (con `Con` terms) = con `SCon` map subst terms
-	  subst (R record)        = SRec [ (lbl, subst term) | lbl `Ass` term <- record ]
-	  subst (term `P` lbl)    = subst term +. lbl
-	  subst (T ptype table)   = STbl [ (pattern2sterm pat, subst term) | 
-					   pats `Cas` term <- table, pat <- pats ]
-	  subst (V ptype table)   = STbl [ (pat, subst term) | 
-					   (pat, term) <- zip (groundTerms env ptype) table ]
-	  subst (term `S` select) = subst term +! subst select
-	  subst (term `C` term')  = subst term `SConcat` subst term'
-	  subst (K str)           = SToken str
-	  subst (E)               = SEmpty
-	  subst (FV terms)        = evalFV $ map subst terms
-	  subst (Arg (A _ arg))   = arguments !! fromInteger arg
-
-
-termPaths :: GrammarEnv -> CType -> STerm -> [(Path, (CType, STerm))]
-termPaths env (TStr) term = [ (emptyPath, (TStr, term)) ]
-termPaths env (RecType rtype) (SRec record) 
-    = [ (path ++. lbl, value) |
-	(lbl, term) <- record,
-	let ctype = lookupLabelling lbl rtype,
-	(path, value) <- termPaths env ctype term ]
-termPaths env (Table _ ctype) (STbl table)
-    = [ (path ++! pat, value) |
-	(pat, term) <- table,
-	(path, value) <- termPaths env ctype term ]
-termPaths env ctype (SVariants terms)
-    = terms >>= termPaths env ctype
-termPaths env (Cn pc) term = [ (emptyPath, (Cn pc, term)) ]
-
-{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt):
-{a=a1; b=b1}  | {a=a2; b=b2}   ==>  {a=a1|a2; b=b1|b2}
-[p=>p1;q=>q1] | [p=>p2;q=>q2]  ==>  [p=>p1|p2;q=>q1|q2]
--}
-
-parPaths :: GrammarEnv -> CType -> STerm -> [[(Path, STerm)]]
-parPaths env ctype term = mapM (uncurry (map . (,))) (groupPairs paths)
-    where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths env ctype term ]
-
-strPaths :: GrammarEnv -> CType -> STerm -> [(Path, STerm)]
-strPaths env ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ]
-    where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths env ctype term ]
-
-extractLin :: [MCFCat] -> (Path, STerm) -> [Lin MCFCat MCFLabel Tokn]
-extractLin args (path, term) = map (Lin path) (convertLin term)
-    where convertLin (t1 `SConcat` t2) = liftM2 (++) (convertLin t1) (convertLin t2)
-	  convertLin (SEmpty) = [[]]
-	  convertLin (SToken tok) = [[Tok tok]]
-	  convertLin (SVariants terms) = concatMap convertLin terms
-	  convertLin (SArg nr _ path) = [[Cat (args !! nr, path, nr)]]
-
-evalFV terms0 = case nubsort (concatMap flattenFV terms0) of
-	          [term] -> term
-		  terms  -> SVariants terms
-    where flattenFV (SVariants ts) = ts
-	  flattenFV  t      = [t]
-
-lookupLabelling :: Label -> [Labelling] -> CType
-lookupLabelling lbl rtyp = case [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] of
-			     [ctyp] -> ctyp
-			     err -> error $ "lookupLabelling:" ++ show err
-
-pattern2sterm :: Patt -> STerm
-pattern2sterm (con `PC` patterns) = con `SCon` map pattern2sterm patterns
-pattern2sterm (PR record) = SRec [ (lbl, pattern2sterm pattern) | 
-				   lbl `PAss` pattern <- record ]
-
-------------------------------------------------------------
--- updating the mcf rule
-
-updateArg :: Int -> Constraint -> CnvMonad ()
-updateArg arg cn
-    = do (head, args, lins) <- readState 
-	 args' <- updateNth (addToMCFCat cn) arg args
-	 writeState (head, args', lins)
-
-updateHead :: Constraint -> CnvMonad ()
-updateHead cn
-    = do (head, args, lins) <- readState
-	 head' <- addToMCFCat cn head
-	 writeState (head', args, lins)
-
-updateLin :: Constraint -> CnvMonad ()
-updateLin (path, term) 
-    = do let newLins = term2lins term
-	 (head, args, lins) <- readState
-	 let lins' = lins ++ map (Lin path) newLins
-	 writeState (head, args, lins')
-
-term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]]
-term2lins (SArg arg cat path) = return [Cat (cat, path, arg)]
-term2lins (SToken str)        = return [Tok str]
-term2lins (SConcat t1 t2)     = liftM2 (++) (term2lins t1) (term2lins t2)
-term2lins (SEmpty)            = return []
-term2lins (SVariants terms)   = terms >>= term2lins
-term2lins term = error $ "term2lins: " ++ show term
-
-addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat
-addToMCFCat cn (MCFCat cat cns) = liftM (MCFCat cat) $ addConstraint cn cns
-
-addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint]
-addConstraint cn0 (cn : cns)
-    | fst cn0 >  fst cn = liftM (cn:) (addConstraint cn0 cns)
-    | fst cn0 == fst cn = guard (snd cn0 == snd cn) >>
-			  return (cn : cns)
-addConstraint cn0 cns   = return (cn0 : cns)
-
-
-----------------------------------------------------------------------
--- utilities 
-
-updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
-updateNth update 0 (a : as) = liftM (:as) (update a)
-updateNth update n (a : as) = liftM (a:)  (updateNth update (n-1) as)
-
-catOfArg (A aCat _) = aCat
-catOfArg (AB aCat _ _) = aCat
-
-lookupCType :: GrammarEnv -> Cat -> CType
-lookupCType env cat = errVal defLinType $ 
-		      lookupLincat (fst env) (CIQ (snd env) cat)
-
-groundTerms :: GrammarEnv -> CType -> [STerm]
-groundTerms env ctype = err error (map term2spattern) $
-			allParamValues (fst env) ctype
-
-cTypeForArg :: GrammarEnv -> STerm -> CType
-cTypeForArg env (SArg nr cat (Path path))
-    = follow path $ lookupCType env cat
-    where follow [] ctype = ctype
-	  follow (Right pat : path) (Table _ ctype) = follow path ctype
-	  follow (Left lbl : path) (RecType rec)
-	      = case [ ctype | Lbg lbl' ctype <- rec, lbl == lbl' ] of
-		  [ctype] -> follow path ctype
-		  err     -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++ 
-			             " results in " ++ show err
-
-term2spattern (R rec)         = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ]
-term2spattern (Con con terms) = SCon con $ map term2spattern terms
-