mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
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
This commit is contained in:
@@ -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"
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 ]
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user