compute the parameter indices

src/compiler/GF/Compile/CheckGrammar.hs

@@ -33,14 +33,13 @@ import qualified GF.Compile.Compute.ConcreteNew as CN
 import GF.Grammar
 import GF.Grammar.Lexer
 import GF.Grammar.Lookup
---import GF.Grammar.Predef
---import GF.Grammar.PatternMatch
 
 import GF.Data.Operations
 import GF.Infra.CheckM
 
 import Data.List
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 import Control.Monad
 import GF.Text.Pretty
 
@@ -260,18 +259,30 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
       return (ResOverload os [(y,x) | (x,y) <- tysts'])
 
     ResParam (Just (L loc pcs)) _ -> do
-      ts <- chIn loc "parameter type" $ 
+      (vs,pcs) <- chIn loc "parameter type" $
-              liftM concat $ mapM mkPar pcs
+                    mkParams 0 [] pcs
-      return (ResParam (Just (L loc pcs)) (Just ts))
+      return (ResParam (Just (L loc pcs)) (Just vs))
+
+    ResValue (L loc ty) _ -> 
+      chIn loc "operation" $ do
+        let (_,Cn x) = typeFormCnc ty
+            is = case Map.lookup x (jments mo) of
+                   Just (ResParam (Just (L _ pcs)) _) -> [i | (f,_,i) <- pcs, f == c]
+                   _                                  -> []
+        case is of
+          [i] -> return (ResValue (L loc ty) i)
+          _   -> checkError (pp "Failed to find the value index for parameter" <+> pp c)
 
     _ ->  return info
  where
    gr = prependModule sgr (m,mo)
    chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
 
-   mkPar (f,co) = do
+   mkParams i vs []             = return (vs,[])
-       vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
+   mkParams i vs ((f,co,_):pcs) = do
-       return $ map (mkApp (QC (m,f))) vs
+     vs0 <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
+     (vs,pcs) <- mkParams (i + length vs0) (vs ++ map (mkApp (QC (m,f))) vs0) pcs
+     return (vs,(f,co,i):pcs)
 
    checkUniq xss = case xss of
      x:y:xs 

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -353,9 +353,9 @@ paramType gr q@(_,n) =
             [ParamAliasDef ((gQId m n)) (convType t)])
       _ -> ((S.empty,S.empty),[])
   where
-    param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
+    param m (n,ctx,_) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
     argTypes = S.unions . map argTypes1
-    argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
+    argTypes1 (n,ctx,_) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
 
 lblId = LabelId . render -- hmm
 modId (MN m) = ModId (showIdent m)

src/compiler/GF/Compile/Rename.hs

@@ -156,9 +156,9 @@ renameInfo cwd status (m,mi) i info =
     ResParam (Just pp) m -> do
       pp' <- renLoc (mapM (renParam status)) pp
       return (ResParam (Just pp') m)
-    ResValue offset ty -> do
+    ResValue ty offset -> do
       t <- renLoc (renameTerm status []) ty
-      return (ResValue offset ty)
+      return (ResValue ty offset)
     CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
     CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty)         (renTerm mtr) (renTerm mpr) (return mpmcfg)
     _ -> return info
@@ -186,9 +186,9 @@ renameInfo cwd status (m,mi) i info =
         return (ps',t')
 
     renParam :: Status -> Param -> Check Param
-    renParam env (c,co) = do
+    renParam env (c,co,i) = do
       co' <- renameContext env co
-      return (c,co')
+      return (c,co',i)
 
 renameTerm :: Status -> [Ident] -> Term -> Check Term
 renameTerm env vars = ren vars where

src/compiler/GF/Compile/Tags.hs

@@ -31,7 +31,7 @@ getLocalTags x (m,mi) =
     getLocations (AbsFun mb_type _ mb_eqs _)    = maybe (ltype "fun")        mb_type ++
                                                   maybe (list (loc "def"))   mb_eqs  
     getLocations (ResParam mb_params _)         = maybe (loc "param")        mb_params
-    getLocations (ResValue _ mb_type)           = ltype "param-value"          mb_type
+    getLocations (ResValue mb_type _)           = ltype "param-value"          mb_type
     getLocations (ResOper  mb_type mb_def)      = maybe (ltype "oper-type")  mb_type ++
                                                   maybe (loc "oper-def")     mb_def
     getLocations (ResOverload _ defs)           = list (\(x,y) -> ltype "overload-type" x ++ 

src/compiler/GF/Compile/TypeCheck/Primitives.hs

@@ -8,7 +8,7 @@ typPredefined :: Ident -> Maybe Type
 typPredefined f = case Map.lookup f primitives of
                     Just (ResOper (Just (L _ ty)) _) -> Just ty
                     Just (ResParam _ _)              -> Just typePType
-                    Just (ResValue _ (L _ ty))       -> Just ty
+                    Just (ResValue (L _ ty) _)       -> Just ty
                     _                                -> Nothing
 
 primitives = Map.fromList
@@ -16,9 +16,9 @@ primitives = Map.fromList
   , (cInt      , ResOper (Just (noLoc typePType)) Nothing)
   , (cFloat    , ResOper (Just (noLoc typePType)) Nothing)
   , (cInts     , fun [typeInt] typePType)
-  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
+  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[],0),(cPFalse,[],1)])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
-  , (cPTrue    , ResValue 0 (noLoc typePBool))
+  , (cPTrue    , ResValue (noLoc typePBool) 0)
-  , (cPFalse   , ResValue 1 (noLoc typePBool))
+  , (cPFalse   , ResValue (noLoc typePBool) 1)
   , (cError    , fun [typeStr] typeError)  -- non-can. of empty set
   , (cLength   , fun [typeTok] typeInt)
   , (cDrop     , fun [typeInt,typeTok] typeTok)

src/compiler/GF/Compile/Update.hs

@@ -174,7 +174,7 @@ globalizeLoc fpath i =
     AbsCat mc             -> AbsCat (fmap gl mc)
     AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
     ResParam mt mv        -> ResParam (fmap gl mt) mv
-    ResValue offset t    -> ResValue offset (gl t)
+    ResValue t offset     -> ResValue (gl t) offset
     ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
     ResOverload ms os     -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
     CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
@@ -196,9 +196,9 @@ unifyAnyInfo m i j = case (i,j) of
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
     liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
-  (ResValue offset1 (L l1 t1), ResValue offset2 (L l2 t2)) 
+  (ResValue (L l1 t1) i1, ResValue (L l2 t2) i2) 
-      | offset1 == offset2 && t1==t2 -> return (ResValue offset1 (L l1 t1))
+      | t1==t2 && i1 == i2 -> return (ResValue (L l1 t1) i1)
-      | otherwise                    -> fail ""
+      | otherwise          -> fail ""
   (_, ResOverload ms t) | elem m ms ->
     return $ ResOverload ms t
   (ResOper mt1 m1, ResOper mt2 m2) -> 

src/compiler/GF/Grammar/Analyse.hs

@@ -107,7 +107,7 @@ sizeInfo i = case i of
   AbsFun mt mi me mb -> 1 + msize mt + 
     sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
   ResParam mp mt -> 
-    1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
+    1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co,_) <- ps]
   ResValue _ lt -> 0
   ResOper mt md -> 1 + msize mt + msize md
   ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]

