summaryrefslogtreecommitdiff
path: root/src-3.0/GF/OldParsing/ConvertSimpleToMCFG
diff options
context:
space:
mode:
authorkr.angelov <kr.angelov@chalmers.se>2008-05-22 11:59:31 +0000
committerkr.angelov <kr.angelov@chalmers.se>2008-05-22 11:59:31 +0000
commitdf0c4f81fa9c620d7c63af79c0b183a6beccf0bd (patch)
tree0cdc80b29f8f5df0ad280f17be0ba9d46fbd948c /src-3.0/GF/OldParsing/ConvertSimpleToMCFG
parent6394f3ccfbb9d14017393b433a38a3921f1083e5 (diff)
remove all files that aren't used in GF-3.0
Diffstat (limited to 'src-3.0/GF/OldParsing/ConvertSimpleToMCFG')
-rw-r--r--src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs70
-rw-r--r--src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs245
-rw-r--r--src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs277
-rw-r--r--src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs139
4 files changed, 0 insertions, 731 deletions
diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs
deleted file mode 100644
index adc42115a..000000000
--- a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Coercions.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:57 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.3 $
---
--- Adding coercion functions to a MCFG if necessary.
------------------------------------------------------------------------------
-
-
-module GF.OldParsing.ConvertSimpleToMCFG.Coercions (addCoercions) where
-
-import GF.System.Tracing
-import GF.Printing.PrintParser
-import GF.Printing.PrintSimplifiedTerm
--- import PrintGFC
--- import qualified PrGrammar as PG
-
-import qualified GF.Infra.Ident as Ident
-import GF.OldParsing.Utilities
---import GF.OldParsing.GrammarTypes
-import GF.OldParsing.MCFGrammar (Rule(..), Lin(..))
-import GF.Data.SortedList
-import Data.List (groupBy) -- , transpose)
-
-----------------------------------------------------------------------
-
---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 ] ]
- allHeadSet = nubsort allHeads
- allArgSet = union allArgs <\\> map fst allHeadSet
- coercions = tracePrt "#coercions total" (prt . length) $
- concat $
- tracePrt "#coercions per cat" (prtList . map length) $
- combineCoercions
- (groupBy sameCatFst allHeadSet)
- (groupBy sameCat allArgSet)
- sameCatFst a b = sameCat (fst a) (fst b)
-
-
-combineCoercions [] _ = []
-combineCoercions _ [] = []
-combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs)
- = case compare (mainCat $ fst $ head heads) (mainCat $ head args) of
- LT -> combineCoercions allHeads allArgs'
- GT -> combineCoercions allHeads' allArgs
- EQ -> makeCoercion heads args : combineCoercions allHeads allArgs
-
-
-makeCoercion heads args = [ Rule arg [head] lins coercionName |
- head@((_, headCns), lbls) <- heads,
- let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ],
- arg@(_, argCns) <- args,
- argCns `subset` headCns ]
-
-
-coercionName = Ident.IW
-
-mainCat (c, _) = c
-
-sameCat mc1 mc2 = mainCat mc1 == mainCat mc2
-
-
diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs
deleted file mode 100644
index 6627c5f2e..000000000
--- a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Nondet.hs
+++ /dev/null
@@ -1,245 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:58 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.2 $
---
--- Converting SimpleGFC 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.
------------------------------------------------------------------------------
-
-
-module GF.OldParsing.ConvertSimpleToMCFG.Nondet (convertGrammar) where
-
-import GF.System.Tracing
-import GF.Printing.PrintParser
-import GF.Printing.PrintSimplifiedTerm
--- import PrintGFC
--- import qualified PrGrammar as PG
-
-import Control.Monad
--- import Ident (Ident(..))
-import qualified GF.Canon.AbsGFC as AbsGFC
--- import GFC
-import GF.Canon.Look
-import GF.Data.Operations
--- import qualified Modules as M
-import GF.Canon.CMacros (defLinType)
--- import MkGFC (grammar2canon)
-import GF.OldParsing.Utilities
--- import GF.OldParsing.GrammarTypes
-import GF.Data.SortedList
-import qualified GF.OldParsing.MCFGrammar as MCF (Grammar, Rule(..), Lin(..))
-import GF.OldParsing.SimpleGFC
--- import Maybe (listToMaybe)
-import Data.List (groupBy) -- , transpose)
-
-import GF.Data.BacktrackM
-
-----------------------------------------------------------------------
-
---convertGrammar :: Grammar -> MCF.Grammar
-convertGrammar rules = tracePrt "#mcf-rules total" (prt . length) $
- solutions conversion rules undefined
- where conversion = member rules >>= convertRule
-
---convertRule :: Rule -> CnvMonad MCF.Rule
-convertRule (Rule fun (cat :@ _, decls) (Just (term, ctype)))
- = do let args = [ arg | _ ::: (arg :@ _) <- decls ]
- writeState (initialMCat cat, map initialMCat args, [])
- convertTerm cat term
- (newCat, newArgs, linRec) <- readState
- let newTerm = map (instLin newArgs) linRec
- return (MCF.Rule newCat newArgs newTerm fun)
-convertRule _ = failure
-
-instLin newArgs (MCF.Lin lbl lin) = MCF.Lin lbl (map instSym lin)
- where instSym = mapSymbol instCat id
- instCat (_, lbl, arg) = (newArgs !! arg, lbl, arg)
-
---convertTerm :: Cat -> Term -> CnvMonad ()
-convertTerm cat term = do rterm <- simplifyTerm term
- env <- readEnv
- let ctype = lookupCType env cat
- reduce ctype rterm emptyPath
-
-------------------------------------------------------------
-
-{-
-type CnvMonad a = BacktrackM Grammar CMRule a
-
-type CMRule = (MCFCat, [MCFCat], LinRec)
-type LinRec = [Lin Cat Path Tokn]
--}
-
---initialMCat :: Cat -> MCFCat
-initialMCat cat = (cat, []) --MCFCat cat []
-
-----------------------------------------------------------------------
-
---simplifyTerm :: Term -> CnvMonad STerm
-simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms
-simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record
-simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term
-simplifyTerm (Tbl table) = Tbl $ mapM simplifyCase table
-simplifyTerm (term :! sel)
- = do sterm <- simplifyTerm term
- ssel <- simplifyTerm sel
- case sterm of
- Tbl table -> do (pat, val) <- member table
- pat =?= ssel
- return val
- _ -> do sel' <- expandTerm ssel
- return (sterm +! sel')
-simplifyTerm (Variants terms) = liftM Variants $ mapM simplifyTerm terms
-simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2)
-simplifyTerm term = return term
--- error constructors:
--- (I CIdent) - from resource
--- (LI Ident) - pattern variable
--- (EInt Integer) - integer
-
---simplifyAssign :: Assign -> CnvMonad (Label, STerm)
-simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term
-
---simplifyCase :: Case -> [CnvMonad (STerm, STerm)]
-simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term)
-
-
-------------------------------------------------------------
--- reducing simplified terms, collecting mcf rules
-
---reduce :: CType -> STerm -> Path -> CnvMonad ()
-reduce StrT term path = updateLin (path, term)
-reduce (ConT _) term path
- = do pat <- expandTerm term
- updateHead (path, pat)
-reduce ctype (Variants terms) path
- = do term <- member terms
- reduce ctype term path
-reduce (RecT rtype) term path
- = sequence_ [ reduce ctype (term +. lbl) (path ++. lbl) |
- (lbl, ctype) <- rtype ]
-reduce (TblT _ ctype) (Tbl table) path
- = sequence_ [ reduce ctype term (path ++! pat) |
- (pat, term) <- table ]
-reduce (TblT ptype vtype) arg@(Arg _ _ _) path
- = do env <- readEnv
- sequence_ [ reduce vtype (arg +! pat) (path ++! pat) |
- pat <- groundTerms ptype ]
-reduce ctype term path = error ("reduce:\n ctype = (" ++ show ctype ++
- ")\n term = (" ++ show term ++
- ")\n path = (" ++ show path ++ ")\n")
-
-
-------------------------------------------------------------
--- expanding a term to ground terms
-
---expandTerm :: STerm -> CnvMonad STerm
-expandTerm arg@(Arg _ _ _)
- = do env <- readEnv
- pat <- member $ groundTerms $ cTypeForArg env arg
- pat =?= arg
- return pat
-expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms
-expandTerm (Rec record) = liftM Rec $ mapM expandAssign record
-expandTerm (Variants terms) = member terms >>= expandTerm
-expandTerm term = error $ "expandTerm: " ++ show term
-
---expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
-expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term
-
-------------------------------------------------------------
--- unification of patterns and selection terms
-
---(=?=) :: STerm -> STerm -> CnvMonad ()
-Wildcard =?= _ = return ()
-Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) |
- (lbl, pat) <- precord ]
-pat =?= Arg arg _ path = updateArg arg (path, pat)
-(con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms)
- sequence_ $ zipWith (=?=) pats terms
-Rec precord =?= Rec record = sequence_ [ maybe mzero (pat =?=) mterm |
- (lbl, pat) <- precord,
- let mterm = lookup lbl record ]
-pat =?= term = error $ "(=?=): " ++ show pat ++ " =?= " ++ show term
-
-
-------------------------------------------------------------
--- 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 (MCF.Lin path) newLins
- writeState (head, args, lins')
-
---term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]]
-term2lins (Arg arg cat path) = return [Cat (cat, path, arg)]
-term2lins (Token str) = return [Tok str]
-term2lins (t1 :++ t2) = liftM2 (++) (term2lins t1) (term2lins t2)
-term2lins (Empty) = return []
-term2lins (Variants 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)
-
---lookupCType :: GrammarEnv -> Cat -> CType
-lookupCType env cat = errVal defLinType $
- lookupLincat (fst env) (AbsGFC.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 (Arg nr cat (Path path))
- = follow path $ lookupCType env cat
- where follow [] ctype = ctype
- follow (Right pat : path) (TblT _ ctype) = follow path ctype
- follow (Left lbl : path) (RecT rec)
- = case [ ctype | (lbl', ctype) <- rec, lbl == lbl' ] of
- [ctype] -> follow path ctype
- err -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++
- " results in " ++ show err
-
-term2spattern (AbsGFC.R rec) = Rec [ (lbl, term2spattern term) |
- AbsGFC.Ass lbl term <- rec ]
-term2spattern (AbsGFC.Con con terms) = con :^ map term2spattern terms
-
diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs
deleted file mode 100644
index dd2ff0713..000000000
--- a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Old.hs
+++ /dev/null
@@ -1,277 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : ConvertGFCtoMCFG.Old
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:59 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.2 $
---
--- Converting GFC grammars to MCFG grammars. (Old variant)
---
--- 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.OldParsing.ConvertSimpleToMCFG.Old (convertGrammar) where
-
-import GF.System.Tracing
-import GF.Printing.PrintParser
-import GF.Printing.PrintSimplifiedTerm
---import PrintGFC
-import qualified GF.Grammar.PrGrammar as PG
-
-import Control.Monad (liftM, liftM2, guard)
--- import Maybe (listToMaybe)
-import GF.Infra.Ident (Ident(..))
-import GF.Canon.AbsGFC
-import GF.Canon.GFC
-import GF.Canon.Look
-import GF.Data.Operations
-import qualified GF.Infra.Modules as M
-import GF.Canon.CMacros (defLinType)
-import GF.Canon.MkGFC (grammar2canon)
-import GF.OldParsing.Utilities
-import GF.OldParsing.GrammarTypes
-import GF.OldParsing.MCFGrammar (Rule(..), Lin(..))
-import GF.Data.SortedList (nubsort, groupPairs)
-import Data.Maybe (listToMaybe)
-import Data.List (groupBy, transpose)
-
-----------------------------------------------------------------------
--- old style types
-
-data XMCFCat = XMCFCat Cat [(XPath, Term)] deriving (Eq, Ord, Show)
-type XMCFLabel = XPath
-
-cnvXMCFCat :: XMCFCat -> MCFCat
-cnvXMCFCat (XMCFCat cat constrs) = MCFCat cat [ (cnvXPath path, cnvTerm term) |
- (path, term) <- constrs ]
-
-cnvXMCFLabel :: XMCFLabel -> MCFLabel
-cnvXMCFLabel = cnvXPath
-
-cnvXMCFLin :: Lin XMCFCat XMCFLabel Tokn -> Lin MCFCat MCFLabel Tokn
-cnvXMCFLin (Lin lbl lin) = Lin (cnvXMCFLabel lbl) $
- map (mapSymbol cnvSym id) lin
- where cnvSym (cat, lbl, nr) = (cnvXMCFCat cat, cnvXMCFLabel lbl, nr)
-
--- Term -> STerm
-
-cnvTerm (R rec) = SRec [ (lbl, cnvTerm term) | Ass lbl term <- rec ]
-cnvTerm (T _ tbl) = STbl [ (cnvPattern pat, cnvTerm term) |
- Cas pats term <- tbl, pat <- pats ]
-cnvTerm (Con con terms) = SCon con $ map cnvTerm terms
-cnvTerm term
- | isArgPath term = cnvArgPath term
-
-cnvPattern (PR rec) = SRec [ (lbl, cnvPattern term) | PAss lbl term <- rec ]
-cnvPattern (PC con pats) = SCon con $ map cnvPattern pats
-cnvPattern (PW) = SWildcard
-
-isArgPath (Arg _) = True
-isArgPath (P _ _) = True
-isArgPath (S _ _) = True
-isArgPath _ = False
-
-cnvArgPath (Arg (A cat nr)) = SArg (fromInteger nr) cat emptyPath
-cnvArgPath (term `P` lbl) = cnvArgPath term +. lbl
-cnvArgPath (term `S` sel) = cnvArgPath term +! cnvTerm sel
-
--- old style paths
-
-newtype XPath = XPath [Either Label Term] deriving (Eq, Ord, Show)
-
-cnvXPath :: XPath -> Path
-cnvXPath (XPath path) = Path (map (either Left (Right . cnvTerm)) (reverse path))
-
-emptyXPath :: XPath
-emptyXPath = XPath []
-
-(++..) :: XPath -> Label -> XPath
-XPath path ++.. lbl = XPath (Left lbl : path)
-
-(++!!) :: XPath -> Term -> XPath
-XPath path ++!! sel = XPath (Right sel : path)
-
-----------------------------------------------------------------------
-
--- | combining alg. 1 and alg. 2 from Ljunglöf's PhD thesis
-convertGrammar :: (CanonGrammar, Ident) -> MCFGrammar
-convertGrammar (gram, lng) = trace2 "language" (prt lng) $
- trace2 "modules" (prtSep " " modnames) $
- trace2 "#lin-terms" (prt (length cncdefs)) $
- tracePrt "#mcf-rules total" (prt.length) $
- concat $
- tracePrt "#mcf-rules per fun"
- (\rs -> concat [" "++show n++"="++show (length r) |
- (n, r) <- zip [1..] rs]) $
- map (convertDef gram lng) cncdefs
- where Gr mods = grammar2canon gram
- cncdefs = [ def | Mod (MTCnc modname _) _ _ _ defs <- mods,
- modname `elem` modnames,
- def@(CncDFun _ _ _ _ _) <- defs ]
- modnames = M.allExtends gram lng
-
-
-convertDef :: CanonGrammar -> Ident -> Def -> [MCFRule]
-convertDef gram lng (CncDFun fun (CIQ _ cat) args term _)
- = [ Rule (cnvXMCFCat newCat) (map cnvXMCFCat newArgs) (map cnvXMCFLin newTerm) fun |
- let ctype = lookupCType gram lng cat,
- instArgs <- mapM (enumerateInsts gram lng) args,
- let instTerm = substitutePaths gram lng instArgs term,
- newCat <- emcfCat gram lng cat instTerm,
- newArgs <- mapM (extractArg gram lng instArgs) args,
- let newTerm = concatMap (extractLin newArgs) $ strPaths gram lng ctype instTerm
- ]
-
-
--- gammalt skräp:
--- mergeArgs = zipWith mergeRec
--- mergeRec (R r1) (R r2) = R (r1 ++ r2)
-
-extractArg :: CanonGrammar -> Ident -> [Term] -> ArgVar -> [XMCFCat]
-extractArg gram lng args (A cat nr) = emcfCat gram lng cat (args !!! nr)
-
-
-emcfCat :: CanonGrammar -> Ident -> Ident -> Term -> [XMCFCat]
-emcfCat gram lng cat = map (XMCFCat cat) . parPaths gram lng (lookupCType gram lng cat)
-
-
-extractLin :: [XMCFCat] -> (XPath, Term) -> [Lin XMCFCat XMCFLabel Tokn]
-extractLin args (path, term) = map (Lin path) (convertLin term)
- where convertLin (t1 `C` t2) = liftM2 (++) (convertLin t1) (convertLin t2)
- convertLin (E) = [[]]
- convertLin (K tok) = [[Tok tok]]
- convertLin (FV terms) = concatMap convertLin terms
- convertLin term = map (return . Cat) $ flattenTerm emptyXPath term
- flattenTerm path (Arg (A _ nr)) = [(args !!! nr, path, fromInteger nr)]
- flattenTerm path (term `P` lbl) = flattenTerm (path ++.. lbl) term
- flattenTerm path (term `S` sel) = flattenTerm (path ++!! sel) term
- flattenTerm path (FV terms) = concatMap (flattenTerm path) terms
- flattenTerm path term = error $ "flattenTerm: \n " ++ show path ++ "\n " ++ prt term
-
-
-enumerateInsts :: CanonGrammar -> Ident -> ArgVar -> [Term]
-enumerateInsts gram lng arg@(A argCat _) = enumerate (Arg arg) (lookupCType gram lng argCat)
- where enumerate path (TStr) = [ path ]
- enumerate path (Cn con) = okError $ lookupParamValues gram con
- enumerate path (RecType r)
- = map R $ sequence [ map (lbl `Ass`) $
- enumerate (path `P` lbl) ctype |
- lbl `Lbg` ctype <- r ]
- enumerate path (Table s t)
- = map (T s) $ sequence [ map ([term2pattern sel] `Cas`) $
- enumerate (path `S` sel) t |
- sel <- enumerate (error "enumerate") s ]
-
-
-
-termPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, (CType, Term))]
-termPaths gr l (TStr) term = [ (emptyXPath, (TStr, term)) ]
-termPaths gr l (RecType rtype) (R record)
- = [ (path ++.. lbl, value) |
- lbl `Ass` term <- record,
- let ctype = okError $ maybeErr "termPaths/record" $ lookupLabelling lbl rtype,
- (path, value) <- termPaths gr l ctype term ]
-termPaths gr l (Table _ ctype) (T _ table)
- = [ (path ++!! pattern2term pat, value) |
- pats `Cas` term <- table, pat <- pats,
- (path, value) <- termPaths gr l ctype term ]
-termPaths gr l (Table _ ctype) (V ptype table)
- = [ (path ++!! pat, value) |
- (pat, term) <- zip (okError $ allParamValues gr ptype) table,
- (path, value) <- termPaths gr l ctype term ]
-termPaths gr l ctype (FV terms)
- = concatMap (termPaths gr l ctype) terms
-termPaths gr l (Cn pc) term = [ (emptyXPath, (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 :: CanonGrammar -> Ident -> CType -> Term -> [[(XPath, Term)]]
-parPaths gr l ctype term = mapM (uncurry (map . (,))) (groupPairs paths)
- where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths gr l ctype term ]
-
-strPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, Term)]
-strPaths gr l ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ]
- where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths gr l ctype term ]
-
-
--- Substitute each instantiated parameter path for its instantiation
-substitutePaths :: CanonGrammar -> Ident -> [Term] -> Term -> Term
-substitutePaths gr l arguments trm = subst trm
- where subst (con `Con` terms) = con `Con` map subst terms
- subst (R record) = R $ map substAss record
- subst (term `P` lbl) = subst term `evalP` lbl
- subst (T ptype table) = T ptype $ map substCas table
- subst (V ptype table) = T ptype [ [term2pattern pat] `Cas` subst term |
- (pat, term) <- zip (okError $ allParamValues gr ptype) table ]
- subst (term `S` select) = subst term `evalS` subst select
- subst (term `C` term') = subst term `C` subst term'
- subst (FV terms) = evalFV $ map subst terms
- subst (Arg (A _ arg)) = arguments !!! arg
- subst term = term
-
- substAss (l `Ass` term) = l `Ass` subst term
- substCas (p `Cas` term) = p `Cas` subst term
-
-
-evalP (R record) lbl = okError $ maybeErr errStr $ lookupAssign lbl record
- where errStr = "evalP: " ++ prt (R record `P` lbl)
-evalP (FV terms) lbl = evalFV [ evalP term lbl | term <- terms ]
-evalP term lbl = term `P` lbl
-
-evalS t@(T _ tbl) sel = maybe (t `S` sel) id $ lookupCase sel tbl
-evalS (FV terms) sel = evalFV [ term `evalS` sel | term <- terms ]
-evalS term (FV sels)= evalFV [ term `evalS` sel | sel <- sels ]
-evalS term sel = term `S` sel
-
-evalFV terms0 = case nubsort (concatMap flattenFV terms0) of
- [term] -> term
- terms -> FV terms
- where flattenFV (FV ts) = ts
- flattenFV t = [t]
-
-
-----------------------------------------------------------------------
--- utilities
-
--- lookup a CType for an Ident
-lookupCType :: CanonGrammar -> Ident -> Ident -> CType
-lookupCType gr lng c = errVal defLinType $ lookupLincat gr (CIQ lng c)
-
--- lookup a label in a (record / record ctype / table)
-lookupAssign :: Label -> [Assign] -> Maybe Term
-lookupLabelling :: Label -> [Labelling] -> Maybe CType
-lookupCase :: Term -> [Case] -> Maybe Term
-
-lookupAssign lbl rec = listToMaybe [ term | lbl' `Ass` term <- rec, lbl == lbl' ]
-lookupLabelling lbl rtyp = listToMaybe [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ]
-lookupCase sel tbl = listToMaybe [ term | pats `Cas` term <- tbl, sel `matchesPats` pats ]
-
-matchesPats :: Term -> [Patt] -> Bool
-matchesPats term patterns = or [ term == pattern2term pattern | pattern <- patterns ]
-
--- converting between patterns and terms
-pattern2term :: Patt -> Term
-term2pattern :: Term -> Patt
-
-pattern2term (con `PC` patterns) = con `Con` map pattern2term patterns
-pattern2term (PR record) = R [ lbl `Ass` pattern2term pattern |
- lbl `PAss` pattern <- record ]
-
-term2pattern (con `Con` terms) = con `PC` map term2pattern terms
-term2pattern (R record) = PR [ lbl `PAss` term2pattern term |
- lbl `Ass` term <- record ]
-
--- list lookup for Integers instead of Ints
-(!!!) :: [a] -> Integer -> a
-xs !!! n = xs !! fromInteger n
diff --git a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs b/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs
deleted file mode 100644
index aa741518a..000000000
--- a/src-3.0/GF/OldParsing/ConvertSimpleToMCFG/Strict.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:23:00 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.2 $
---
--- Converting SimpleGFC grammars to MCFG grammars, deterministic.
---
--- the resulting grammars might be /very large/
---
--- the conversion is only equivalent if the GFC grammar has a context-free backbone.
------------------------------------------------------------------------------
-
-
-module GF.OldParsing.ConvertSimpleToMCFG.Strict (convertGrammar) where
-
-import GF.System.Tracing
-import GF.Infra.Print
-
-import Control.Monad
-
-import GF.Formalism.Utilities
-import GF.Formalism.GCFG
-import GF.Formalism.MCFG
-import GF.Formalism.SimpleGFC
-import GF.Conversion.Types
-
-import GF.Data.BacktrackM
-
-{-
-import GF.Infra.Ident (Ident(..))
-import GF.Canon.AbsGFC
-import GF.Canon.GFC
-import GF.Canon.Look
-import GF.Data.Operations
-import qualified GF.Infra.Modules as M
-import GF.Canon.CMacros (defLinType)
-import GF.Canon.MkGFC (grammar2canon)
-import GF.OldParsing.Utilities
-import GF.OldParsing.GrammarTypes
-import GF.OldParsing.MCFGrammar (Grammar, Rule(..), Lin(..))
-import GF.Data.SortedList
--- import Maybe (listToMaybe)
-import Data.List (groupBy) -- , transpose)
-
-import GF.Data.BacktrackM
--}
-
-----------------------------------------------------------------------
-
-convertGrammar :: SimpleGrammar -> MGrammar
-convertGrammar rules = tracePrt "#mcf-rules total" (prt . length) $
- solutions conversion undefined
- where conversion = member rules >>= convertRule
-
-convertRule :: SimpleRule -> CnvMonad MRule
-convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term)))
- = do let cat : args = map decl2cat (decl : decls)
- args_ctypes = zip3 [0..] args ctypes
- instArgs <- mapM enumerateArg args_ctypes
- let instTerm = substitutePaths instArgs term
- newCat <- extractMCat cat ctype instTerm
- newArgs <- mapM (extractArg instArgs) args
- let newLinRec = strPaths ctype instTerm >>= extractLin newArgs
- lintype : lintypes = map (convertLinType emptyPath) (ctype : ctypes)
- return $ Rule (Abs newCat newArgs fun) (Cnc lintype lintypes newLinRec)
-convertRule _ = failure
-
-----------------------------------------------------------------------
-
-type CnvMonad a = BacktrackM () a
-
-----------------------------------------------------------------------
--- strict conversion
-
---extractArg :: [Term] -> (Int, Cat, LinType) -> CnvMonad MCat
-extractArg args (nr, cat, ctype) = emcfCat cat ctype (args !! nr)
-
---emcfCat :: Cat -> LinType -> Term -> CnvMonad MCat
-extractMCat cat ctype term = map (MCat cat) $ parPaths ctype term
-
---enumerateArg :: (Int, Cat, LinType) -> CnvMonad Term
-enumerateArg (nr, cat, ctype) = enumerateTerms (Arg nr cat emptyPath) ctype
-
--- Substitute each instantiated parameter path for its instantiation
-substitutePaths :: [Term] -> Term -> Term
-substitutePaths arguments = subst
- where subst (Arg nr _ path) = followPath path (arguments !! nr)
- subst (con :^ terms) = con :^ map subst terms
- subst (Rec record) = Rec [ (lbl, subst term) | (lbl, term) <- record ]
- subst (term :. lbl) = subst term +. lbl
- subst (Tbl table) = Tbl [ (pat, subst term) |
- (pat, term) <- table ]
- subst (term :! select) = subst term +! subst select
- subst (term :++ term') = subst term ?++ subst term'
- subst (Variants terms) = Variants $ map subst terms
- subst term = term
-
-
---termPaths :: CType -> STerm -> [(Path, (CType, STerm))]
-termPaths ctype (Variants terms) = terms >>= termPaths ctype
-termPaths (StrT) term = [ (emptyPath, (StrT, term)) ]
-termPaths (RecT rtype) (Rec record)
- = [ (path ++. lbl, value) |
- (lbl, term) <- record,
- let Just ctype = lookup lbl rtype,
- (path, value) <- termPaths ctype term ]
-termPaths (TblT _ ctype) (Tbl table)
- = [ (path ++! pat, value) |
- (pat, term) <- table,
- (path, value) <- termPaths ctype term ]
-termPaths (ConT pc _) term = [ (emptyPath, (ConT 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 :: CType -> STerm -> [[(Path, STerm)]]
-parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $
- nubsort [ (path, value) |
- (path, (ConT _, value)) <- termPaths ctype term ]
-
---strPaths :: CType -> STerm -> [(Path, STerm)]
-strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ]
- where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ]
-
---extractLin :: [MCFCat] -> (Path, STerm) -> [Lin MCFCat MCFLabel Tokn]
-extractLin args (path, term) = map (Lin path) (convertLin term)
- where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2)
- convertLin (Empty) = [[]]
- convertLin (Token tok) = [[Tok tok]]
- convertLin (Variants terms) = concatMap convertLin terms
- convertLin (Arg nr _ path) = [[Cat (args !! nr, path, nr)]]
-