msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

in the middle of adapting CheckGrammar

Browse Source
This commit is contained in:
aarne
2007-12-06 17:29:19 +00:00
parent bfd215aa7f
commit fe30e32748
5 changed files with 610 additions and 134 deletions
Download Patch File Download Diff File Expand all files Collapse all files

241
src/GF/Devel/Compile/CheckGrammar.hs
View File

@@ -34,7 +34,7 @@ import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Terms import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.MkJudgements import GF.Devel.Grammar.MkJudgements
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.PrGrammar import GF.Devel.Grammar.PrGF
import GF.Devel.Grammar.Lookup import GF.Devel.Grammar.Lookup
import GF.Infra.Ident import GF.Infra.Ident
@@ -47,8 +47,8 @@ import GF.Infra.Ident
--import GF.Grammar.LookAbs --import GF.Grammar.LookAbs
--import GF.Grammar.ReservedWords ---- --import GF.Grammar.ReservedWords ----
--import GF.Grammar.PatternMatch import GF.Grammar.PatternMatch (testOvershadow)
--import GF.Grammar.AppPredefined import GF.Grammar.AppPredefined
--import GF.Grammar.Lockfield (isLockLabel) --import GF.Grammar.Lockfield (isLockLabel)
import GF.Data.Operations import GF.Data.Operations
@@ -68,14 +68,14 @@ showCheckModule mos m = do
checkModule :: GF -> SourceModule -> Check SourceModule checkModule :: GF -> SourceModule -> Check SourceModule
checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do
let gf = gf0 {gfmodules = Map.insert name mo (gfmodules gf0)} let gr = gf0 {gfmodules = Map.insert name mo (gfmodules gf0)}
checkRestrictedInheritance gf (name, mo) ---- checkRestrictedInheritance gr (name, mo)
mo1 <- case mtype mo of mo1 <- case mtype mo of
MTAbstract -> judgementOpModule (checkAbsInfo gr name) mo MTAbstract -> judgementOpModule (checkAbsInfo gr name) mo
MTResource -> judgementOpModule (checkResInfo gr name) mo MTGrammar -> judgementOpModule (checkResInfo gr name) mo
MTConcrete aname -> do MTConcrete aname -> do
checkErr $ topoSortOpers $ allOperDependencies name js checkErr $ topoSortOpers $ allOperDependencies name $ mjments mo
abs <- checkErr $ lookupModule gr aname abs <- checkErr $ lookupModule gr aname
js1 <- checkCompleteGrammar abs mo js1 <- checkCompleteGrammar abs mo
judgementOpModule (checkCncInfo gr name (aname,abs)) js1 judgementOpModule (checkCncInfo gr name (aname,abs)) js1
@@ -119,13 +119,13 @@ checkRestrictedInheritance mos (name,mo) = do
-- | check if a term is typable -- | check if a term is typable
justCheckLTerm :: SourceGrammar -> Term -> Err Term justCheckLTerm :: GF -> Term -> Err Term
justCheckLTerm src t = do justCheckLTerm src t = do
((t',_),_) <- checkStart (inferLType src t) ((t',_),_) <- checkStart (inferLType src t)
return t' return t'
checkAbsInfo :: GF -> Ident -> (Ident,JEntry) -> Check (Ident,JEntry) checkAbsInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement
checkAbsInfo st m (c,info) = return (c,info) ---- checkAbsInfo st m c info = return info ----
{- {-
checkAbsInfo st m (c,info) = do checkAbsInfo st m (c,info) = do
@@ -178,70 +178,62 @@ checkAbsInfo st m (c,info) = do
_ -> mkApp t [a] _ -> mkApp t [a]
-} -}
checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info)
checkCompleteGrammar :: Module -> Module -> Check Module
checkCompleteGrammar abs cnc = do checkCompleteGrammar abs cnc = do
let js = jments cnc let js = mjments cnc
let fs = tree2list $ jments abs let fs = Map.assocs $ mjments abs
foldM checkOne js fs js' <- foldM checkOne js fs
return $ cnc {mjments = js'}
where where
checkOne js i@(c,info) = case info of checkOne js i@(c, Left ju) = case jform ju of
AbsFun (Yes _) _ -> case lookupIdent c js of JFun -> case Map.lookup c js of
Ok _ -> return js Just (Left j) | jform ju == JLin -> return js
_ -> do _ -> do
checkWarn $ "WARNING: no linearization of" +++ prt c checkWarn $ "WARNING: no linearization of" +++ prt c
return js return js
AbsCat (Yes _) _ -> case lookupIdent c js of JCat -> case Map.lookup c js of
Ok (AnyInd _ _) -> return js Just (Left j) | jform ju == JLincat -> return js
Ok (CncCat (Yes _) _ _) -> return js _ -> do ---- TODO: other things to check here
Ok (CncCat _ mt mp) -> do
checkWarn $ checkWarn $
"Warning: no linearization type for" +++ prt c ++ "Warning: no linearization type for" +++ prt c ++
", inserting default {s : Str}" ", inserting default {s : Str}"
return $ updateTree (c,CncCat (Yes defLinType) mt mp) js return $ Map.insert c (cncCat defLinType) js
_ -> do
checkWarn $
"Warning: no linearization type for" +++ prt c ++
", inserting default {s : Str}"
return $ updateTree (c,CncCat (Yes defLinType) nope nope) js
_ -> return js _ -> return js
-- | General Principle: only Yes-values are checked. checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement
-- A May-value has always been checked in its origin module. checkResInfo gr mo c info = do
checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) ---- checkReservedId c
checkResInfo gr mo (c,info) = do case jform info of
checkReservedId c JOper -> chIn "operation" $ case (jtype info, jdef info) of
case info of (_,Meta _) -> do
ResOper pty pde -> chIn "operation" $ do checkWarn "No definition given to oper"
(pty', pde') <- case (pty,pde) of return info
(Yes ty, Yes de) -> do (Meta,de) -> do
ty' <- check ty typeType >>= comp . fst (de',ty') <- infer de
(de',_) <- check de ty' return (resOper ty' de')
return (Yes ty', Yes de') (ty, de) -> do
(_, Yes de) -> do ty' <- check ty typeType >>= comp . fst
(de',ty') <- infer de (de',_) <- check de ty'
return (Yes ty', Yes de') return (resOper ty' de')
(_,Nope) -> do {- ----
checkWarn "No definition given to oper"
return (pty,pde)
_ -> return (pty, pde) --- other cases are uninteresting
return (c, ResOper pty' pde')
ResOverload tysts -> chIn "overloading" $ do ResOverload tysts -> chIn "overloading" $ do
tysts' <- mapM (uncurry $ flip check) tysts tysts' <- mapM (uncurry $ flip check) tysts
let tysts2 = [(y,x) | (x,y) <- tysts'] let tysts2 = [(y,x) | (x,y) <- tysts']
--- this can only be a partial guarantee, since matching --- this can only be a partial guarantee, since matching
--- with value type is only possible if expected type is given --- with value type is only possible if expected type is given
checkUniq $ checkUniq $
sort [t : map snd xs | (x,_) <- tysts2, Ok (xs,t) <- [typeFormCnc x]] sort [t : map snd xs | (x,_) <- tysts2, let (xs,t) = prodForm x]
return (c,ResOverload tysts2) return (c,ResOverload tysts2)
-}
{- ----
ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do
---- mapM ((mapM (computeLType gr . snd)) . snd) pcs ---- mapM ((mapM (computeLType gr . snd)) . snd) pcs
mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs
ts <- checkErr $ lookupParamValues gr mo c ts <- checkErr $ lookupParamValues gr mo c
return (c,ResParam (Yes (pcs, Just ts))) return (c,ResParam (Yes (pcs, Just ts)))
-}
_ -> return (c,info) _ -> return info
where where
infer = inferLType gr infer = inferLType gr
check = checkLType gr check = checkLType gr
@@ -256,34 +248,37 @@ checkResInfo gr mo (c,info) = do
_ -> return () _ -> return ()
checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> checkCncInfo :: GF -> Ident -> SourceModule ->
(Ident,Info) -> Check (Ident,Info) Ident -> Judgement -> Check Judgement
checkCncInfo gr m (a,abs) (c,info) = do checkCncInfo gr cnc (a,abs) c info = do
checkReservedId c ---- checkReservedId c
case info of case jform info of
JFun -> chIn "linearization of" $ do
CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do typ <- checkErr $ lookupFunType gr a c
typ <- checkErr $ lookupFunTypeSrc gr a c
cat0 <- checkErr $ valCat typ cat0 <- checkErr $ valCat typ
(cont,val) <- linTypeOfType gr m typ -- creates arg vars (cont,val) <- linTypeOfType gr cnc typ -- creates arg vars
(trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars let lintyp = mkFunType (map snd cont) val
checkPrintname gr mpr (trm',_) <- check (jdef info) lintyp -- erases arg vars
checkPrintname gr (jprintname info)
cat <- return $ snd cat0 cat <- return $ snd cat0
return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) return (info {jdef = trm'})
---- return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr)
-- cat for cf, typ for pe -- cat for cf, typ for pe
CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do JCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do
checkErr $ lookupCatContextSrc gr a c checkErr $ lookupCatContext gr a c
typ' <- checkIfLinType gr typ typ' <- checkIfLinType gr (jtype info)
{- ----
mdef' <- case mdef of mdef' <- case mdef of
Yes def -> do Yes def -> do
(def',_) <- checkLType gr def (mkFunType [typeStr] typ) (def',_) <- checkLType gr def (mkFunType [typeStr] typ)
return $ Yes def' return $ Yes def'
_ -> return mdef _ -> return mdef
checkPrintname gr mpr -}
return (c,CncCat (Yes typ') mdef' mpr) checkPrintname gr (jprintname info)
return (info {jtype = typ'})
_ -> checkResInfo gr m (c,info) _ -> checkResInfo gr cnc c info
where where
env = gr env = gr
@@ -292,7 +287,8 @@ checkCncInfo gr m (a,abs) (c,info) = do
check = checkLType gr check = checkLType gr
chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":")
checkIfParType :: SourceGrammar -> Type -> Check ()
checkIfParType :: GF -> Type -> Check ()
checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ)
where where
isParType ty = True ---- isParType ty = True ----
@@ -308,6 +304,7 @@ checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType
_ -> False _ -> False
-} -}
{- ----
checkIfStrType :: SourceGrammar -> Type -> Check () checkIfStrType :: SourceGrammar -> Type -> Check ()
checkIfStrType st typ = case typ of checkIfStrType st typ = case typ of
Table arg val -> do Table arg val -> do
@@ -315,26 +312,17 @@ checkIfStrType st typ = case typ of
checkIfStrType st val checkIfStrType st val
_ | typ == typeStr -> return () _ | typ == typeStr -> return ()
_ -> prtFail "not a string type" typ _ -> prtFail "not a string type" typ
-}
checkIfLinType :: GF -> Type -> Check Type
checkIfLinType :: SourceGrammar -> Type -> Check Type
checkIfLinType st typ0 = do checkIfLinType st typ0 = do
typ <- computeLType st typ0 typ <- computeLType st typ0
case typ of case typ of
RecType r -> do RecType r -> return ()
let (lins,ihs) = partition (isLinLabel .fst) r
--- checkErr $ checkUnique $ map fst r
mapM_ checkInh ihs
mapM_ checkLin lins
_ -> prtFail "a linearization type must be a record type instead of" typ _ -> prtFail "a linearization type must be a record type instead of" typ
return typ return typ
where computeLType :: GF -> Type -> Check Type
checkInh (label,typ) = checkIfParType st typ
checkLin (label,typ) = return () ---- checkIfStrType st typ
computeLType :: SourceGrammar -> Type -> Check Type
computeLType gr t = do computeLType gr t = do
g0 <- checkGetContext g0 <- checkGetContext
let g = [(x, Vr x) | (x,_) <- g0] let g = [(x, Vr x) | (x,_) <- g0]
@@ -348,15 +336,15 @@ computeLType gr t = do
Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed Q (IC "Predef") (IC "Error") -> return ty ---- shouldn't be needed
Q m c | elem c [cPredef,cPredefAbs] -> return ty Q m c | elem c [cPredef,cPredefAbs] -> return ty
Q m c | elem c [zIdent "Int"] -> Q m c | elem c [identC "Int"] ->
return $ defLinType return $ defLinType
---- let ints k = App (Q (IC "Predef") (IC "Ints")) (EInt k) in ---- let ints k = App (Q (IC "Predef") (IC "Ints")) (EInt k) in
---- RecType [ ---- RecType [
---- (LIdent "last",ints 9),(LIdent "s", typeStr), (LIdent "size",ints 1)] ---- (LIdent "last",ints 9),(LIdent "s", typeStr), (LIdent "size",ints 1)]
Q m c | elem c [zIdent "Float",zIdent "String"] -> return defLinType ---- Q m c | elem c [identC "Float",identC "String"] -> return defLinType ----
Q m ident -> checkIn ("module" +++ prt m) $ do Q m ident -> checkIn ("module" +++ prt m) $ do
ty' <- checkErr (lookupResDef gr m ident) ty' <- checkErr (lookupOperDef gr m ident)
if ty' == ty then return ty else comp ty' --- is this necessary to test? if ty' == ty then return ty else comp ty' --- is this necessary to test?
Vr ident -> checkLookup ident -- never needed to compute! Vr ident -> checkLookup ident -- never needed to compute!
@@ -388,41 +376,43 @@ computeLType gr t = do
let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs
liftM RecType $ mapPairsM comp fs' liftM RecType $ mapPairsM comp fs'
_ | ty == typeTok -> return typeStr ---- _ | ty == typeStr -> return typeStr
_ | isPredefConstant ty -> return ty ---- _ | isPredefConstant ty -> return ty
_ -> composOp comp ty _ -> composOp comp ty
checkPrintname :: SourceGrammar -> Perh Term -> Check () checkPrintname :: GF -> Term -> Check ()
checkPrintname st (Yes t) = checkLType st t typeStr >> return () ---- checkPrintname st (Yes t) = checkLType st t typeStr >> return ()
checkPrintname _ _ = return () checkPrintname _ _ = return ()
{- ----
-- | for grammars obtained otherwise than by parsing ---- update!! -- | for grammars obtained otherwise than by parsing ---- update!!
checkReservedId :: Ident -> Check () checkReservedId :: Ident -> Check ()
checkReservedId x = let c = prt x in checkReservedId x = let c = prt x in
if isResWord c if isResWord c
then checkWarn ("Warning: reserved word used as identifier:" +++ c) then checkWarn ("Warning: reserved word used as identifier:" +++ c)
else return () else return ()
-}
-- to normalize records and record types -- to normalize records and record types
labelIndex :: Type -> Label -> Int labelIndex :: Type -> Label -> Int
labelIndex ty lab = case ty of labelIndex ty lab = case ty of
RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts RecType ts -> maybe (error ("label index"+++ prt lab)) id $ lookup lab $ labs ts
_ -> error $ "label index" +++ prt ty _ -> error $ "label index" +++ prt ty
where where
labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..] labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..]
-- the underlying algorithms -- the underlying algorithms
inferLType :: SourceGrammar -> Term -> Check (Term, Type) inferLType :: GF -> Term -> Check (Term, Type)
inferLType gr trm = case trm of inferLType gr trm = case trm of
Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
Q m ident -> checks [ Q m ident -> checks [
termWith trm $ checkErr (lookupResType gr m ident) >>= comp termWith trm $ checkErr (lookupOperType gr m ident) >>= comp
, ,
checkErr (lookupResDef gr m ident) >>= infer checkErr (lookupOperDef gr m ident) >>= infer
, ,
{- {-
do do
@@ -438,9 +428,9 @@ inferLType gr trm = case trm of
QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
QC m ident -> checks [ QC m ident -> checks [
termWith trm $ checkErr (lookupResType gr m ident) >>= comp termWith trm $ checkErr (lookupOperType gr m ident) >>= comp
, ,
checkErr (lookupResDef gr m ident) >>= infer checkErr (lookupOperDef gr m ident) >>= infer
, ,
prtFail "cannot infer type of canonical constant" trm prtFail "cannot infer type of canonical constant" trm
] ]
@@ -532,23 +522,20 @@ inferLType gr trm = case trm of
check2 (flip justCheck typeStr) C s1 s2 typeStr check2 (flip justCheck typeStr) C s1 s2 typeStr
Glue s1 s2 -> Glue s1 s2 ->
check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok check2 (flip justCheck typeStr) Glue s1 s2 typeStr
---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 ---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
Strs (Cn (IC "#conflict") : ts) -> do ---- Strs (Cn (IC "#conflict") : ts) -> do
trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts) ---- trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts)
-- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) -- checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts))
-- infer $ head ts -- infer $ head ts
Strs ts -> do
ts' <- mapM (\t -> justCheck t typeStr) ts
return (Strs ts', typeStrs)
Alts (t,aa) -> do Alts (t,aa) -> do
t' <- justCheck t typeStr t' <- justCheck t typeStr
aa' <- flip mapM aa (\ (c,v) -> do aa' <- flip mapM aa (\ (c,v) -> do
c' <- justCheck c typeStr c' <- justCheck c typeStr
v' <- justCheck v typeStrs v' <- justCheck v typeStr
return (c',v')) return (c',v'))
return (Alts (t',aa'), typeStr) return (Alts (t',aa'), typeStr)
@@ -633,7 +620,7 @@ inferLType gr trm = case trm of
_ -> False _ -> False
inferPatt p = case p of inferPatt p = case p of
PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc PP q c ps | q /= cPredef -> checkErr $ lookupOperType gr q c >>= snd . prodForm
PAs _ p -> inferPatt p PAs _ p -> inferPatt p
PNeg p -> inferPatt p PNeg p -> inferPatt p
PAlt p q -> checks [inferPatt p, inferPatt q] PAlt p q -> checks [inferPatt p, inferPatt q]
@@ -644,9 +631,9 @@ inferLType gr trm = case trm of
-- type inference: Nothing, type checking: Just t -- type inference: Nothing, type checking: Just t
-- the latter permits matching with value type -- the latter permits matching with value type
getOverload :: SourceGrammar -> Maybe Type -> Term -> Check (Maybe (Term,Type)) getOverload :: GF -> Maybe Type -> Term -> Check (Maybe (Term,Type))
getOverload env@gr mt t = case appForm t of getOverload env@gr mt t = case appForm t of
(f@(Q m c), ts) -> case lookupOverload gr m c of (f@(Q m c), ts) -> case (return []) of ---- lookupOverload gr m c of
Ok typs -> do Ok typs -> do
ttys <- mapM infer ts ttys <- mapM infer ts
v <- matchOverload f typs ttys v <- matchOverload f typs ttys
@@ -682,7 +669,7 @@ getOverload env@gr mt t = case appForm t of
matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where
unlocked = case v of unlocked = case v of
RecType fs -> [Just $ RecType $ filter (not . isLockLabel . fst) fs] RecType fs -> [Just $ RecType $ fs] ---- filter (not . isLockLabel . fst) fs]
_ -> [] _ -> []
---- TODO: accept subtypes ---- TODO: accept subtypes
---- TODO: use a trie ---- TODO: use a trie
@@ -698,7 +685,7 @@ getOverload env@gr mt t = case appForm t of
Prod _ _ _ -> False Prod _ _ _ -> False
_ -> True _ -> True
checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type) checkLType :: GF -> Term -> Type -> Check (Term, Type)
checkLType env trm typ0 = do checkLType env trm typ0 = do
typ <- comp typ0 typ <- comp typ0
@@ -862,8 +849,8 @@ pattContext :: LTEnv -> Type -> Patt -> Check Context
pattContext env typ p = case p of pattContext env typ p = case p of
PV x | not (isWildIdent x) -> return [(x,typ)] PV x | not (isWildIdent x) -> return [(x,typ)]
PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
t <- checkErr $ lookupResType cnc q c t <- checkErr $ lookupOperType cnc q c
(cont,v) <- checkErr $ typeFormCnc t let (cont,v) = prodForm t
checkCond ("wrong number of arguments for constructor in" +++ prt p) checkCond ("wrong number of arguments for constructor in" +++ prt p)
(length cont == length ps) (length cont == length ps)
checkEqLType env typ v (patt2term p) checkEqLType env typ v (patt2term p)
@@ -912,7 +899,7 @@ pattContext env typ p = case p of
-- auxiliaries -- auxiliaries
type LTEnv = SourceGrammar type LTEnv = GF
termWith :: Term -> Check Type -> Check (Term, Type) termWith :: Term -> Check Type -> Check (Term, Type)
termWith t ct = do termWith t ct = do
@@ -1007,7 +994,7 @@ checkIfEqLType env t u trm = do
let let
ls = [l | (l,a) <- rs, ls = [l | (l,a) <- rs,
not (any (\ (k,b) -> alpha g a b && l == k) ts)] not (any (\ (k,b) -> alpha g a b && l == k) ts)]
(locks,others) = partition isLockLabel ls (locks,others) = partition (const False) ls ---- isLockLabel ls
in case others of in case others of
_:_ -> Bad $ "missing record fields" +++ unwords (map prt others) _:_ -> Bad $ "missing record fields" +++ unwords (map prt others)
_ -> return locks _ -> return locks
@@ -1019,15 +1006,19 @@ checkIfEqLType env t u trm = do
_ -> Bad "" _ -> Bad ""
sTypes = [typeStr, typeTok, typeString] ---- to revise
allExtendsPlus _ n = [n]
sTypes = [typeStr, typeString]
comp = computeLType env comp = computeLType env
-- printing a type with a lock field lock_C as C -- printing a type with a lock field lock_C as C
prtType :: LTEnv -> Type -> String prtType :: LTEnv -> Type -> String
prtType env ty = case ty of prtType env ty = case ty of
RecType fs -> case filter isLockLabel $ map fst fs of RecType fs -> ---- case filter isLockLabel $ map fst fs of
[lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty ---- [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty
_ -> prtt ty ---- _ ->
prtt ty
Prod x a b -> prtType env a +++ "->" +++ prtType env b Prod x a b -> prtType env a +++ "->" +++ prtType env b
_ -> prtt ty _ -> prtt ty
where where
@@ -1036,7 +1027,7 @@ prtType env ty = case ty of
-- | linearization types and defaults -- | linearization types and defaults
linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) linTypeOfType :: GF -> Ident -> Type -> Check (Context,Type)
linTypeOfType cnc m typ = do linTypeOfType cnc m typ = do
(cont,cat) <- checkErr $ typeSkeleton typ (cont,cat) <- checkErr $ typeSkeleton typ
val <- lookLin cat val <- lookLin cat
@@ -1057,10 +1048,10 @@ linTypeOfType cnc m typ = do
-- | dependency check, detecting circularities and returning topo-sorted list -- | dependency check, detecting circularities and returning topo-sorted list
allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])] allOperDependencies :: Ident -> Map.Map Ident JEntry -> [(Ident,[Ident])]
allOperDependencies m = allDependencies (==m) allOperDependencies m = allDependencies (==m)
allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])] allDependencies :: (Ident -> Bool) -> Map.Map Ident JEntry -> [(Ident,[Ident])]
allDependencies ism b = allDependencies ism b =
[(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b] [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
where where
@@ -1070,14 +1061,8 @@ allDependencies ism b =
_ -> collectOp opersIn t _ -> collectOp opersIn t
opty (Yes ty) = opersIn ty opty (Yes ty) = opersIn ty
opty _ = [] opty _ = []
pts i = case i of pts i = [jtype i, jdef i]
ResOper pty pt -> [pty,pt] ---- AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual
ResParam (Yes (ps,_)) -> [Yes t | (_,cont) <- ps, (_,t) <- cont]
CncCat pty _ _ -> [pty]
CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual
AbsCat (Yes co) _ -> [Yes ty | (_,ty) <- co]
_ -> []
topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] topoSortOpers :: [(Ident,[Ident])] -> Err [Ident]
topoSortOpers st = do topoSortOpers st = do

163
src/GF/Devel/Grammar/AppPredefined.hs Normal file
View File

@@ -0,0 +1,163 @@
----------------------------------------------------------------------
-- |
-- Module : AppPredefined
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/06 14:21:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $
--
-- Predefined function type signatures and definitions.
-----------------------------------------------------------------------------
module GF.Devel.Grammar.AppPredefined (
isInPredefined,
typPredefined,
appPredefined
) where
import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.Macros
import GF.Grammar.PrGF (prt,prt_,prtBad)
import GF.Infra.Ident
import GF.Data.Operations
-- predefined function type signatures and definitions. AR 12/3/2003.
isInPredefined :: Ident -> Bool
isInPredefined = err (const True) (const False) . typPredefined
typPredefined :: Ident -> Err Type
typPredefined c@(IC f) = case f of
"Int" -> return typePType
"Float" -> return typePType
"Error" -> return typeType
"Ints" -> return $ mkFunType [cnPredef "Int"] typePType
"PBool" -> return typePType
"error" -> return $ mkFunType [typeStr] (cnPredef "Error") -- non-can. of empty set
"PFalse" -> return $ cnPredef "PBool"
"PTrue" -> return $ cnPredef "PBool"
"dp" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
"drop" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
"eqInt" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
"lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
"eqStr" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
"length" -> return $ mkFunType [typeTok] (cnPredef "Int")
"occur" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
"occurs" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
"plus" -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
---- "read" -> (P : Type) -> Tok -> P
"show" -> return $ mkProd -- (P : PType) -> P -> Tok
([(zIdent "P",typePType),(wildIdent,Vr (zIdent "P"))],typeStr,[])
"toStr" -> return $ mkProd -- (L : Type) -> L -> Str
([(zIdent "L",typeType),(wildIdent,Vr (zIdent "L"))],typeStr,[])
"mapStr" ->
let ty = zIdent "L" in
return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L
([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[])
"take" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
"tk" -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
_ -> prtBad "unknown in Predef:" c
typPredefined c = prtBad "unknown in Predef:" c
appPredefined :: Term -> Err (Term,Bool)
appPredefined t = case t of
App f x0 -> do
(x,_) <- appPredefined x0
case f of
-- one-place functions
Q (IC "Predef") (IC f) -> case (f, x) of
("length", K s) -> retb $ EInt $ toInteger $ length s
_ -> retb t ---- prtBad "cannot compute predefined" t
-- two-place functions
App (Q (IC "Predef") (IC f)) z0 -> do
(z,_) <- appPredefined z0
case (f, norm z, norm x) of
("drop", EInt i, K s) -> retb $ K (drop (fi i) s)
("take", EInt i, K s) -> retb $ K (take (fi i) s)
("tk", EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s)
("dp", EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s)
("eqStr",K s, K t) -> retb $ if s == t then predefTrue else predefFalse
("occur",K s, K t) -> retb $ if substring s t then predefTrue else predefFalse
("occurs",K s, K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse
("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse
("lessInt",EInt i, EInt j) -> retb $ if i<j then predefTrue else predefFalse
("plus", EInt i, EInt j) -> retb $ EInt $ i+j
("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t
("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags
("toStr", _, t) -> trm2str t >>= retb
_ -> retb t ---- prtBad "cannot compute predefined" t
-- three-place functions
App (App (Q (IC "Predef") (IC f)) z0) y0 -> do
(y,_) <- appPredefined y0
(z,_) <- appPredefined z0
case (f, z, y, x) of
("mapStr",ty,op,t) -> retf $ mapStr ty op t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t ---- prtBad "cannot compute predefined" t
_ -> retb t
---- should really check the absence of arg variables
where
retb t = return (t,True) -- no further computing needed
retf t = return (t,False) -- must be computed further
norm t = case t of
Empty -> K []
_ -> t
fi = fromInteger
-- read makes variables into constants
str2tag :: String -> Term
str2tag s = case s of
---- '\'' : cs -> mkCn $ pTrm $ init cs
_ -> Cn $ IC s ---
where
mkCn t = case t of
Vr i -> Cn i
App c a -> App (mkCn c) (mkCn a)
_ -> t
predefTrue = Q (IC "Predef") (IC "PTrue")
predefFalse = Q (IC "Predef") (IC "PFalse")
substring :: String -> String -> Bool
substring s t = case (s,t) of
(c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
([],_) -> True
_ -> False
trm2str :: Term -> Err Term
trm2str t = case t of
R ((_,(_,s)):_) -> trm2str s
T _ ((_,s):_) -> trm2str s
TSh _ ((_,s):_) -> trm2str s
V _ (s:_) -> trm2str s
C _ _ -> return $ t
K _ -> return $ t
S c _ -> trm2str c
Empty -> return $ t
_ -> prtBad "cannot get Str from term" t
-- simultaneous recursion on type and term: type arg is essential!
-- But simplify the task by assuming records are type-annotated
-- (this has been done in type checking)
mapStr :: Type -> Term -> Term -> Term
mapStr ty f t = case (ty,t) of
_ | elem ty [typeStr,typeTok] -> App f t
(_, R ts) -> R [(l,mapField v) | (l,v) <- ts]
(Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
_ -> t
where
mapField (mty,te) = case mty of
Just ty -> (mty,mapStr ty f te)
_ -> (mty,te)

18
src/GF/Devel/Grammar/Lookup.hs
View File

@@ -4,11 +4,13 @@ import GF.Devel.Grammar.Modules
import GF.Devel.Grammar.Judgements import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Macros
import GF.Devel.Grammar.Terms import GF.Devel.Grammar.Terms
import GF.Devel.Grammar.PrGF
import GF.Infra.Ident import GF.Infra.Ident
import GF.Data.Operations import GF.Data.Operations
import Data.Map import Data.Map
import Data.List (sortBy) ----
-- look up fields for a constant in a grammar -- look up fields for a constant in a grammar
@@ -57,6 +59,22 @@ lookupParamValues gf m c = do
V _ ts -> return ts V _ ts -> return ts
_ -> raise "no parameter values" _ -> raise "no parameter values"
allParamValues :: GF -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of
App (Q (IC "Predef") (IC "Ints")) (EInt n) ->
return [EInt i | i <- [0..n]]
QC p c -> lookupParamValues cnc p c
Q p c -> lookupParamValues cnc p c ----
RecType r -> do
let (ls,tys) = unzip $ sortByFst r
tss <- mapM allPV tys
return [R (zipAssign ls ts) | ts <- combinations tss]
_ -> prtBad "cannot find parameter values for" ptyp
where
allPV = allParamValues cnc
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
-- infrastructure for lookup -- infrastructure for lookup
lookupModule :: GF -> Ident -> Err Module lookupModule :: GF -> Ident -> Err Module

167
src/GF/Devel/Grammar/Macros.hs
View File

@@ -7,9 +7,12 @@ import GF.Infra.Ident
import GF.Data.Operations import GF.Data.Operations
import Data.Map import qualified Data.Map as Map
import Control.Monad (liftM,liftM2) import Control.Monad (liftM,liftM2)
-- analyse types and terms
contextOfType :: Type -> Context contextOfType :: Type -> Context
contextOfType ty = co where (co,_,_) = typeForm ty contextOfType ty = co where (co,_,_) = typeForm ty
@@ -30,9 +33,48 @@ appForm tr = (f,reverse xs) where
App f a -> (f2,a:a2) where (f2,a2) = appForm f App f a -> (f2,a:a2) where (f2,a2) = appForm f
_ -> (t,[]) _ -> (t,[])
valCat :: Type -> Err (Ident,Ident)
valCat typ = case typeForm typ of
(_,Q m c,_) -> return (m,c)
typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
typeRawSkeleton typ = do
let (cont,typ) = prodForm typ
args <- mapM (typeRawSkeleton . snd) cont
return ([(length c, v) | (c,v) <- args], typ)
type MCat = (Ident,Ident)
sortMCat :: String -> MCat
sortMCat s = (identC "_", identC s)
--- hack for Editing.actCat in empty state
errorCat :: MCat
errorCat = (identC "?", identC "?")
getMCat :: Term -> Err MCat
getMCat t = case t of
Q m c -> return (m,c)
QC m c -> return (m,c)
Sort s -> return $ sortMCat s
App f _ -> getMCat f
_ -> error $ "no qualified constant" +++ show t
typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
typeSkeleton typ = do
(cont,val) <- typeRawSkeleton typ
cont' <- mapPairsM getMCat cont
val' <- getMCat val
return (cont',val')
-- construct types and terms
mkProd :: Context -> Type -> Type mkProd :: Context -> Type -> Type
mkProd = flip (foldr (uncurry Prod)) mkProd = flip (foldr (uncurry Prod))
mkFunType :: [Type] -> Type -> Type
mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod
mkApp :: Term -> [Term] -> Term mkApp :: Term -> [Term] -> Term
mkApp = foldl App mkApp = foldl App
@@ -43,6 +85,12 @@ mkCTable :: [Ident] -> Term -> Term
mkCTable ids v = foldr ccase v ids where mkCTable ids v = foldr ccase v ids where
ccase x t = T TRaw [(PV x,t)] ccase x t = T TRaw [(PV x,t)]
appCons :: Ident -> [Term] -> Term
appCons = mkApp . Con
appc :: String -> [Term] -> Term
appc = appCons . identC
tuple2record :: [Term] -> [Assign] tuple2record :: [Term] -> [Assign]
tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts] tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
@@ -67,9 +115,74 @@ mkDecl typ = (wildIdent, typ)
mkLet :: [LocalDef] -> Term -> Term mkLet :: [LocalDef] -> Term -> Term
mkLet defs t = foldr Let t defs mkLet defs t = foldr Let t defs
mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
mkRecType :: (Int -> Label) -> [Type] -> Type
mkRecType = mkRecTypeN 0
plusRecType :: Type -> Type -> Err Type
plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2))
ls -> Bad $ "clashing labels" +++ unwords (map show ls)
_ -> Bad ("cannot add record types" +++ show t1 +++ "and" +++ show t2)
plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
case (t1,t2) of
(R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
_ -> Bad ("cannot add records" +++ show t1 +++ "and" +++ show t2)
zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
-- type constants
typeType :: Type typeType :: Type
typeType = Sort "Type" typeType = Sort "Type"
typePType :: Type
typePType = Sort "PType"
typeStr :: Type
typeStr = Sort "Str"
cPredef :: Ident
cPredef = identC "Predef"
cPredefAbs :: Ident
cPredefAbs = identC "PredefAbs"
typeString, typeFloat, typeInt :: Term
typeInts :: Integer -> Term
typeString = constPredefRes "String"
typeInt = constPredefRes "Int"
typeFloat = constPredefRes "Float"
typeInts i = App (constPredefRes "Ints") (EInt i)
isTypeInts :: Term -> Bool
isTypeInts ty = case ty of
App c _ -> c == constPredefRes "Ints"
_ -> False
constPredefRes :: String -> Term
constPredefRes s = Q (IC "Predef") (identC s)
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q (IC "Predef") _ -> True
Q (IC "PredefAbs") _ -> True
_ -> False
defLinType :: Type
defLinType = RecType [(LIdent "s", typeStr)]
meta0 :: Term meta0 :: Term
meta0 = Meta 0 meta0 = Meta 0
@@ -93,12 +206,14 @@ termOpGF f g = do
termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module
termOpModule f = judgementOpModule fj where termOpModule f = judgementOpModule fj where
fj = either (liftM Left . termOpJudgement f) (return . Right) fj = termOpJudgement f
judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module
judgementOpModule f m = do judgementOpModule f m = do
mjs <- mapMapM f (mjments m) mjs <- mapMapM fj (mjments m)
return m {mjments = mjs} return m {mjments = mjs}
where
fj = either (liftM Left . f) (return . Right)
termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement
termOpJudgement f j = do termOpJudgement f j = do
@@ -194,6 +309,28 @@ composOp co trm = case trm of
_ -> return trm -- covers K, Vr, Cn, Sort _ -> return trm -- covers K, Vr, Cn, Sort
---- should redefine using composOp
collectOp :: (Term -> [a]) -> Term -> [a]
collectOp co trm = case trm of
App c a -> co c ++ co a
Abs _ b -> co b
Prod _ a b -> co a ++ co b
S c a -> co c ++ co a
Table a c -> co a ++ co c
ExtR a c -> co a ++ co c
R r -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r
RecType r -> concatMap (co . snd) r
P t i -> co t
T _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
V _ cc -> concatMap co cc --- nor from type annot
Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
C s1 s2 -> co s1 ++ co s2
Glue s1 s2 -> co s1 ++ co s2
Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
FV ts -> concatMap co ts
_ -> [] -- covers K, Vr, Cn, Sort, Ready
--- just aux to composOp? --- just aux to composOp?
mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))] mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
@@ -207,9 +344,29 @@ changeTableType co i = case i of
TWild ty -> co ty >>= return . TWild TWild ty -> co ty >>= return . TWild
_ -> return i _ -> return i
patt2term :: Patt -> Term
patt2term pt = case pt of
PV x -> Vr x
PW -> Vr wildIdent --- not parsable, should not occur
PC c pp -> mkApp (Con c) (map patt2term pp)
PP p c pp -> mkApp (QC p c) (map patt2term pp)
PR r -> R [assign l (patt2term p) | (l,p) <- r]
PT _ p -> patt2term p
PInt i -> EInt i
PFloat i -> EFloat i
PString s -> K s
PAs x p -> appc "@" [Vr x, patt2term p] --- an encoding
PSeq a b -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
PAlt a b -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
PRep a -> appc "*" [(patt2term a)] --- an encoding
PNeg a -> appc "-" [(patt2term a)] --- an encoding
---- given in lib? ---- given in lib?
mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map k v -> m (Map k v) mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map.Map k v -> m (Map.Map k v)
mapMapM f = mapMapM f =
liftM fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . assocs liftM Map.fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . Map.assocs

153
src/GF/Devel/Grammar/PatternMatch.hs Normal file
View File

@@ -0,0 +1,153 @@
----------------------------------------------------------------------
-- |
-- Module : PatternMatch
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/12 12:38:29 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.7 $
--
-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
-----------------------------------------------------------------------------
module GF.Devel.Grammar.PatternMatch (matchPattern,
testOvershadow,
findMatch
) where
import GF.Grammar.Terms
import GF.Grammar.Macros
import GF.Grammar.PrGF
import GF.Infra.Ident
import GF.Data.Operations
import Data.List
import Control.Monad
matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
matchPattern pts term =
if not (isInConstantForm term)
then prtBad "variables occur in" term
else
errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
findMatch [([p],t) | (p,t) <- pts] [term]
testOvershadow :: [Patt] -> [Term] -> Err [Patt]
testOvershadow pts vs = do
let numpts = zip pts [0..]
let cases = [(p,EInt i) | (p,i) <- numpts]
ts <- mapM (liftM fst . matchPattern cases) vs
return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
findMatch cases terms = case cases of
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
(patts,_):_ | length patts /= length terms ->
Bad ("wrong number of args for patterns :" +++
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs)
_ -> findMatch cc terms
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
tryMatch (p,t) = do
t' <- termForm t
trym p t'
where
isInConstantFormt = True -- tested already
trym p t' =
case (p,t') of
(PVal _ i, (_,Val _ j,_))
| i == j -> return []
| otherwise -> Bad $ "no match of values"
(_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = []
(PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard
(PV x, _) | isInConstantFormt -> return [(x,t)]
(PString s, ([],K i,[])) | s==i -> return []
(PInt s, ([],EInt i,[])) | s==i -> return []
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
(PC p pp, ([], Con f, tt)) |
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PP q p pp, ([], QC r f, tt)) |
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
---- hack for AppPredef bug
(PP q p pp, ([], Q r f, tt)) |
-- q `eqStrIdent` r && ---
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PR r, ([],R r',[])) |
all (`elem` map fst r') (map fst r) ->
do matches <- mapM tryMatch
[(p,snd a) | (l,p) <- r, let Just a = lookup l r']
return (concat matches)
(PT _ p',_) -> trym p' t'
(_, ([],Alias _ _ d,[])) -> tryMatch (p,d)
-- (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do
(PAs x p',_) -> do
subst <- trym p' t'
return $ (x,t) : subst
(PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
(PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return []
_ -> prtBad "no match with negative pattern" p
(PSeq p1 p2, ([],K s, [])) -> do
let cuts = [splitAt n s | n <- [0 .. length s]]
matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
return (concat matches)
(PRep p1, ([],K s, [])) -> checks [
trym (foldr (const (PSeq p1)) (PString "")
[1..n]) t' | n <- [0 .. length s]
] >>
return []
_ -> prtBad "no match in case expr for" t
isInConstantForm :: Term -> Bool
isInConstantForm trm = case trm of
Cn _ -> True
Con _ -> True
Q _ _ -> True
QC _ _ -> True
Abs _ _ -> True
App c a -> isInConstantForm c && isInConstantForm a
R r -> all (isInConstantForm . snd . snd) r
K _ -> True
Empty -> True
Alias _ _ t -> isInConstantForm t
EInt _ -> True
_ -> False ---- isInArgVarForm trm
varsOfPatt :: Patt -> [Ident]
varsOfPatt p = case p of
PV x -> [x | not (isWildIdent x)]
PC _ ps -> concat $ map varsOfPatt ps
PP _ _ ps -> concat $ map varsOfPatt ps
PR r -> concat $ map (varsOfPatt . snd) r
PT _ q -> varsOfPatt q
_ -> []
-- | to search matching parameter combinations in tables
isMatchingForms :: [Patt] -> [Term] -> Bool
isMatchingForms ps ts = all match (zip ps ts') where
match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
match _ = True
ts' = map appForm ts