diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index 79c45f337..213f5d304 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -177,16 +177,20 @@ reorder abs cg = M.MGrammar $ finfo <- tree2list (M.jments mo)] predefADefs = [(IC c, AbsCat (Yes []) Nope) | c <- ["Float","Int","String"]] - aflags = nubFlags $ concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo] + aflags = nubFlags $ + concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo] cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] - concr la = (nubFlags (concat flags), sortIds (predefCDefs ++ concat jments)) where - (flags,jments) = unzip $ cdata la - cdata la = [(M.flags mo, tree2list (M.jments mo)) | - (i,mo) <- mos, M.isModCnc mo, elem i (M.allExtends cg la)] - predefCDefs = - [(IC c, CncCat (Yes GM.defLinType) Nope Nope) | ---- lindef,printname - c <- ["Float","Int","String"]] + concr la = (nubFlags flags, + sortIds (predefCDefs ++ jments)) where + jments = Look.allOrigInfos cg la + flags = concat [M.flags mo | + (i,mo) <- mos, M.isModCnc mo, + Just r <- [lookup i (M.allExtendSpecs cg la)]] + + predefCDefs = [(IC c, CncCat (Yes GM.defLinType) Nope Nope) | + ---- lindef,printname + c <- ["Float","Int","String"]] sortIds = sortBy (\ (f,_) (g,_) -> compare f g) nubFlags = nubBy (\ (Opt (f,_)) (Opt (g,_)) -> f == g) @@ -301,7 +305,9 @@ paramValues cgr = (labels,untyps,typs) where Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] lincats = [(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Int", "Float", "String"]] ++ - [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments] + reverse ---- TODO: really those lincats that are reached + ---- reverse is enough to expel overshadowed ones... + [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments] labels = Map.fromList $ concat [((cat,[lab]),(typ,i)): [((cat,[lab,lab2]),(ty,j)) | @@ -400,13 +406,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps where - tryPerm tr = case tr of -{- obsolete ---- - R rs -> case Map.lookup (R rs) untyps of - Just v -> EInt v - _ -> valNumFV $ tryVar tr --} - _ -> valNumFV $ tryVar tr + tryPerm tr = valNumFV $ tryVar tr tryVar tr = case GM.appForm tr of (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryVar ts)] (FV ts,_) -> ts diff --git a/src/GF/GFCC/Linearize.hs b/src/GF/GFCC/Linearize.hs index 572b8fe08..b7b419f7d 100644 --- a/src/GF/GFCC/Linearize.hs +++ b/src/GF/GFCC/Linearize.hs @@ -6,6 +6,8 @@ import GF.GFCC.AbsGFCC import Data.Map import Data.List +import Debug.Trace + -- linearization and computation of concrete GFCC Terms linearize :: GFCC -> CId -> Exp -> String @@ -53,7 +55,7 @@ compute mcfg lang args = comp where look = lookOper mcfg lang idx xs i = if i > length xs - 1 - then error + then trace ("too large " ++ show i ++ " for\n" ++ unlines (lmap prt xs) ++ "\n") TM else xs !! i @@ -71,7 +73,7 @@ compute mcfg lang args = comp where C i -> i RP p _ -> getIndex p ---- DEPREC TM -> 0 -- default value for parameter - _ -> error ("ERROR in grammar compiler: index from " ++ show t) 0 + _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 666 getField t i = case t of R rs -> idx rs i diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs index a0d0d1cea..01f6c20a1 100644 --- a/src/GF/Grammar/Lookup.hs +++ b/src/GF/Grammar/Lookup.hs @@ -24,6 +24,7 @@ module GF.Grammar.Lookup ( lookupFirstTag, lookupValueIndex, lookupIndexValue, + allOrigInfos, allParamValues, lookupAbsDef, lookupLincat, @@ -121,6 +122,17 @@ lookupOverload gr m c = do _ -> Bad $ prt c +++ "is not an overloaded operation" _ -> Bad $ prt m +++ "is not a resource" +lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info +lookupOrigInfo gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupIdentInfo mo c + case info of + AnyInd _ n -> lookupOrigInfo gr n c + i -> return i + _ -> Bad $ prt m +++ "is not run-time module" + lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues) lookupParams gr = look True where look isTop m c = do @@ -169,6 +181,14 @@ lookupIndexValue gr ty i = do then return $ ts !! i else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty +allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)] +allOrigInfos gr m = errVal [] $ do + mi <- lookupModule gr m + case mi of + ModMod mo -> return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]] + where + look = lookupOrigInfo gr m + allParamValues :: SourceGrammar -> Type -> Err [Term] allParamValues cnc ptyp = case ptyp of App (Q (IC "Predef") (IC "Ints")) (EInt n) -> diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index b0fe1b0ba..4d50608c6 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -28,7 +28,8 @@ module GF.Infra.Modules ( oSimple, oQualif, ModuleStatus(..), openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar, - allExtends, allExtendsPlus, allExtensions, searchPathModule, addModule, + allExtends, allExtendSpecs, allExtendsPlus, allExtensions, + searchPathModule, addModule, emptyMGrammar, emptyModInfo, emptyModule, IdentM(..), typeOfModule, abstractOfConcrete, abstractModOfConcrete, @@ -216,8 +217,7 @@ partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor] ---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ---- _ -> [i] - --- | all modules that a module extends, directly or indirectly +-- | all modules that a module extends, directly or indirectly, without restricts allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i] allExtends gr i = case lookupModule gr i of Ok (ModMod m) -> case extends m of @@ -225,6 +225,14 @@ allExtends gr i = case lookupModule gr i of is -> i : concatMap (allExtends gr) is _ -> [] +-- | all modules that a module extends, directly or indirectly, with restricts +allExtendSpecs :: (Show i,Ord i) => MGrammar i f a -> i -> [(i,MInclude i)] +allExtendSpecs gr i = case lookupModule gr i of + Ok (ModMod m) -> case extend m of + [] -> [(i,MIAll)] + is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is + _ -> [] + -- | this plus that an instance extends its interface allExtendsPlus :: (Show i,Ord i) => MGrammar i f a -> i -> [i] allExtendsPlus gr i = case lookupModule gr i of