def and List

src/GF/Compile/CheckGrammar.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/22 08:52:02 $ 
+-- > CVS $Date: 2005/10/02 20:50:19 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.28 $
+-- > CVS $Revision: 1.29 $
 --
 -- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003
 --
@@ -93,18 +93,25 @@ checkAbsInfo st m (c,info) = do
      checkContext st cont ---- also cstrs
    AbsFun (Yes typ0) md -> do
     typ <- compAbsTyp [] typ0   -- to calculate let definitions
-    mkCheck "function" $
+    mkCheck "type of function" $ checkTyp st typ 
-       checkTyp st typ ++ 
+    md' <- case md of
-       case md of
+       Yes d -> do
-         Yes d ->  checkEquation st (m,c) d
+         let d' = elimTables d
-         _ -> []
+         mkCheckWarn "definition of function" $ checkEquation st (m,c) d'
-    return $ (c,AbsFun (Yes typ) md)
+         return $ Yes d'
+       _ -> return md
+    return $ (c,AbsFun (Yes typ) md')
    _ -> return (c,info)
  where
    mkCheck cat ss = case ss of
      [] -> return (c,info)
      ["[]"] -> return (c,info) ----
      _  -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c
+   ---- temporary solution when tc of defs is incomplete
+   mkCheckWarn cat ss = case ss of
+     [] -> return (c,info)
+     ["[]"] -> return (c,info) ----
+     _  -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info)
    compAbsTyp g t = case t of
      Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g
      Let (x,(_,a)) b -> do
@@ -117,6 +124,16 @@ checkAbsInfo st m (c,info) = do
      Abs _ _ -> return t
      _ -> composOp (compAbsTyp g) t
 
+   elimTables e = case e of
+     S t a  -> elimSel (elimTables t) (elimTables a)
+     T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs]
+     _ -> composSafeOp elimTables e
+   elimPatt p = case p of
+     PR lps -> map snd lps
+     _ -> [p]
+   elimSel t a = case a of
+     R fs -> mkApp t (map (snd . snd) fs)
+     _ -> mkApp t [a]
 
 checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info)
 checkCompleteGrammar abs cnc = do

src/GF/Grammar/AbsCompute.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:18 $ 
+-- > CVS $Date: 2005/10/02 20:50:19 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.7 $
+-- > CVS $Revision: 1.8 $
 --
 -- computation in abstract syntax w.r.t. explicit definitions.
 --
@@ -72,12 +72,15 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
        Ok (Just EData) -> Nothing  -- canonical --- should always be QC
        Ok md -> md
        _ -> Nothing
+     Eqs _ -> return t ---- for nested fn
      _ -> Nothing
 
 beta :: [Ident] -> Exp -> Exp
 beta vv c = case c of
   App (Abs x b) a -> beta vv $ substTerm vv [xvv] (beta (x:vv) b) 
                                                     where xvv = (x,beta vv a) 
+  Let (x,(_,a)) b -> beta vv $ substTerm vv [xvv] (beta (x:vv) b) 
+                                                    where xvv = (x,beta vv a) 
   App f         a -> let (a',f') = (beta vv a, beta vv f) in 
                      (if a'==a && f'==f then id else beta vv) $ App f' a'
   Prod x a b      -> Prod x (beta vv a) (beta (x:vv) b)

src/GF/Grammar/Macros.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/03 21:51:58 $ 
+-- > CVS $Date: 2005/10/02 20:50:19 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.22 $
+-- > CVS $Revision: 1.23 $
 --
 -- Macros for constructing and analysing source code terms.
 --
@@ -655,6 +655,10 @@ composOp co trm =
         i'  <- changeTableType co i
         return (TSh i' cc')
 
+   Eqs cc -> 
+     do cc' <- mapPairListM (co . snd) cc
+        return (Eqs cc')
+
    V ty vs ->
      do ty' <- co ty
         vs' <- mapM co vs

src/GF/Grammar/TC.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/15 16:22:02 $ 
+-- > CVS $Date: 2005/10/02 20:50:19 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.10 $
+-- > CVS $Revision: 1.11 $
 --
 -- Thierry Coquand's type checking algorithm that creates a trace
 -----------------------------------------------------------------------------
@@ -261,6 +261,9 @@ checkPatt th tenv exp val = do
    checkExpP tenv@(k,rho,gamma) exp val = case exp of
      Meta m -> return $ (AMeta m val, val, [])
      Vr x   -> return $ (AVr   x val, val, [])
+     EInt i -> return (AInt i, valAbsInt, [])
+     K s    -> return (AStr s, valAbsString, [])
+
      Q m c  -> do
        typ <- lookupConst th (m,c)
        return $ (ACn (m,c) typ, typ, [])

src/GF/Source/SourceToGrammar.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 21:08:15 $ 
+-- > CVS $Date: 2005/10/02 20:50:19 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.26 $
+-- > CVS $Revision: 1.27 $
 --
 -- based on the skeleton Haskell module generated by the BNF converter
 -----------------------------------------------------------------------------
@@ -251,15 +251,20 @@ transCatDef x = case x of
 		       cont <- liftM concat $ mapM transDDecl ddecls
 		       return (i, G.AbsCat (yes cont) nope)
        listCat id ddecls size = do
-				let li = mkListId id
+	 let 
-				catd <- cat li ddecls
+           li = mkListId id
-				let cd = M.mkDecl (G.Vr id)
+	 catd@(_,G.AbsCat (Yes cont0) _) <- cat li ddecls
-				    lc = G.Vr li
+	 let
-				    niltyp = M.mkProdSimple (genericReplicate size cd) lc
+           cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
-				    nilfund = (mkBaseId id, G.AbsFun (yes niltyp) nope)
+           xs = map (G.Vr . fst) cont 
-				    constyp = M.mkProdSimple [cd, M.mkDecl lc] lc
+           cd = M.mkDecl (M.mkApp (G.Vr id) xs)
-				    consfund = (mkConsId id, G.AbsFun (yes constyp) nope)
+	   lc = M.mkApp (G.Vr li) xs
-				return [catd,nilfund,consfund]
+	   niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc
+	   nilfund = (mkBaseId id, G.AbsFun (yes niltyp) nope)
+	   constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
+	   consfund = (mkConsId id, G.AbsFun (yes constyp) nope)
+	 return [catd,nilfund,consfund]
+       mkId x i = if isWildIdent x then (mkIdent "x" i) else x
 
 transFunDef :: FunDef -> Err ([Ident], G.Type)
 transFunDef x = case x of