From 0c0c82603cdf347f921db09ce529c2747bb37a02 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Thu, 1 Jun 2006 10:26:49 +0000 Subject: [PATCH] The SLinType type is changed so that you don't have to use enumerateTerms each time when you want to know the possible table arguments --- src/GF/Conversion/GFCtoSimple.hs | 4 ++-- src/GF/Conversion/SimpleToMCFG/Nondet.hs | 16 +++++++-------- src/GF/Conversion/SimpleToMCFG/Strict.hs | 2 +- src/GF/Formalism/SimpleGFC.hs | 26 ++++++++++++------------ 4 files changed, 23 insertions(+), 25 deletions(-) diff --git a/src/GF/Conversion/GFCtoSimple.hs b/src/GF/Conversion/GFCtoSimple.hs index a01deb08a..b6a34a8ce 100644 --- a/src/GF/Conversion/GFCtoSimple.hs +++ b/src/GF/Conversion/GFCtoSimple.hs @@ -119,8 +119,8 @@ expandTerm gram term = -- tracePrt "expanded term" prt $ convertCType :: Env -> A.CType -> SLinType convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ] -convertCType gram (A.Table pt vt) = TblT (convertCType gram pt) (convertCType gram vt) -convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct +convertCType gram (A.Table pt vt) = TblT (enumerateTerms Nothing (convertCType gram pt)) (convertCType gram vt) +convertCType gram ct@(A.Cn con) = ConT $ map (convertTerm gram) $ groundTerms gram ct convertCType gram (A.TStr) = StrT convertCType gram (A.TInts n) = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor" diff --git a/src/GF/Conversion/SimpleToMCFG/Nondet.hs b/src/GF/Conversion/SimpleToMCFG/Nondet.hs index 514f2b382..d6ff052f5 100644 --- a/src/GF/Conversion/SimpleToMCFG/Nondet.hs +++ b/src/GF/Conversion/SimpleToMCFG/Nondet.hs @@ -136,15 +136,13 @@ simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term) reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad () --reduceTerm ctype path (Variants terms) -- = member terms >>= reduceTerm ctype path -reduceTerm (StrT) path term = updateLin (path, term) -reduceTerm (ConT _ _) path term = do pat <- expandTerm term - updateHead (path, pat) +reduceTerm (StrT) path term = updateLin (path, term) +reduceTerm (ConT _) path term = do pat <- expandTerm term + updateHead (path, pat) reduceTerm (RecT rtype) path term - = sequence_ [ reduceTerm ctype (path ++. lbl) (term +. lbl) | - (lbl, ctype) <- rtype ] -reduceTerm (TblT ptype vtype) path table - = sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) | - pat <- enumeratePatterns ptype ] + = sequence_ [ reduceTerm ctype (path ++. lbl) (term +. lbl) | (lbl, ctype) <- rtype ] +reduceTerm (TblT pats vtype) path table + = sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) | pat <- pats ] ------------------------------------------------------------ @@ -174,7 +172,7 @@ unifyPType arg (RecT prec) = sequence [ liftM ((,) lbl) $ unifyPType (arg +. lbl) ptype | (lbl, ptype) <- prec ] -unifyPType (Arg nr _ path) (ConT con terms) = +unifyPType (Arg nr _ path) (ConT terms) = do (_, args, _, _) <- readState case lookup path (ecatConstraints (args !! nr)) of Just term -> return term diff --git a/src/GF/Conversion/SimpleToMCFG/Strict.hs b/src/GF/Conversion/SimpleToMCFG/Strict.hs index 6ca7c4737..a5519fcd8 100644 --- a/src/GF/Conversion/SimpleToMCFG/Strict.hs +++ b/src/GF/Conversion/SimpleToMCFG/Strict.hs @@ -109,7 +109,7 @@ termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ] parPaths :: SLinType -> STerm -> [[(SPath, STerm)]] parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $ nubsort [ (path, value) | - (path, (ConT _ _, value)) <- termPaths ctype term ] + (path, (ConT _, value)) <- termPaths ctype term ] strPaths :: SLinType -> STerm -> [(SPath, STerm)] strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ] diff --git a/src/GF/Formalism/SimpleGFC.hs b/src/GF/Formalism/SimpleGFC.hs index 63a9ed43f..ea1f9dc12 100644 --- a/src/GF/Formalism/SimpleGFC.hs +++ b/src/GF/Formalism/SimpleGFC.hs @@ -79,15 +79,15 @@ term2tterm term = error $ "term2tterm: illegal term" -- ** linearization types and terms data LinType c t = RecT [(Label, LinType c t)] - | TblT (LinType c t) (LinType c t) - | ConT Constr [Term c t] + | TblT [Term c t] (LinType c t) + | ConT [Term c t] | StrT deriving (Eq, Ord, Show) isBaseType :: LinType c t -> Bool -isBaseType (ConT _ _) = True -isBaseType (StrT) = True -isBaseType _ = False +isBaseType (ConT _) = True +isBaseType (StrT) = True +isBaseType _ = False data Term c t = Arg Int c (Path c t) -- ^ argument variable, the 'Path' is a path @@ -166,12 +166,12 @@ variants terms0 = case concatMap flatten terms0 of enumerateTerms :: (Eq c, Eq t) => Maybe (Term c t) -> LinType c t -> [Term c t] enumerateTerms arg (StrT) = maybe err return arg where err = error "enumeratePatterns: parameter type should not be string" -enumerateTerms arg (ConT _ terms) = terms +enumerateTerms arg (ConT terms) = terms enumerateTerms arg (RecT rtype) = liftM Rec $ mapM enumAssign rtype where enumAssign (lbl, ctype) = liftM ((,) lbl) $ enumerateTerms arg ctype -enumerateTerms arg (TblT ptype ctype) - = liftM Tbl $ mapM enumCase $ enumeratePatterns ptype +enumerateTerms arg (TblT terms ctype) + = liftM Tbl $ mapM enumCase terms where enumCase pat = liftM ((,) pat) $ enumerateTerms (fmap (+! pat) arg) ctype enumeratePatterns :: (Eq c, Eq t) => LinType c t -> [Term c t] @@ -214,12 +214,12 @@ termFollowPath (Path path0) = follow (reverse path0) follow (Left lbl : path) term = follow path (term +. lbl) lintype2paths :: (Eq c, Eq t) => Path c t -> LinType c t -> [Path c t] -lintype2paths path (ConT _ _) = [] +lintype2paths path (ConT _) = [] lintype2paths path (StrT) = [ path ] lintype2paths path (RecT rec) = concat [ lintype2paths (path ++. lbl) ctype | (lbl, ctype) <- rec ] -lintype2paths path (TblT pt vt) = concat [ lintype2paths (path ++! pat) vt | - pat <- enumeratePatterns pt ] +lintype2paths path (TblT pts vt)= concat [ lintype2paths (path ++! pat) vt | + pat <- pts ] ---------------------------------------------------------------------- -- * pretty-printing @@ -243,8 +243,8 @@ instance Print TTerm where instance (Print c, Print t) => Print (LinType c t) where prt (RecT rec) = "{" ++ prtPairList ":" "; " rec ++ "}" - prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")" - prt (ConT t ts) = prt t ++ "[" ++ prtSep "|" ts ++ "]" + prt (TblT ts t2) = "([" ++ prtSep "|" ts ++ "] => " ++ prt t2 ++ ")" + prt (ConT ts) = "[" ++ prtSep "|" ts ++ "]" prt (StrT) = "Str" instance (Print c, Print t) => Print (Term c t) where