src/compiler/GF/Grammar/Grammar.hs

@@ -330,7 +330,7 @@ data Info =
 
 -- judgements in resource
  | ResParam (Maybe (L [Param])) (Maybe [Term])   -- ^ (/RES/) the second parameter is list of all possible values
- | ResValue Int (L Type)                         -- ^ (/RES/) to mark parameter constructors for lookup
+ | ResValue (L Type) Int                         -- ^ (/RES/) to mark parameter constructors for lookup
  | ResOper  (Maybe (L Type)) (Maybe (L Term))    -- ^ (/RES/)
 
  | ResOverload [ModuleName] [(L Type,L Term)]         -- ^ (/RES/) idents: modules inherited
@@ -459,7 +459,7 @@ type Case = (Patt, Term)
 --type Cases = ([Patt], Term) 
 type LocalDef = (Ident, (Maybe Type, Term))
 
-type Param = (Ident, Context) 
+type Param = (Ident, Context, Int) 
 type Altern = (Term, [(Term, Term)])
 
 type Substitution =  [(Ident, Term)]

src/compiler/GF/Grammar/Lookup.hs

@@ -23,10 +23,11 @@ module GF.Grammar.Lookup (
            lookupResType, 
            lookupOverload,
            lookupOverloadTypes,
-           lookupParamValues, 
+           lookupParamValues,
            allParamValues,
-           lookupAbsDef, 
+           lookupParamValueIndex,
-           lookupLincat, 
+           lookupAbsDef,
+           lookupLincat,
            lookupFunType,
            lookupCatContext,
            allOpers, allOpersTo
@@ -99,7 +100,7 @@ lookupResType gr (m,c) = do
           return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _      -> return typePType
-    ResValue _ (L _ t)-> return t
+    ResValue (L _ t) _-> return t
     _   -> raise $ render (c <+> "has no type defined in resource" <+> m)
 
 lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)]
@@ -113,8 +114,8 @@ lookupOverloadTypes gr id@(m,c) = do
     CncFun (Just (cat,cont,val)) _ _ _ -> do
           val' <- lock cat val 
           ret $ mkProd cont val' []
-    ResParam _ _      -> ret typePType
+    ResParam _ _       -> ret typePType
-    ResValue _ (L _ t)  -> ret t
+    ResValue (L _ t) _ -> ret t
     ResOverload os tysts -> do
             tss <- mapM (\x -> lookupOverloadTypes gr (x,c)) os
             return $ [(tr,ty) | (L _ ty,L _ tr) <- tysts] ++
