some work on evaluation with abstract expressions in PGF

6 files changed, 26 insertions, 29 deletions

diff --git a/src/GF/Grammar/Binary.hs b/src/GF/Grammar/Binary.hs
index 0521ff9c3..18594d4eb 100644
--- a/src/GF/Grammar/Binary.hs
+++ b/src/GF/Grammar/Binary.hs
@@ -90,7 +90,7 @@ instance Binary Options where
 

 instance Binary Info where

   put (AbsCat x y)     = putWord8 0 >> put (x,y)

-  put (AbsFun x y)     = putWord8 1 >> put (x,y)

+  put (AbsFun x y z)   = putWord8 1 >> put (x,y,z)

   put (ResParam x)     = putWord8 2 >> put x

   put (ResValue x)     = putWord8 3 >> put x

   put (ResOper x y)    = putWord8 4 >> put (x,y)

@@ -101,7 +101,7 @@ instance Binary Info where
   get = do tag <- getWord8

            case tag of

              0 -> get >>= \(x,y)   -> return (AbsCat x y)

-             1 -> get >>= \(x,y)   -> return (AbsFun x y)

+             1 -> get >>= \(x,y,z) -> return (AbsFun x y z)

              2 -> get >>= \x       -> return (ResParam x)

              3 -> get >>= \x       -> return (ResValue x)

              4 -> get >>= \(x,y)   -> return (ResOper x y)

diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index 37692ec39..13ddbdb8c 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/src/GF/Grammar/Grammar.hs
@@ -41,7 +41,6 @@ module GF.Grammar.Grammar (SourceGrammar,
 		Param,
 		Altern,
 		Substitution,
-		wildPatt,
 		varLabel, tupleLabel, linLabel, theLinLabel,
 		ident2label, label2ident
 	       ) where
@@ -80,8 +79,8 @@ type PValues = [Term]
 -- and indirection to module (/INDIR/)
 data Info =
 -- judgements in abstract syntax
-   AbsCat   (Maybe Context) (Maybe [Term])   -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
- | AbsFun   (Maybe Type) (Maybe [Equation])  -- ^ (/ABS/)
+   AbsCat   (Maybe Context) (Maybe [Term])               -- ^ (/ABS/) the second parameter is list of constructors - must be 'Id' or 'QId'
+ | AbsFun   (Maybe Type) (Maybe Int) (Maybe [Equation])  -- ^ (/ABS/) type, arrity and definition of function
 
 -- judgements in resource
  | ResParam (Maybe ([Param],Maybe PValues))  -- ^ (/RES/)
@@ -229,6 +228,3 @@ ident2label c = LIdent (ident2bs c)
 label2ident :: Label -> Ident
 label2ident (LIdent s) = identC s
 label2ident (LVar i)   = identC (BS.pack ('$':show i))
-
-wildPatt :: Patt
-wildPatt = PV identW
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 3df2db7da..b136eee83 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -121,7 +121,7 @@ lookupResType gr m c = do
           mu <- lookupModule gr a
           info <- lookupIdentInfo mu c
           case info of
-            AbsFun (Just ty) _ -> return $ redirectTerm e ty 
+            AbsFun (Just ty) _ _ -> return $ redirectTerm e ty 
             AbsCat _ _ -> return typeType
             AnyInd _ n -> lookFun e m c n
             _ -> prtBad "cannot find type of reused function" c
@@ -227,14 +227,14 @@ qualifAnnotPar m t = case t of
   Con c -> QC m c
   _ -> composSafeOp (qualifAnnotPar m) t
 
-lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe [Equation])
+lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
 lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
   mo <- lookupModule gr m
   info <- lookupIdentInfo mo c
   case info of
-    AbsFun _ (Just t) -> return (Just t)
-    AnyInd _ n        -> lookupAbsDef gr n c
-    _                 -> return Nothing
+    AbsFun _ a d -> return (a,d)
+    AnyInd _ n   -> lookupAbsDef gr n c
+    _            -> return (Nothing,Nothing)
 
 lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
 lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
@@ -252,9 +252,9 @@ lookupFunType gr m c = do
   mo <- lookupModule gr m
   info <- lookupIdentInfo mo c
   case info of
-    AbsFun (Just t) _  -> return t
-    AnyInd _ n         -> lookupFunType gr n c
-    _                  -> prtBad "cannot find type of" c
+    AbsFun (Just t) _ _  -> return t
+    AnyInd _ n           -> lookupFunType gr n c
+    _                    -> prtBad "cannot find type of" c
 
 -- | this is needed at compile time
 lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
