internal representation for param value index

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:

lib/resource-1.0/common/ConstructX.gf

@@ -1,3 +1,5 @@
+--# -path=.:../abstract:prelude
+
 resource ConstructX = open CommonX in {
 
   oper

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

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 :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
-checkResInfo gr (c,info) = do
+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
+       termWith trm $ checkErr (lookupResType gr m ident) >>= comp
-     ,
+       ,
-     checkErr (lookupResDef gr m ident) >>= infer
+       checkErr (lookupResDef gr m ident) >>= infer
-     ,
+       ,
-     prtFail "cannot infer type of canonical constant" trm
+       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)
+  ResParam (Yes (pp,m)) -> do
-  ResValue t  -> liftM ResValue (ren t)
+    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

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/)
+ | ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/)
- | ResValue (Perh Type)                    -- ^ (/RES/) to mark parameter constructors for lookup
+ | 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

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 (Yes psm) -> return psm
-          ---- ResParam   Nope   -> if isTop then lookExt m c 
+
-          ----                       else prtBad "cannot find params in exts" c 
           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
+  (ps,mpv) <- lookupParams gr m c
-  liftM concat $ mapM mkPar ps
+  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) -> 

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

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

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

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']
+                                  else (yes (pars,Nothing)))) 
-           ++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p)))) |
+                                     | (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

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