Rebuilding resource libraries.

Rebuilding resource libraries.
Working with resource interfaces.

src/GF/Canon/Look.hs

@@ -112,6 +112,9 @@ ccompute cnc = comp []
           if noVar v' 
              then matchPatt cs v' >>= compt
              else return $ S u' v'
+        FV ccs -> do
+          v' <- compt v
+          mapM (\c -> compt (S c v')) ccs >>= return . FV
 
         _      -> liftM (S u') $ compt v
 

src/GF/Compile/CheckGrammar.hs

@@ -101,7 +101,7 @@ checkResInfo gr (c,info) = do
            ty'     <- check ty typeType >>= comp . fst
            (de',_) <- check de ty'
            return (Yes ty', Yes de')
-         (Nope, Yes de) -> do
+         (_, Yes de) -> do
            (de',ty') <- infer de
            return (Yes ty', Yes de')
          _ -> return (pty, pde) --- other cases are uninteresting
@@ -611,6 +611,10 @@ checkEqLType env t u trm = do
                                || elem n (allExtends env m)
      (QC m a, QC n b) | a == b -> elem m (allExtends env n) 
                                || elem n (allExtends env m)
+     (QC m a, Q  n b) | a == b -> elem m (allExtends env n) 
+                               || elem n (allExtends env m)
+     (Q  m a, QC n b) | a == b -> elem m (allExtends env n) 
+                               || elem n (allExtends env m)
 
      (RecType rs, RecType ts) -> and [alpha g a b && l == k --- too strong req
                                         | ((l,a),(k,b)) <- zip rs ts]

src/GF/Compile/Extend.hs

@@ -27,8 +27,9 @@ extendModInfo name old new = case (old,new) of
 
 extendMod :: Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
              Err (BinTree (Ident,Info))
-extendMod name old new = 
-  foldM (tryInsert (extendAnyInfo name) (indirInfo name)) new $ tree2list old
+extendMod name old new = foldM try new $ tree2list old where
+  try t i@(c,_) = errIn ("constant" +++ prt c) $
+                  tryInsert (extendAnyInfo name) (indirInfo name) t i
 
 indirInfo :: Ident -> Info -> Info
 indirInfo n info = AnyInd b n' where 
@@ -58,7 +59,7 @@ perhIndir n p = case p of
   _ -> p
 
 extendAnyInfo :: Ident -> Info -> Info -> Err Info
-extendAnyInfo n i j = case (i,j) of
+extendAnyInfo n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of
   (AbsCat mc1 mf1, AbsCat mc2 mf2) -> 
     liftM2 AbsCat (updatePerhaps n mc1 mc2) (updatePerhaps n mf1 mf2) --- add cstrs
   (AbsFun mt1 md1, AbsFun mt2 md2) -> 
@@ -66,8 +67,7 @@ extendAnyInfo n i j = case (i,j) of
 
   (ResParam mt1, ResParam mt2) -> liftM ResParam $ updatePerhaps n mt1 mt2
   (ResValue mt1, ResValue mt2) -> liftM ResValue $ updatePerhaps n mt1 mt2
-  (ResOper mt1 m1, ResOper mt2 m2) -> 
-    liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2)
+  (ResOper mt1 m1, ResOper mt2 m2) -> extendResOper n mt1 m1 mt2 m2 
 
   (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
     liftM3 CncCat (updatePerhaps n mc1 mc2) 
@@ -75,4 +75,20 @@ extendAnyInfo n i j = case (i,j) of
   (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
     liftM2 (CncFun m) (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2)
 
-  _ -> Bad $ "cannot unify information for" +++ show n
+  (AnyInd _ _, ResOper _ _) -> return j ----
+
+  _ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j
+
+
+-- opers declared in one module and defined in an extension are a special case
+
+extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of
+  (Nope,_) -> return $ ResOper (strip mt1) m2
+  _ -> liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2)
+ where
+   strip (Yes t) = Yes $ strp t
+   strip m = m
+   strp t = case t of
+     Q _ c  -> Vr c
+     QC _ c -> Vr c
+     _ -> composSafeOp strp t

src/GF/Compile/Rename.hs

@@ -62,7 +62,7 @@ extendModule ms (name,mod) = case mod of
           _ -> Bad $ "cannot find extended module" +++ prt n
         extendMod n (jments m0) js
       _ -> return js
-    return $ (name,ModMod (Module mt fs Nothing ops js1))
+    return $ (name,ModMod (Module mt fs me ops js1))
 
 
 type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
@@ -72,7 +72,9 @@ type StatusTree = BinTree (Ident,StatusInfo)
 type StatusInfo = Ident -> Term
 
 renameIdentTerm :: Status -> Term -> Err Term
-renameIdentTerm env@(act,imps) t = case t of
+renameIdentTerm env@(act,imps) t = 
+ errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
+   case t of
   Vr c -> do
     f <- lookupTreeMany prt opens c
     return $ f c
@@ -90,7 +92,8 @@ renameIdentTerm env@(act,imps) t = case t of
   _ -> return t
  where
    opens   = act : [st  | (OSimple _,st) <- imps]
-   qualifs = [  (m, st) | (OQualif m _, st) <- imps]
+   qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ 
+             [(m, st) | (OSimple m, st) <- imps] -- qualifying is always possible
 
 --- would it make sense to optimize this by inlining?
 renameIdentPatt :: Status -> Patt -> Err Patt
@@ -117,8 +120,9 @@ tree2status o = case o of
 buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
 buildStatus gr c mo = let mo' = self2status c mo in case mo of
   ModMod m -> do
-    let ops  = allOpens m
-    mods <- mapM (lookupModule gr . openedModule) ops
+    let gr1 = MGrammar $ (c,mo) : modules gr 
+        ops = [OSimple e | e <- allExtends gr1 c] ++ allOpens m
+    mods <- mapM (lookupModule gr1 . openedModule) ops
     let sts = map modInfo2status $ zip ops mods    
     return $ if isModCnc m
       then (NT, sts) -- the module itself does not define any names

src/GF/Data/Operations.hs

@@ -168,6 +168,14 @@ updatePerhaps old p1 p2 = case (p1,p2) of
   (_, May a)        -> Bad "strange indirection"
   _ -> unifPerhaps p1 p2
 
+-- here the value is copied instead of referred to; used for oper types
+updatePerhapsHard :: b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
+updatePerhapsHard old p1 p2 = case (p1,p2) of
+  (Yes a,    Nope)  -> return $ yes a
+  (May older,Nope)  -> return $ may older
+  (_, May a)        -> Bad "strange indirection"
+  _ -> unifPerhaps p1 p2
+
 -- binary search trees
 
 data BinTree a = NT | BT a (BinTree a) (BinTree a) deriving (Show,Read)

src/GF/Grammar/Lookup.hs

@@ -17,6 +17,7 @@ lookupResDef gr m c = do
       info <- lookupInfo mo c
       case info of
         ResOper _ (Yes t) -> return $ qualifAnnot m t 
+        ResOper _ Nope    -> return $ Q m c
         AnyInd _ n        -> lookupResDef gr n c
         ResParam _        -> return $ QC m c
         ResValue _        -> return $ QC m c
@@ -31,6 +32,7 @@ lookupResType gr m c = do
       info <- lookupInfo mo c
       case info of
         ResOper (Yes t) _ -> return $ qualifAnnot m t
+        ResOper (May n) _ -> lookupResType gr n c
         AnyInd _ n        -> lookupResType gr n c
         ResParam _        -> return $ typePType
         ResValue (Yes t)  -> return $ qualifAnnotPar m t