@@ -176,6 +177,13 @@ allParamValues cnc ptyp =
     -- to normalize records and record types
     sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
 
+lookupParamValueIndex :: ErrorMonad m => Grammar -> QIdent -> m Int
+lookupParamValueIndex gr c = do
+  (_,info) <- lookupOrigInfo gr c
+  case info of
+    ResValue _ i -> return i
+    _            -> raise $ render (ppQIdent Qualified c <+> "has no parameter index defined")
+
 lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
 lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
   info <- lookupQIdentInfo gr (m,c)
@@ -226,7 +234,7 @@ allOpers gr =
     typesIn info = case info of
       AbsFun  (Just ltyp) _ _ _ -> [ltyp]
       ResOper (Just ltyp) _     -> [ltyp]
-      ResValue _ ltyp           -> [ltyp]
+      ResValue ltyp _           -> [ltyp]
       ResOverload _ tytrs       -> [ltyp | (ltyp,_) <- tytrs]
       CncFun  (Just (i,ctx,typ)) _ _ _ ->
                                    [L NoLoc (mkProdSimple ctx (lock' i typ))]

src/compiler/GF/Grammar/Macros.hs

@@ -22,14 +22,12 @@ import GF.Data.Operations
 import GF.Data.Str
 import GF.Infra.Ident
 import GF.Grammar.Grammar
---import GF.Grammar.Values
 import GF.Grammar.Predef
 import GF.Grammar.Printer
 
 import Control.Monad.Identity(Identity(..))
 import qualified Data.Traversable as T(mapM)
 import Control.Monad (liftM, liftM2, liftM3)
---import Data.Char (isDigit)
 import Data.List (sortBy,nub)
 import Data.Monoid
 import GF.Text.Pretty(render,(<+>),hsep,fsep)
@@ -48,7 +46,7 @@ typeForm t =
     Q  c -> ([],c,[])
     QC c -> ([],c,[])
     Sort c -> ([],(MN identW, c),[])
-    _      -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
+    _      -> error (render ("no normal form of type" <+> show t))
 
 typeFormCnc :: Type -> (Context, Type)
 typeFormCnc t = 
@@ -615,13 +613,15 @@ allDependencies ism b =
     opersIn t = case t of
       Q  (n,c) | ism n -> [c]
       QC (n,c) | ism n -> [c]
+      Cn c             -> [c]
       _ -> collectOp opersIn t
     opty (Just (L _ ty)) = opersIn ty
     opty _ = []
     pts i = case i of
       ResOper pty pt -> [pty,pt]
       ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
-      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
+      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont,_) <- ps, (_,_,t) <- cont]
+      ResValue pty _ -> [Just pty]
       CncCat pty _ _ _ _ -> [pty]
       CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
       AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual

src/compiler/GF/Grammar/Parser.y

@@ -266,7 +266,7 @@ DataDef
 ParamDef :: { [(Ident,Info)] }
 ParamDef
   : Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
-                                        [(f, ResValue 0 (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
+                                        [(f, ResValue (L loc (mkProdSimple co (Cn $2))) i) | L loc (f,co,i) <- $4] }
   | Posn LhsIdent                   Posn { [($2, ResParam Nothing Nothing)] }
 
 OperDef :: { [(Ident,Info)] }
@@ -301,7 +301,7 @@ ListDataConstr
 
 ParConstr :: { L Param }
 ParConstr
-  : Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) } 
+  : Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3,0) } 
 
 ListLinDef :: { [(Ident,Info)] }
 ListLinDef
@@ -773,7 +773,7 @@ checkInfoType mt jment@(id,info) =
     CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
     CncFun _   pd ppn _  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
     ResParam pparam _    -> ifResource mt (locPerh pparam)
-    ResValue _ ty        -> ifResource mt (locL ty)
+    ResValue ty _        -> ifResource mt (locL ty)
     ResOper  pty pt      -> ifOper mt pty pt
     ResOverload _ xs     -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
   where

src/compiler/GF/Grammar/Printer.hs

@@ -106,8 +106,8 @@ ppJudgement q (id, ResParam pparams _) =
   (case pparams of
      Just (L _ ps) -> '=' <+> ppParams q ps
      _             -> empty) <+> ';'
-ppJudgement q (id, ResValue _ pvalue) = 
+ppJudgement q (id, ResValue pvalue i) = 
-  "-- param constructor" <+> id <+> ':' <+> 
+  "-- param constructor" <+> "[index" <+> i <> "]" <+> id <+> ':' <+> 
   (case pvalue of
      (L _ ty) -> ppTerm q 0 ty) <+> ';'
 ppJudgement q (id, ResOper  ptype pexp) =
@@ -322,7 +322,7 @@ ppBind (Implicit,v) = braces v
 ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
 
 ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
-ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
+ppParam q (id,cxt,_) = id <+> hsep (map (ppDDecl q) cxt)
 
 ppProduction (Production fid funid args) =
   ppFId fid <+> "->" <+> ppFunId funid <>