@@ -281,7 +281,7 @@ opersForType gr orig val =
       let cat = err error snd (valCat orig) in --- ignore module
       [(f,ty) |
         Ok a <- [abstractOfConcrete gr i >>= lookupModule gr],
-        (f, AbsFun (Just ty0) _) <- tree2list $ jments a,
+        (f, AbsFun (Just ty0) _ _) <- tree2list $ jments a,
         let ty = redirectTerm i ty0,
         Ok valt  <- [valCat ty],
         cat == snd valt ---
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index fa1b75dda..2c0761f00 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -414,7 +414,8 @@ linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
 
 term2patt :: Term -> Err Patt
 term2patt trm = case termForm trm of
-  Ok ([], Vr x, []) -> return (PV x)
+  Ok ([], Vr x, []) | x == identW -> return PW
+                    | otherwise   -> return (PV x)
   Ok ([], Val te ty x, []) -> do
     te' <- term2patt te
     return (PVal te' ty x)
diff --git a/src/GF/Grammar/Parser.y b/src/GF/Grammar/Parser.y
index 981589ac0..1a9723c28 100644
--- a/src/GF/Grammar/Parser.y
+++ b/src/GF/Grammar/Parser.y
@@ -240,19 +240,19 @@ CatDef
 
 FunDef :: { [(Ident,SrcSpan,Info)] }
 FunDef
-  : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) (Just [])) | fun <- $2] } 
+  : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing (Just [])) | fun <- $2] } 
 
 DefDef :: { [(Ident,SrcSpan,Info)] }
 DefDef
-  : Posn ListName '=' Exp         Posn { [(f, ($1,$5),AbsFun Nothing (Just [([],$4)])) | f <- $2] }
-  | Posn Name ListPatt '=' Exp    Posn { [($2,($1,$6),AbsFun Nothing (Just [($3,$5)]))] }
+  : Posn ListName '=' Exp         Posn { [(f, ($1,$5),AbsFun Nothing (Just 0) (Just [([],$4)])) | f <- $2] }
+  | Posn Name ListPatt '=' Exp    Posn { [($2,($1,$6),AbsFun Nothing (Just (length $3)) (Just [($3,$5)]))] }
 
 DataDef :: { [(Ident,SrcSpan,Info)] }
 DataDef
   : Posn Ident '=' ListDataConstr Posn { ($2,   ($1,$5), AbsCat Nothing   (Just (map Cn $4))) :
-                                         [(fun, ($1,$5), AbsFun Nothing   Nothing) | fun <- $4] }
+                                         [(fun, ($1,$5), AbsFun Nothing   Nothing Nothing) | fun <- $4] }
   | Posn ListIdent ':' Exp Posn        { [(cat, ($1,$5), AbsCat Nothing   (Just (map Cn $2))) | Ok (_,cat) <- [valCat $4]] ++
-                                         [(fun, ($1,$5), AbsFun (Just $4) Nothing) | fun <- $2] }                                         
+                                         [(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] }                                         
 
 ParamDef :: { [(Ident,SrcSpan,Info)] }
 ParamDef
@@ -481,7 +481,7 @@ Patt2
   | '[' String ']'            { PChars $2 }
   | '#' Ident                 { PMacro $2 }
   | '#' Ident '.' Ident       { PM $2 $4 }
-  | '_'                       { wildPatt }
+  | '_'                       { PW }
   | Ident                     { PV $1 }
   | Ident '.' Ident           { PP $1 $3 [] }
   | Integer                   { PInt $1 }
@@ -609,8 +609,8 @@ listCatDef id pos cont size = [catd,nilfund,consfund]
     consId = mkConsId id
 
     catd     = (listId, pos, AbsCat (Just cont')   (Just [Cn baseId,Cn consId]))
-    nilfund  = (baseId, pos, AbsFun (Just niltyp)  Nothing)
-    consfund = (consId, pos, AbsFun (Just constyp) Nothing)
+    nilfund  = (baseId, pos, AbsFun (Just niltyp)  Nothing Nothing)
+    consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing)
 
     cont' = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont]
     xs = map (Vr . fst) cont'
@@ -667,7 +667,7 @@ type SrcSpan = (Posn,Posn)
 checkInfoType MTAbstract       (id,pos,info) =
   case info of
     AbsCat _ _   -> return ()
-    AbsFun _ _   -> return ()
+    AbsFun _ _ _ -> return ()
     _            -> failLoc (fst pos) "illegal definition in abstract module" 
 checkInfoType MTResource       (id,pos,info) =
   case info of
@@ -701,7 +701,7 @@ checkInfoType (MTInstance _)   (id,pos,info) =
 checkInfoType (MTTransfer _ _) (id,pos,info) =
   case info of
     AbsCat _ _   -> return ()
-    AbsFun _ _   -> return ()
+    AbsFun _ _ _ -> return ()
     _            -> failLoc (fst pos) "illegal definition in transfer module" 
 
 
diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs
index 383d36d4f..12b7ba782 100644
--- a/src/GF/Grammar/Printer.hs
+++ b/src/GF/Grammar/Printer.hs
@@ -79,7 +79,7 @@ ppJudgement q (id, AbsCat pcont pconstrs) =
   case pconstrs of

     Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi

     Nothing     -> empty

-ppJudgement q (id, AbsFun ptype pexp) =

+ppJudgement q (id, AbsFun ptype _ pexp) =

   (case ptype of

      Just typ   -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi

      Nothing    -> empty) $$