From 4b28aa89faaadb66e6a81fcbeda5a7e6dd34f83a Mon Sep 17 00:00:00 2001 From: aarne Date: Tue, 14 Nov 2006 19:13:33 +0000 Subject: [PATCH] internal representation for param value index --- lib/resource-1.0/Makefile | 2 ++ lib/resource-1.0/common/ConstructX.gf | 2 ++ src/GF/Canon/CanonToGrammar.hs | 4 +++- src/GF/Compile/CheckGrammar.hs | 33 +++++++++++++++------------ src/GF/Compile/Evaluate.hs | 7 ++++++ src/GF/Compile/GrammarToCanon.hs | 2 +- src/GF/Compile/PrOld.hs | 2 +- src/GF/Compile/Rebuild.hs | 26 --------------------- src/GF/Compile/Rename.hs | 8 +++++-- src/GF/Grammar/Grammar.hs | 11 +++++++-- src/GF/Grammar/Lookup.hs | 31 +++++++++++++++++++------ src/GF/Grammar/Macros.hs | 8 ++++++- src/GF/Grammar/PatternMatch.hs | 3 +++ src/GF/Source/GrammarToSource.hs | 2 +- src/GF/Source/SourceToGrammar.hs | 5 ++-- src/GF/UseGrammar/Information.hs | 4 ++-- 16 files changed, 89 insertions(+), 61 deletions(-) diff --git a/lib/resource-1.0/Makefile b/lib/resource-1.0/Makefile index aa050f5ce..b804f144f 100644 --- a/lib/resource-1.0/Makefile +++ b/lib/resource-1.0/Makefile @@ -32,6 +32,7 @@ alltenses: $(GFC) russian/Russian.gf $(GFC) spanish/Spanish.gf $(GFC) swedish/Swedish.gf + $(GFC) common/ConstructX.gf cp -p */*.gfc */*.gfr ../alltenses langs: @@ -50,6 +51,7 @@ present: $(GFCP) russian/LangRus.gf $(GFCP) spanish/Spanish.gf $(GFCP) swedish/Swedish.gf + $(GFCP) common/ConstructX.gf mv */*.gfc */*.gfr ../present mathematical: diff --git a/lib/resource-1.0/common/ConstructX.gf b/lib/resource-1.0/common/ConstructX.gf index 45ebb1847..ee4decf00 100644 --- a/lib/resource-1.0/common/ConstructX.gf +++ b/lib/resource-1.0/common/ConstructX.gf @@ -1,3 +1,5 @@ +--# -path=.:../abstract:prelude + resource ConstructX = open CommonX in { oper diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs index 780a953e1..da40425f0 100644 --- a/src/GF/Canon/CanonToGrammar.hs +++ b/src/GF/Canon/CanonToGrammar.hs @@ -69,7 +69,9 @@ redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do AbsTrans t -> do return $ G.AbsTrans t - ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par + ResPar par -> do + par' <- mapM redParam par + return $ G.ResParam (Yes (par',Nothing)) ---- list of values CncCat pty ptr ppr -> do ty' <- redCType pty diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 0ef79123e..f0da2386a 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -61,7 +61,7 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod MTTransfer a b -> mapMTree (checkAbsInfo gr name) js - MTResource -> mapMTree (checkResInfo gr) js + MTResource -> mapMTree (checkResInfo gr name) js MTConcrete a -> do checkErr $ topoSortOpers $ allOperDependencies name js @@ -69,12 +69,12 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod js1 <- checkCompleteGrammar abs mo mapMTree (checkCncInfo gr name (a,abs)) js1 - MTInterface -> mapMTree (checkResInfo gr) js + MTInterface -> mapMTree (checkResInfo gr name) js MTInstance a -> do ModMod abs <- checkErr $ lookupModule gr a -- checkCompleteInstance abs mo -- this is done in Rebuild - mapMTree (checkResInfo gr) js + mapMTree (checkResInfo gr name) js return $ (name, ModMod (Module mt st fs me ops js')) : ms @@ -167,8 +167,8 @@ checkCompleteGrammar abs cnc = do -- | General Principle: only Yes-values are checked. -- A May-value has always been checked in its origin module. -checkResInfo :: SourceGrammar -> (Ident,Info) -> Check (Ident,Info) -checkResInfo gr (c,info) = do +checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) +checkResInfo gr mo (c,info) = do checkReservedId c case info of @@ -187,10 +187,11 @@ checkResInfo gr (c,info) = do _ -> return (pty, pde) --- other cases are uninteresting return (c, ResOper pty' pde') - ResParam (Yes pcs) -> chIn "parameter type" $ do + ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do ---- mapM ((mapM (computeLType gr . snd)) . snd) pcs mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs - return (c,info) + ts <- checkErr $ lookupParamValues gr mo c + return (c,ResParam (Yes (pcs, Just ts))) _ -> return (c,info) where @@ -226,7 +227,7 @@ checkCncInfo gr m (a,abs) (c,info) = do checkPrintname gr mpr return (c,CncCat (Yes typ') mdef' mpr) - _ -> checkResInfo gr (c,info) + _ -> checkResInfo gr m (c,info) where env = gr @@ -360,12 +361,14 @@ inferLType gr trm = case trm of QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) QC m ident -> checks [ - termWith trm $ checkErr (lookupResType gr m ident) >>= comp - , - checkErr (lookupResDef gr m ident) >>= infer - , - prtFail "cannot infer type of canonical constant" trm - ] + termWith trm $ checkErr (lookupResType gr m ident) >>= comp + , + checkErr (lookupResDef gr m ident) >>= infer + , + prtFail "cannot infer type of canonical constant" trm + ] + + Val ty i -> termWith trm $ return ty Vr ident -> termWith trm $ checkLookup ident @@ -384,7 +387,7 @@ inferLType gr trm = case trm of then return val else substituteLType [(z,a')] val return (App f' a',ty) - _ -> prtFail ("function type expected for" +++ prt f +++ "instead of") fty + _ -> prtFail ("function type expected for"+++ prt f +++"instead of") fty S f x -> do (f', fty) <- infer f diff --git a/src/GF/Compile/Evaluate.hs b/src/GF/Compile/Evaluate.hs index 41a6ee17d..a574fef40 100644 --- a/src/GF/Compile/Evaluate.hs +++ b/src/GF/Compile/Evaluate.hs @@ -151,6 +151,13 @@ evalConcrete gr mo = mapMTree evaldef mo where return d Just d -> fterm2term d >>= comp g App f a -> case apps t of +{- ---- + (h@(QC p c),xs) -> do + xs' <- mapM (comp g) xs + case lookupValueIndex gr ty t of + Ok v -> return v + _ -> return t +-} (h@(Q p c),xs) | p == IC "Predef" -> do xs' <- mapM (comp g) xs (t',b) <- stmErr $ appPredefined (foldl App h xs') diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs index 25ec623e8..e0e245163 100644 --- a/src/GF/Compile/GrammarToCanon.hs +++ b/src/GF/Compile/GrammarToCanon.hs @@ -104,7 +104,7 @@ redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do AbsTrans t -> returns c' $ C.AbsTrans t - ResParam (Yes ps) -> do + ResParam (Yes (ps,_)) -> do ps' <- mapM redParam ps returns c' $ C.ResPar ps' diff --git a/src/GF/Compile/PrOld.hs b/src/GF/Compile/PrOld.hs index 7aa0db623..29920fab6 100644 --- a/src/GF/Compile/PrOld.hs +++ b/src/GF/Compile/PrOld.hs @@ -49,7 +49,7 @@ stripInfo (c,i) = case i of AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr)) AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope - ResParam (Yes ps) -> rc $ ResParam (Yes [(c,stripContext co) | (c,co)<- ps]) + ResParam (Yes (ps,m)) -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing)) CncCat (Yes ty) _ _ -> rc $ CncCat (Yes (stripTerm ty)) nope nope CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs index 452a485c8..52224c4a1 100644 --- a/src/GF/Compile/Rebuild.hs +++ b/src/GF/Compile/Rebuild.hs @@ -91,29 +91,3 @@ checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $ then id else (("Error: no definition given to" +++ prt f):) -{- ---- should not be needed -qualifInstanceInfo :: [(Ident,Ident)] -> (Ident,Info) -> (Ident,Info) -qualifInstanceInfo insts (c,i) = (c,qualInfo i) where - - qualInfo i = case i of - ResOper pty pt -> ResOper (qualP pty) (qualP pt) - CncCat pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp) - CncFun mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp - ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) - ResValue pty -> ResValue (qualP pty) - _ -> i - qualP pt = case pt of - Yes t -> yes $ qual t - May m -> may $ qualId m - _ -> pt - qualId x = maybe x id $ lookup x insts - qual t = case t of - Q m c -> Q (qualId m) c - QC m c -> QC (qualId m) c - _ -> composSafeOp qual t - qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co]) - qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t))) - qualLin Nothing = Nothing - - -- NB constructor patterns never appear in interfaces so we need not rename them --} diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 05fdfa077..4276fc6e8 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -159,8 +159,12 @@ renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ AbsTrans f -> liftM AbsTrans (rent f) ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) - ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp) - ResValue t -> liftM ResValue (ren t) + ResParam (Yes (pp,m)) -> do + pp' <- mapM (renameParam status) pp + return $ ResParam $ Yes (pp',m) + ResValue (Yes (t,m)) -> do + t' <- rent t + return $ ResValue $ Yes (t',m) CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr) CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr) _ -> return info diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs index 1c963ac66..f49075f48 100644 --- a/src/GF/Grammar/Grammar.hs +++ b/src/GF/Grammar/Grammar.hs @@ -21,6 +21,7 @@ module GF.Grammar.Grammar (SourceGrammar, SourceRes, SourceCnc, Info(..), + PValues, Perh, MPr, Type, @@ -68,6 +69,9 @@ type SourceAbs = Module Ident Option Info type SourceRes = Module Ident Option Info type SourceCnc = Module Ident Option Info +-- this is created in CheckGrammar, and so are Val and PVal +type PValues = [Term] + -- | the constructors are judgements in -- -- - abstract syntax (/ABS/) @@ -84,8 +88,8 @@ data Info = | AbsTrans Term -- ^ (/ABS/) -- judgements in resource - | ResParam (Perh [Param]) -- ^ (/RES/) - | ResValue (Perh Type) -- ^ (/RES/) to mark parameter constructors for lookup + | ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/) + | ResValue (Perh (Type,Maybe Int)) -- ^ (/RES/) to mark parameter constructors for lookup | ResOper (Perh Type) (Perh Term) -- ^ (/RES/) -- judgements in concrete syntax @@ -139,6 +143,7 @@ data Term = | TSh TInfo [Cases] -- ^ table with discjunctive patters (only back end opt) | V Type [Term] -- ^ table given as course of values: @table T [c1 ; ... ; cn]@ | S Term Term -- ^ selection: @t ! p@ + | Val Type Int -- ^ parameter value number: @T # i# | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ @@ -173,6 +178,8 @@ data Patt = | PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract | PT Type Patt -- ^ type-annotated pattern + | PVal Type Int -- ^ parameter value number: @T # i# + | PAs Ident Patt -- ^ as-pattern: x@p -- regular expression patterns diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index 1620474e6..9f360dfcd 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -21,6 +21,8 @@ module GF.Grammar.Lookup ( lookupParams, lookupParamValues, lookupFirstTag, + lookupValueIndex, + lookupIndexValue, allParamValues, lookupAbsDef, lookupLincat, @@ -87,7 +89,7 @@ lookupResType gr m c = do CncFun _ _ _ -> lookFunType m m c AnyInd _ n -> lookupResType gr n c ResParam _ -> return $ typePType - ResValue (Yes t) -> return $ qualifAnnotPar m t + ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t _ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m _ -> Bad $ prt m +++ "is not a resource" where @@ -104,7 +106,7 @@ lookupResType gr m c = do _ -> prtBad "cannot find type of reused function" c -lookupParams :: SourceGrammar -> Ident -> Ident -> Err [Param] +lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues) lookupParams gr = look True where look isTop m c = do mi <- lookupModule gr m @@ -112,9 +114,8 @@ lookupParams gr = look True where ModMod mo -> do info <- lookupIdentInfo mo c case info of - ResParam (Yes ps) -> return ps - ---- ResParam Nope -> if isTop then lookExt m c - ---- else prtBad "cannot find params in exts" c + ResParam (Yes psm) -> return psm + AnyInd _ n -> look False n c _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m _ -> Bad $ prt m +++ "is not a resource" @@ -123,8 +124,10 @@ lookupParams gr = look True where lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term] lookupParamValues gr m c = do - ps <- lookupParams gr m c - liftM concat $ mapM mkPar ps + (ps,mpv) <- lookupParams gr m c + case mpv of + Just ts -> return ts + _ -> liftM concat $ mapM mkPar ps where mkPar (f,co) = do vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gr ty) co @@ -137,6 +140,20 @@ lookupFirstTag gr m c = do v:_ -> return v _ -> prtBad "no parameter values given to type" c +lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term +lookupValueIndex gr ty tr = do + ts <- allParamValues gr ty + case lookup tr $ zip ts [0..] of + Just i -> return $ Val ty i + _ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty + +lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term +lookupIndexValue gr ty i = do + ts <- allParamValues gr ty + if i < length ts + then return $ ts !! i + else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty + allParamValues :: SourceGrammar -> Type -> Err [Term] allParamValues cnc ptyp = case ptyp of App (Q (IC "Predef") (IC "Ints")) (EInt n) -> diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index a3cad8bae..9d93a0258 100644 --- a/src/GF/Grammar/Macros.hs +++ b/src/GF/Grammar/Macros.hs @@ -496,6 +496,7 @@ linDefStr = Abs s (R [assign (linLabel 0) (Vr s)]) where s = zIdent "s" term2patt :: Term -> Err Patt term2patt trm = case termForm trm of Ok ([], Vr x, []) -> return (PV x) + Ok ([], Val ty x, []) -> return (PVal ty x) Ok ([], Con c, aa) -> do aa' <- mapM term2patt aa return (PC c aa') @@ -535,7 +536,8 @@ term2patt trm = case termForm trm of patt2term :: Patt -> Term patt2term pt = case pt of PV x -> Vr x - PW -> Vr wildIdent --- not parsable, should not occur + PW -> Vr wildIdent --- not parsable, should not occur + PVal t i -> Val t i 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] @@ -694,6 +696,10 @@ composOp co trm = vs' <- mapM co vs return (V ty' vs') + Val ty i -> + do ty' <- co ty + return (Val ty' i) + Let (x,(mt,a)) b -> do a' <- co a mt' <- case mt of diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs index 7635e6fa1..804333b14 100644 --- a/src/GF/Grammar/PatternMatch.hs +++ b/src/GF/Grammar/PatternMatch.hs @@ -56,6 +56,9 @@ tryMatch (p,t) = do where 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, _) | isInConstantForm t -> return [] -- optimization with wildcard (PV x, _) | isInConstantForm t -> return [(x,t)] diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index 38c658dc4..a20eb7830 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -90,7 +90,7 @@ trAnyDef (i,info) = let i' = tri i in case info of ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]] ResParam pp -> [P.DefPar [case pp of - Yes ps -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps] + Yes (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps] May b -> P.ParDefIndir i' $ tri b _ -> P.ParDefAbs i']] diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index c77a9f47b..dadf8c3af 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -293,8 +293,9 @@ transResDef x = case x of pardefs' <- mapM transParDef pardefs returnl $ [(p, G.ResParam (if null pars then nope -- abstract param type - else (yes pars))) | (p,pars) <- pardefs'] - ++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p)))) | + else (yes (pars,Nothing)))) + | (p,pars) <- pardefs'] + ++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) | (p,pars) <- pardefs', (f,co) <- pars] DefOper defs -> do defs' <- liftM concat $ mapM getDefs defs diff --git a/src/GF/UseGrammar/Information.hs b/src/GF/UseGrammar/Information.hs index 900b1b126..4526980d6 100644 --- a/src/GF/UseGrammar/Information.hs +++ b/src/GF/UseGrammar/Information.hs @@ -129,10 +129,10 @@ getInformation opts st c = allChecks $ [ rs <- return [] returnm i $ IFunCnc i tr rs tr --- ResOper (Yes ty) (Yes tr) -> returnm i $ IOper i ty tr - ResParam (Yes ps) -> do + ResParam (Yes (ps,_)) -> do ts <- allParamValues src (QC i c) returnm i $ IParam i ps ts - ResValue (Yes ty) -> returnm i $ IValue i ty --- + ResValue (Yes (ty,_)) -> returnm i $ IValue i ty --- _ -> prtBad "nothing available for" i lookInCan (i,m) = do