internal representation for param value index

4 files changed, 43 insertions, 10 deletions

diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index 1c963ac66..f49075f48 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/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/)
- | ResValue (Perh Type)                    -- ^ (/RES/) to mark parameter constructors for lookup
+ | ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/)
+ | 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
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 1620474e6..9f360dfcd 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/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   Nope   -> if isTop then lookExt m c 
-          ----                       else prtBad "cannot find params in exts" c 
+          ResParam (Yes psm) -> return psm
+
           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
-  liftM concat $ mapM mkPar ps
+  (ps,mpv) <- lookupParams gr m c
+  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) -> 
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index a3cad8bae..9d93a0258 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/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
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index 7635e6fa1..804333b14 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/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)]