internal representation for param value index

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

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')

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'
 

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

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
--}

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