mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 11:42:49 -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 :: Env -> A.CType -> SLinType
|
||||||
convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ]
|
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 (A.Table pt vt) = TblT (enumerateTerms Nothing (convertCType gram pt)) (convertCType gram vt)
|
||||||
convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct
|
convertCType gram ct@(A.Cn con) = ConT $ map (convertTerm gram) $ groundTerms gram ct
|
||||||
convertCType gram (A.TStr) = StrT
|
convertCType gram (A.TStr) = StrT
|
||||||
convertCType gram (A.TInts n) = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor"
|
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 :: SLinType -> SPath -> STerm -> CnvMonad ()
|
||||||
--reduceTerm ctype path (Variants terms)
|
--reduceTerm ctype path (Variants terms)
|
||||||
-- = member terms >>= reduceTerm ctype path
|
-- = member terms >>= reduceTerm ctype path
|
||||||
reduceTerm (StrT) path term = updateLin (path, term)
|
reduceTerm (StrT) path term = updateLin (path, term)
|
||||||
reduceTerm (ConT _ _) path term = do pat <- expandTerm term
|
reduceTerm (ConT _) path term = do pat <- expandTerm term
|
||||||
updateHead (path, pat)
|
updateHead (path, pat)
|
||||||
reduceTerm (RecT rtype) path term
|
reduceTerm (RecT rtype) path term
|
||||||
= sequence_ [ reduceTerm ctype (path ++. lbl) (term +. lbl) |
|
= sequence_ [ reduceTerm ctype (path ++. lbl) (term +. lbl) | (lbl, ctype) <- rtype ]
|
||||||
(lbl, ctype) <- rtype ]
|
reduceTerm (TblT pats vtype) path table
|
||||||
reduceTerm (TblT ptype vtype) path table
|
= sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) | pat <- pats ]
|
||||||
= sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) |
|
|
||||||
pat <- enumeratePatterns ptype ]
|
|
||||||
|
|
||||||
|
|
||||||
------------------------------------------------------------
|
------------------------------------------------------------
|
||||||
@@ -174,7 +172,7 @@ unifyPType arg (RecT prec) =
|
|||||||
sequence [ liftM ((,) lbl) $
|
sequence [ liftM ((,) lbl) $
|
||||||
unifyPType (arg +. lbl) ptype |
|
unifyPType (arg +. lbl) ptype |
|
||||||
(lbl, ptype) <- prec ]
|
(lbl, ptype) <- prec ]
|
||||||
unifyPType (Arg nr _ path) (ConT con terms) =
|
unifyPType (Arg nr _ path) (ConT terms) =
|
||||||
do (_, args, _, _) <- readState
|
do (_, args, _, _) <- readState
|
||||||
case lookup path (ecatConstraints (args !! nr)) of
|
case lookup path (ecatConstraints (args !! nr)) of
|
||||||
Just term -> return term
|
Just term -> return term
|
||||||
|
|||||||
@@ -109,7 +109,7 @@ termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ]
|
|||||||
parPaths :: SLinType -> STerm -> [[(SPath, STerm)]]
|
parPaths :: SLinType -> STerm -> [[(SPath, STerm)]]
|
||||||
parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $
|
parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $
|
||||||
nubsort [ (path, value) |
|
nubsort [ (path, value) |
|
||||||
(path, (ConT _ _, value)) <- termPaths ctype term ]
|
(path, (ConT _, value)) <- termPaths ctype term ]
|
||||||
|
|
||||||
strPaths :: SLinType -> STerm -> [(SPath, STerm)]
|
strPaths :: SLinType -> STerm -> [(SPath, STerm)]
|
||||||
strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ]
|
strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ]
|
||||||
|
|||||||
@@ -79,15 +79,15 @@ term2tterm term = error $ "term2tterm: illegal term"
|
|||||||
-- ** linearization types and terms
|
-- ** linearization types and terms
|
||||||
|
|
||||||
data LinType c t = RecT [(Label, LinType c t)]
|
data LinType c t = RecT [(Label, LinType c t)]
|
||||||
| TblT (LinType c t) (LinType c t)
|
| TblT [Term c t] (LinType c t)
|
||||||
| ConT Constr [Term c t]
|
| ConT [Term c t]
|
||||||
| StrT
|
| StrT
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
isBaseType :: LinType c t -> Bool
|
isBaseType :: LinType c t -> Bool
|
||||||
isBaseType (ConT _ _) = True
|
isBaseType (ConT _) = True
|
||||||
isBaseType (StrT) = True
|
isBaseType (StrT) = True
|
||||||
isBaseType _ = False
|
isBaseType _ = False
|
||||||
|
|
||||||
data Term c t
|
data Term c t
|
||||||
= Arg Int c (Path c t) -- ^ argument variable, the 'Path' is a path
|
= 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 :: (Eq c, Eq t) => Maybe (Term c t) -> LinType c t -> [Term c t]
|
||||||
enumerateTerms arg (StrT) = maybe err return arg
|
enumerateTerms arg (StrT) = maybe err return arg
|
||||||
where err = error "enumeratePatterns: parameter type should not be string"
|
where err = error "enumeratePatterns: parameter type should not be string"
|
||||||
enumerateTerms arg (ConT _ terms) = terms
|
enumerateTerms arg (ConT terms) = terms
|
||||||
enumerateTerms arg (RecT rtype)
|
enumerateTerms arg (RecT rtype)
|
||||||
= liftM Rec $ mapM enumAssign rtype
|
= liftM Rec $ mapM enumAssign rtype
|
||||||
where enumAssign (lbl, ctype) = liftM ((,) lbl) $ enumerateTerms arg ctype
|
where enumAssign (lbl, ctype) = liftM ((,) lbl) $ enumerateTerms arg ctype
|
||||||
enumerateTerms arg (TblT ptype ctype)
|
enumerateTerms arg (TblT terms ctype)
|
||||||
= liftM Tbl $ mapM enumCase $ enumeratePatterns ptype
|
= liftM Tbl $ mapM enumCase terms
|
||||||
where enumCase pat = liftM ((,) pat) $ enumerateTerms (fmap (+! pat) arg) ctype
|
where enumCase pat = liftM ((,) pat) $ enumerateTerms (fmap (+! pat) arg) ctype
|
||||||
|
|
||||||
enumeratePatterns :: (Eq c, Eq t) => LinType c t -> [Term c t]
|
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)
|
follow (Left lbl : path) term = follow path (term +. lbl)
|
||||||
|
|
||||||
lintype2paths :: (Eq c, Eq t) => Path c t -> LinType c t -> [Path c t]
|
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 (StrT) = [ path ]
|
||||||
lintype2paths path (RecT rec) = concat [ lintype2paths (path ++. lbl) ctype |
|
lintype2paths path (RecT rec) = concat [ lintype2paths (path ++. lbl) ctype |
|
||||||
(lbl, ctype) <- rec ]
|
(lbl, ctype) <- rec ]
|
||||||
lintype2paths path (TblT pt vt) = concat [ lintype2paths (path ++! pat) vt |
|
lintype2paths path (TblT pts vt)= concat [ lintype2paths (path ++! pat) vt |
|
||||||
pat <- enumeratePatterns pt ]
|
pat <- pts ]
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- * pretty-printing
|
-- * pretty-printing
|
||||||
@@ -243,8 +243,8 @@ instance Print TTerm where
|
|||||||
|
|
||||||
instance (Print c, Print t) => Print (LinType c t) where
|
instance (Print c, Print t) => Print (LinType c t) where
|
||||||
prt (RecT rec) = "{" ++ prtPairList ":" "; " rec ++ "}"
|
prt (RecT rec) = "{" ++ prtPairList ":" "; " rec ++ "}"
|
||||||
prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")"
|
prt (TblT ts t2) = "([" ++ prtSep "|" ts ++ "] => " ++ prt t2 ++ ")"
|
||||||
prt (ConT t ts) = prt t ++ "[" ++ prtSep "|" ts ++ "]"
|
prt (ConT ts) = "[" ++ prtSep "|" ts ++ "]"
|
||||||
prt (StrT) = "Str"
|
prt (StrT) = "Str"
|
||||||
|
|
||||||
instance (Print c, Print t) => Print (Term c t) where
|
instance (Print c, Print t) => Print (Term c t) where
|
||||||
|
|||||||
Reference in New Issue
Block a user