From 7db4b641ce6abe90dd404459cd5eccb6e67f618c Mon Sep 17 00:00:00 2001
From: krasimir <krasimir@chalmers.se>
Date: Wed, 20 May 2009 21:03:56 +0000
Subject: refactor the PGF.Expr type and the evaluation of abstract expressions

---
 src/GF/Command/Commands.hs       |  6 +++---
 src/GF/Command/TreeOperations.hs |  6 ++----
 src/GF/Compile/AbsCompute.hs     |  9 ++-------
 src/GF/Compile/CheckGrammar.hs   | 29 ++++++++---------------------
 src/GF/Compile/GFCCtoJS.hs       |  2 +-
 src/GF/Compile/GFCCtoProlog.hs   | 29 +++++++++++++++--------------
 src/GF/Compile/GenerateFCFG.hs   |  8 ++++----
 src/GF/Compile/GeneratePMCFG.hs  |  2 +-
 src/GF/Compile/GrammarToGFCC.hs  | 24 +++++++++++++-----------
 src/GF/Compile/PGFPretty.hs      |  2 +-
 src/GF/Compile/Rename.hs         |  6 ++----
 src/GF/Compile/TC.hs             |  7 +------
 src/GF/Compile/TypeCheck.hs      | 13 +++++++------
 src/GF/Compile/Update.hs         | 14 ++++++--------
 src/GF/Grammar/Binary.hs         |  4 ----
 src/GF/Grammar/Grammar.hs        |  5 +----
 src/GF/Grammar/Lookup.hs         |  2 +-
 src/GF/Grammar/Macros.hs         |  4 ----
 src/GF/Grammar/Parser.y          | 33 ++++++++++-----------------------
 src/GF/Grammar/Printer.hs        | 10 ++--------
 src/GF/Source/GrammarToSource.hs |  9 +++------
 21 files changed, 83 insertions(+), 141 deletions(-)

(limited to 'src/GF')

diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs
index fff9e011d..f29fd3d41 100644
--- a/src/GF/Command/Commands.hs
+++ b/src/GF/Command/Commands.hs
@@ -600,11 +600,11 @@ allCommands cod env@(pgf, mos) = Map.fromList [
      exec = \opts arg -> do
        case arg of
          [Fun id []] -> case Map.lookup id (funs (abstract pgf)) of
-                          Just (ty,def) -> return $ fromString $
+                          Just (ty,eqs) -> return $ fromString $
                                               render (text "fun" <+> text (prCId id) <+> colon <+> ppType 0 ty $$
-                                                      if def == EEq []
+                                                      if null eqs
                                                         then empty
-                                                        else text "def" <+> text (prCId id) <+> char '=' <+> ppExpr 0 def)
+                                                        else text "def" <+> vcat [text (prCId id) <+> hsep (map (ppPatt 9) patts) <+> char '=' <+> ppExpr 0 res | Equ patts res <- eqs])
                           Nothing       -> case Map.lookup id (cats (abstract pgf)) of
                                              Just hyps -> do return $ fromString $
                                                                 render (text "cat" <+> text (prCId id) <+> hsep (map ppHypo hyps) $$
diff --git a/src/GF/Command/TreeOperations.hs b/src/GF/Command/TreeOperations.hs
index a2670dc4f..ff87de563 100644
--- a/src/GF/Command/TreeOperations.hs
+++ b/src/GF/Command/TreeOperations.hs
@@ -4,10 +4,8 @@ module GF.Command.TreeOperations (
   ) where
 
 import GF.Compile.TypeCheck
-import PGF (compute,paraphrase,typecheck)
+import PGF
 
--- for conversions
-import PGF.Data
 --import GF.Compile.GrammarToGFCC (mkType,mkExp)
 import qualified GF.Grammar.Grammar as G
 import qualified GF.Grammar.Macros as M
@@ -22,7 +20,7 @@ treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
 allTreeOps :: PGF -> [(String,(String,TreeOp))]
 allTreeOps pgf = [
    ("compute",("compute by using semantic definitions (def)",
-      map (compute pgf))),
+      map (expr2tree pgf . tree2expr))),
    ("paraphrase",("paraphrase by using semantic definitions (def)",
       nub . concatMap (paraphrase pgf))),
    ("smallest",("sort trees from smallest to largest, in number of nodes",
diff --git a/src/GF/Compile/AbsCompute.hs b/src/GF/Compile/AbsCompute.hs
index 8546dc3bc..ce3528b68 100644
--- a/src/GF/Compile/AbsCompute.hs
+++ b/src/GF/Compile/AbsCompute.hs
@@ -42,7 +42,7 @@ computeAbsTerm :: Grammar -> Exp -> Err Exp
 computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
 
 -- | a hack to make compute work on source grammar as well
-type LookDef = Ident -> Ident -> Err (Maybe Term)
+type LookDef = Ident -> Ident -> Err (Maybe [Equation])
 
 computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
 computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
@@ -55,7 +55,7 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
       let vv' = yy ++ vv
       aa'    <- mapM (compt vv') aa
       case look f of
-        Just (Eqs eqs) -> tracd ("\nmatching" +++ prt f) $ 
+        Just eqs -> tracd ("\nmatching" +++ prt f) $ 
                           case findMatch eqs aa' of
           Ok (d,g) -> do
             --- let (xs,ts) = unzip g
@@ -67,19 +67,14 @@ computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
                do
             let v = mkApp f aa'
             return $ mkAbs yy $ v
-        Just d -> tracd ("define" +++ prt t') $ do
-          da <- compt vv' $ mkApp d aa' 
-          return $ mkAbs yy $ da
         _ -> do
           let t2 = mkAbs yy $ mkApp f aa'
           tracd ("not defined" +++ prt_ t2) $ return t2
 
   look t = case t of
      (Q m f) -> case lookd m f of
-       Ok (Just EData) -> Nothing  -- canonical --- should always be QC
        Ok md -> md
        _ -> Nothing
-     Eqs _ -> return t ---- for nested fn
      _ -> Nothing
 
 beta :: [Ident] -> Exp -> Exp
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 9947de64f..59961e0cd 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -124,16 +124,14 @@ checkAbsInfo st m mo (c,info) = do
    AbsCat (Just cont) _ -> mkCheck "category" $ 
      checkContext st cont ---- also cstrs
    AbsFun (Just typ0) md -> do
-    typ <- compAbsTyp [] typ0   -- to calculate let definitions
-    mkCheck "type of function" $ checkTyp st typ 
-    md' <- case md of
-       Just d -> do
-         let d' = elimTables d
-----         mkCheckWarn "definition of function" $ checkEquation st (m,c) d'
-         mkCheck "definition of function" $ checkEquation st (m,c) d'
-         return $ Just d'
-       _ -> return md
-    return $ (c,AbsFun (Just typ) md')
+     typ <- compAbsTyp [] typ0   -- to calculate let definitions
+     mkCheck "type of function" $
+       checkTyp st typ
+     case md of
+       Just eqs -> mkCheck "definition of function" $
+	             checkDef st (m,c) typ eqs
+       Nothing  -> return (c,info)
+     return $ (c,AbsFun (Just typ) md)
    _ -> return (c,info)
  where
    mkCheck cat ss = case ss of
@@ -161,17 +159,6 @@ checkAbsInfo st m mo (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 :: SourceGrammar -> SourceModInfo -> SourceModInfo -> Check (BinTree Ident Info)
 checkCompleteGrammar gr abs cnc = do
   let jsa = jments abs
diff --git a/src/GF/Compile/GFCCtoJS.hs b/src/GF/Compile/GFCCtoJS.hs
index c8e4e0e4b..7fbe06c98 100644
--- a/src/GF/Compile/GFCCtoJS.hs
+++ b/src/GF/Compile/GFCCtoJS.hs
@@ -34,7 +34,7 @@ pgf2js pgf =
 abstract2js :: String -> Abstr -> JS.Expr
 abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
 
-absdef2js :: (CId,(Type,Expr)) -> JS.Property
+absdef2js :: (CId,(Type,[Equation])) -> JS.Property
 absdef2js (f,(typ,_)) =
   let (args,cat) = M.catSkeleton typ in 
     JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)])
diff --git a/src/GF/Compile/GFCCtoProlog.hs b/src/GF/Compile/GFCCtoProlog.hs
index 4e1ccfba6..dec6b5412 100644
--- a/src/GF/Compile/GFCCtoProlog.hs
+++ b/src/GF/Compile/GFCCtoProlog.hs
@@ -71,17 +71,17 @@ plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ)
           args = reverse [EVar x | (_,x) <- subst]
           typ = wildcardUnusedVars $ DTyp hypos' cat args
 
-plFun :: (CId, (Type, Expr)) -> String
+plFun :: (CId, (Type, [Equation])) -> String
 plFun (fun, (typ, _)) = plFact "fun" (plp fun : plTypeWithHypos typ')
     where typ' = wildcardUnusedVars $ snd $ alphaConvert emptyEnv typ
 
 plTypeWithHypos :: Type -> [String]
 plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plp hypos]
 
-plFundef :: (CId, (Type, Expr)) -> [String]
-plFundef (fun, (_, EEq [])) = []
-plFundef (fun, (_, fundef)) = [plFact "def" [plp fun, plp fundef']]
-    where fundef' = snd $ alphaConvert emptyEnv fundef
+plFundef :: (CId, (Type, [Equation])) -> [String]
+plFundef (fun, (_, [])) = []
+plFundef (fun, (_, eqs)) = [plFact "def" [plp fun, plp fundef']]
+    where fundef' = snd $ alphaConvert emptyEnv eqs
 
 
 ----------------------------------------------------------------------
@@ -122,8 +122,14 @@ instance PLPrint Expr where
     plp (EApp e e') = plOper " * " (plp e) (plp e')
     plp (ELit lit)  = plp lit
     plp (EMeta n)   = "Meta_" ++ show n
-    plp (EEq eqs)   = plList [plOper ":" (plp patterns) (plp result) | 
-                              Equ patterns result <- eqs]
+
+instance PLPrint Patt where
+    plp (PVar x)    = plp x
+    plp (PApp f ps) = plOper " * " (plp f) (plp ps)
+    plp (PLit lit)  = plp lit
+
+instance PLPrint Equation where
+    plp (Equ patterns result)   = plOper ":" (plp patterns) (plp result)
 
 instance PLPrint Term where
     plp (S terms) = plTerm "s"  [plp terms]
@@ -267,17 +273,14 @@ instance AlphaConvert Expr where
         where (env',  e1') = alphaConvert env  e1
               (env'', e2') = alphaConvert env' e2
     alphaConvert env expr@(EVar i) = (env, maybe expr EVar (lookup i (snd env)))
-    alphaConvert env (EEq eqs) = (env', EEq eqs')
-        where (env', eqs') = alphaConvert env eqs
     alphaConvert env expr = (env, expr)
 
 -- pattern variables are not alpha converted
 -- (but they probably should be...)
 instance AlphaConvert Equation where
     alphaConvert env@(_,subst) (Equ patterns result)
-        = ((ctr,subst), Equ patterns' result')
-        where (env',  patterns') = alphaConvert env patterns
-              ((ctr,_), result') = alphaConvert env' result
+        = ((ctr,subst), Equ patterns result')
+        where ((ctr,_), result') = alphaConvert env result
 
 ----------------------------------------------------------------------
 -- translate unused variables to wildcards
@@ -295,6 +298,4 @@ wildcardUnusedVars typ@(DTyp hypos cat args) = DTyp hypos' cat args
           unusedInExpr x (EAbs y e)  = unusedInExpr x e
           unusedInExpr x (EApp e e') = unusedInExpr x e && unusedInExpr x e'
           unusedInExpr x (EVar y)    = x/=y
-          unusedInExpr x (EEq eqs)   = and [all (unusedInExpr x) (result:patterns) |
-                                            Equ patterns result <- eqs]
           unusedInExpr x expr        = True
diff --git a/src/GF/Compile/GenerateFCFG.hs b/src/GF/Compile/GenerateFCFG.hs
index bb8ba9452..254720e04 100644
--- a/src/GF/Compile/GenerateFCFG.hs
+++ b/src/GF/Compile/GenerateFCFG.hs
@@ -43,7 +43,7 @@ convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats'
              cats = lincats cnc
              (abs_defs',conc',cats') = expandHOAS abs_defs conc cats
 
-expandHOAS :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ([(CId,(Type,Expr))],TermMap,TermMap)
+expandHOAS :: [(CId,(Type,[Equation]))] -> TermMap -> TermMap -> ([(CId,(Type,[Equation]))],TermMap,TermMap)
 expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns, 
                                 Map.unions [lins, hoLins, varLins], 
                                 Map.unions [lincats, hoLincats, varLincat])
@@ -59,14 +59,14 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
       hoCats = sortNub (map snd hoTypes)
       -- for each Cat with N bindings, we add a new category _NCat
       -- each new category contains a single function __NCat : Cat -> _Var -> ... -> _Var -> _NCat
-      hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),EEq [])) | ty@(n,c) <- hoTypes]
+      hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),[])) | ty@(n,c) <- hoTypes]
       -- lincats for the new categories
       hoLincats = Map.fromList [(catName ty, modifyRec (++ replicate n (S [])) (lincatOf c)) | ty@(n,c) <- hoTypes]
       -- linearizations of the new functions, lin __NCat v_0 ... v_n-1 x = { s1 = x.s1; ...; sk = x.sk; $0 = v_0.s ...
       hoLins = Map.fromList [ (funName ty, mkLin c n) | ty@(n,c) <- hoTypes]
           where mkLin c n = modifyRec (\fs -> [P (V 0) (C j) | j <- [0..length fs-1]] ++ [P (V i) (C 0) | i <- [1..n]]) (lincatOf c)
       -- for each Cat, we a add a fun _Var_Cat : _Var -> Cat
-      varFuns = [(varFunName cat, (cftype [varCat] cat,EEq [])) | cat <- hoCats]
+      varFuns = [(varFunName cat, (cftype [varCat] cat,[])) | cat <- hoCats]
       -- linearizations of the _Var_Cat functions
       varLins = Map.fromList [(varFunName cat, R [P (V 0) (C 0)]) | cat <- hoCats]
       -- lincat for the _Var category
@@ -98,7 +98,7 @@ fixHoasFuns pinfo = pinfo{functions=mkArray [FFun (fixName n) prof lins | FFun n
                         | BS.pack "_Var_" `BS.isPrefixOf` n = wildCId
         fixName n = n
 
-convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ParserInfo
+convert :: [(CId,(Type,[Equation]))] -> TermMap -> TermMap -> ParserInfo
 convert abs_defs cnc_defs cat_defs = getParserInfo (loop grammarEnv)
       where
         srules = [
diff --git a/src/GF/Compile/GeneratePMCFG.hs b/src/GF/Compile/GeneratePMCFG.hs
index 3da4d9763..772adf81a 100644
--- a/src/GF/Compile/GeneratePMCFG.hs
+++ b/src/GF/Compile/GeneratePMCFG.hs
@@ -38,7 +38,7 @@ convertConcrete abs cnc = convert abs_defs conc cats
              conc = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
              cats = lincats cnc
 
-convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ParserInfo
+convert :: [(CId,(Type,[Equation]))] -> TermMap -> TermMap -> ParserInfo
 convert abs_defs cnc_defs cat_defs =
   let env = expandHOAS abs_defs cnc_defs cat_defs (emptyGrammarEnv cnc_defs cat_defs)
   in getParserInfo (List.foldl' (convertRule cnc_defs) env pfrules)
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
index 272692be7..e1c5b8fb7 100644
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -68,9 +68,9 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
   abs = D.Abstr aflags funs cats catfuns
   gflags = Map.empty
   aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)]
-  mkDef pty = case pty of
-    Just t -> mkExp t
-    _      -> CM.primNotion
+
+  mkDef (Just eqs) = [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
+  mkDef Nothing    = []
 
   -- concretes
   lfuns = [(f', (mkType ty, mkDef pty)) | 
@@ -119,9 +119,7 @@ mkType t = case GM.typeForm t of
   Ok (hyps,(_,cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args)
 
 mkExp :: A.Term -> C.Expr
-mkExp t = case t of
-  A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
-  _ -> case GM.termForm t of
+mkExp t = case GM.termForm t of
     Ok (xs,c,args) -> mkAbs xs (mkApp c (map mkExp args))
   where
     mkAbs xs t = foldr (C.EAbs . i2i) t xs
@@ -134,11 +132,15 @@ mkExp t = case t of
       K s      -> C.ELit (C.LStr s)
       Meta (MetaSymb i) -> C.EMeta i
       _        -> C.EMeta 0
-    mkPatt p = case p of
-      A.PP _ c ps -> foldl C.EApp (C.EVar (i2i c)) (map mkPatt ps)
-      A.PV x      -> C.EVar (i2i x)
-      A.PW        -> C.EVar wildCId
-      A.PInt i    -> C.ELit (C.LInt i)
+
+mkPatt p = case p of
+  A.PP _ c ps -> C.PApp (i2i c) (map mkPatt ps)
+  A.PV x      -> C.PVar (i2i x)
+  A.PW        -> C.PWild
+  A.PInt i    -> C.PLit (C.LInt i)
+  A.PFloat f  -> C.PLit (C.LFlt f)
+  A.PString s -> C.PLit (C.LStr s)
+
 
 mkContext :: A.Context -> [C.Hypo]
 mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
diff --git a/src/GF/Compile/PGFPretty.hs b/src/GF/Compile/PGFPretty.hs
index b6d8f514b..178f8866b 100644
--- a/src/GF/Compile/PGFPretty.hs
+++ b/src/GF/Compile/PGFPretty.hs
@@ -31,7 +31,7 @@ prCat :: CId -> [Hypo] -> Doc
 prCat c h | isLiteralCat c = empty
           | otherwise = text "cat" <+> text (prCId c)
 
-prFun :: CId -> (Type,Expr) -> Doc
+prFun :: CId -> (Type,[Equation]) -> Doc
 prFun f (t,_) = text "fun" <+> text (prCId f) <+> text ":" <+> prType t
 
 prType :: Type -> Doc
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index c00e31d95..8011d2171 100644
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -116,7 +116,7 @@ renameIdentPatt env p = do
 
 info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
 info2status mq (c,i) = case i of
-  AbsFun _ (Just EData) -> maybe Con QC mq
+  AbsFun _ Nothing -> maybe Con QC mq
   ResValue _  -> maybe Con QC mq
   ResParam _  -> maybe Con QC mq
   AnyInd True m -> maybe Con (const (QC m)) mq
@@ -156,8 +156,7 @@ renameInfo mo status (i,info) = errIn
                                 liftM ((,) i) $ case info of
   AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
                                   (renPerh (mapM rent) pfs)
-  AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
-
+  AbsFun  pty ptr -> liftM2 AbsFun (ren pty) (renPerh (mapM (renameEquation status [])) ptr)
   ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
   ResOverload os tysts -> 
     liftM (ResOverload os) (mapM (pairM rent) tysts)
@@ -191,7 +190,6 @@ renameTerm env vars = ren vars where
     Con _  -> renid trm
     Q _ _  -> renid trm
     QC _ _ -> renid trm
-    Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
     T i cs -> do
       i' <- case i of
         TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
diff --git a/src/GF/Compile/TC.hs b/src/GF/Compile/TC.hs
index 5ecbdf8e5..a56c3b86d 100644
--- a/src/GF/Compile/TC.hs
+++ b/src/GF/Compile/TC.hs
@@ -16,6 +16,7 @@ module GF.Compile.TC (AExp(..),
 	   Theory,
 	   checkExp,
 	   inferExp,
+	   checkBranch,
 	   eqVal,
 	   whnf
 	  ) where
@@ -122,7 +123,6 @@ checkExp th tenv@(k,rho,gamma) e ty = do
   let v = VGen k
   case e of
     Meta m -> return $ (AMeta m typ,[])
-    EData -> return $ (AData typ,[])
 
     Abs x t -> case typ of
       VClos env (Prod y a b) -> do
@@ -132,11 +132,6 @@ checkExp th tenv@(k,rho,gamma) e ty = do
 	return (AAbs x a' t', cs)
       _ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ
 
-    Eqs es -> do
-      bcs <- mapM (\b -> checkBranch th tenv b typ) es
-      let (bs,css) = unzip bcs
-      return (AEqs bs, concat css) 
-
     Prod x a b -> do
       testErr (typ == vType) "expected Type"
       (a',csa) <- checkType th tenv a
diff --git a/src/GF/Compile/TypeCheck.hs b/src/GF/Compile/TypeCheck.hs
index e824a0cfe..71fe5b067 100644
--- a/src/GF/Compile/TypeCheck.hs
+++ b/src/GF/Compile/TypeCheck.hs
@@ -15,7 +15,7 @@
 module GF.Compile.TypeCheck (-- * top-level type checking functions; TC should not be called directly.
 		  checkContext,
 		  checkTyp,
-		  checkEquation,
+		  checkDef,
 		  checkConstrs,
 		 ) where
 
@@ -71,11 +71,12 @@ checkContext st = checkTyp st . cont2exp
 checkTyp :: Grammar -> Type -> [String]
 checkTyp gr typ = err singleton prConstrs $ justTypeCheck gr typ vType
 
-checkEquation :: Grammar -> Fun -> Term -> [String]
-checkEquation gr (m,fun) def = err singleton prConstrs $ do
-  typ  <- lookupFunType gr m fun
-  cs   <- justTypeCheck gr def (vClos typ)
-  return $ filter notJustMeta cs
+checkDef :: Grammar -> Fun -> Type -> [Equation] -> [String]
+checkDef gr (m,fun) typ eqs = err singleton prConstrs $ do
+  bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs
+  let (bs,css) = unzip bcs
+  (constrs,_) <- unifyVal (concat css)
+  return $ filter notJustMeta constrs
 
 checkConstrs :: Grammar -> Cat -> [Ident] -> [String]
 checkConstrs gr cat _ = [] ---- check constructors!
diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs
index ba4a91874..0893db561 100644
--- a/src/GF/Compile/Update.hs
+++ b/src/GF/Compile/Update.hs
@@ -163,7 +163,7 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
       (b,n') = case info of
         ResValue _ -> (True,n)
         ResParam _ -> (True,n)
-        AbsFun _ (Just EData) -> (True,n) 
+        AbsFun _ Nothing -> (True,n) 
         AnyInd b k -> (b,k)
         _ -> (False,n) ---- canonical in Abs
 
@@ -203,13 +203,11 @@ unifMaybe (Just p1) (Just p2)
   | p1==p2                    = return (Just p1)
   | otherwise                 = fail ""
 
-unifAbsDefs :: Maybe Term -> Maybe Term -> Err (Maybe Term)
-unifAbsDefs p1 p2 = case (p1,p2) of
-  (Nothing, _)  -> return p2
-  (_, Nothing)  -> return p1
-  (Just (Eqs bs), Just (Eqs ds))
-                -> return $ Just $ Eqs $ bs ++ ds --- order!
-  _             -> fail "definitions"
+unifAbsDefs :: Maybe [Equation] -> Maybe [Equation] -> Err (Maybe [Equation])
+unifAbsDefs Nothing   Nothing   = return Nothing
+unifAbsDefs (Just _ ) Nothing   = fail ""
+unifAbsDefs Nothing   (Just _ ) = fail ""
+unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
 
 unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term])
 unifConstrs p1 p2 = case (p1,p2) of
diff --git a/src/GF/Grammar/Binary.hs b/src/GF/Grammar/Binary.hs
index f61df1c67..0521ff9c3 100644
--- a/src/GF/Grammar/Binary.hs
+++ b/src/GF/Grammar/Binary.hs
@@ -115,7 +115,6 @@ instance Binary Term where
   put (Vr x)        = putWord8 0  >> put x
   put (Cn x)        = putWord8 1  >> put x
   put (Con x)       = putWord8 2  >> put x
-  put (EData)       = putWord8 3
   put (Sort x)      = putWord8 4  >> put x
   put (EInt x)      = putWord8 5  >> put x
   put (EFloat x)    = putWord8 6  >> put x
@@ -125,7 +124,6 @@ instance Binary Term where
   put (Abs x y)     = putWord8 10 >> put (x,y)
   put (Meta x)      = putWord8 11 >> put x
   put (Prod x y z)  = putWord8 12 >> put (x,y,z)
-  put (Eqs x)       = putWord8 13 >> put x
   put (Typed x y)   = putWord8 14 >> put (x,y)
   put (Example x y) = putWord8 15 >> put (x,y)
   put (RecType x)   = putWord8 16 >> put x
@@ -155,7 +153,6 @@ instance Binary Term where
              0  -> get >>= \x       -> return (Vr x)
              1  -> get >>= \x       -> return (Cn x)
              2  -> get >>= \x       -> return (Con x)
-             3  ->                     return (EData)
              4  -> get >>= \x       -> return (Sort x)
              5  -> get >>= \x       -> return (EInt x)
              6  -> get >>= \x       -> return (EFloat x)
@@ -165,7 +162,6 @@ instance Binary Term where
              10 -> get >>= \(x,y)   -> return (Abs x y)
              11 -> get >>= \x       -> return (Meta x)
              12 -> get >>= \(x,y,z) -> return (Prod x y z)
-             13 -> get >>= \x       -> return (Eqs x)
              14 -> get >>= \(x,y)   -> return (Typed x y)
              15 -> get >>= \(x,y)   -> return (Example x y)
              16 -> get >>= \x       -> return (RecType x)
diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index c3f303655..37692ec39 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/src/GF/Grammar/Grammar.hs
@@ -81,7 +81,7 @@ type PValues = [Term]
 data Info =
 -- judgements in abstract syntax
    AbsCat   (Maybe Context) (Maybe [Term])   -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
- | AbsFun   (Maybe Type) (Maybe Term)        -- ^ (/ABS/) 'Yes f' = canonical
+ | AbsFun   (Maybe Type) (Maybe [Equation])  -- ^ (/ABS/)
 
 -- judgements in resource
  | ResParam (Maybe ([Param],Maybe PValues))  -- ^ (/RES/)
@@ -108,7 +108,6 @@ data Term =
    Vr Ident             -- ^ variable
  | Cn Ident             -- ^ constant
  | Con Ident            -- ^ constructor
- | EData                -- ^ to mark in definition that a fun is a constructor
  | Sort Ident           -- ^ basic type
  | EInt Integer         -- ^ integer literal
  | EFloat Double        -- ^ floating point literal
@@ -119,8 +118,6 @@ data Term =
  | Abs Ident Term       -- ^ abstraction: @\x -> b@
  | Meta MetaSymb        -- ^ metavariable: @?i@ (only parsable: ? = ?0)
  | Prod Ident Term Term -- ^ function type: @(x : A) -> B@
- | Eqs [Equation]       -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@
-                        -- only used in internal representation
  | Typed Term Term      -- ^ type-annotated term
 --
 -- /below this, the constructors are only for concrete syntax/
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 312cfd38e..3df2db7da 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -227,7 +227,7 @@ qualifAnnotPar m t = case t of
   Con c -> QC m c
   _ -> composSafeOp (qualifAnnotPar m) t
 
-lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Term)
+lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe [Equation])
 lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
   mo <- lookupModule gr m
   info <- lookupIdentInfo mo c
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index 958ad9a68..fa1b75dda 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -593,10 +593,6 @@ 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
diff --git a/src/GF/Grammar/Parser.y b/src/GF/Grammar/Parser.y
index fbdb541b4..981589ac0 100644
--- a/src/GF/Grammar/Parser.y
+++ b/src/GF/Grammar/Parser.y
@@ -72,7 +72,6 @@ import GF.Compile.Update (buildAnyTree)
  'data'       { T_data      }
  'def'        { T_def       }
  'flags'      { T_flags     }
- 'fn'         { T_fn        }
  'fun'        { T_fun       }
  'in'         { T_in        }
  'incomplete' { T_incomplete}
@@ -241,19 +240,19 @@ CatDef
 
 FunDef :: { [(Ident,SrcSpan,Info)] }
 FunDef
-  : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing) | fun <- $2] } 
+  : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) (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 (Eqs [($3,$5)])))] }
+  : 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)]))] }
 
 DataDef :: { [(Ident,SrcSpan,Info)] }
 DataDef
-  : Posn Ident '=' ListDataConstr Posn { ($2,   ($1,$5), AbsCat Nothing     (Just (map Cn $4))) :
-                                         [(fun, ($1,$5), AbsFun Nothing     (Just EData)) | 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) (Just EData)) | fun <- $2] }                                         
+  : Posn Ident '=' ListDataConstr Posn { ($2,   ($1,$5), AbsCat Nothing   (Just (map Cn $4))) :
+                                         [(fun, ($1,$5), AbsFun 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] }                                         
 
 ParamDef :: { [(Ident,SrcSpan,Info)] }
 ParamDef
@@ -385,7 +384,6 @@ Exp
   | Exp3 'where' '{' ListLocDef '}'   {%
                                         do defs <- mapM tryLoc $4
                                            return $ mkLet defs $1 }
-  | 'fn' '{' ListEquation '}'         { Eqs $3 }
   | 'in' Exp5 String                  { Example $2 $3 }
   | Exp1                              { $1 }
 
@@ -441,7 +439,6 @@ Exp6
   | Double                { EFloat $1 }
   | '?'                   { Meta (int2meta 0) }
   | '[' ']'               { Empty }
-  | 'data'                { EData }
   | '[' Ident Exps ']'    { foldl App (Vr (mkListId $2)) $3 }
   | '[' String ']'        { case $2 of
                               []   -> Empty
@@ -486,7 +483,6 @@ Patt2
   | '#' Ident '.' Ident       { PM $2 $4 }
   | '_'                       { wildPatt }
   | Ident                     { PV $1 }
-  | '{' Ident '}'             { PC $2 [] }
   | Ident '.' Ident           { PP $1 $3 [] }
   | Integer                   { PInt $1 }
   | Double                    { PFloat  $1 }
@@ -569,15 +565,6 @@ ListCase
   : Case              { [$1]    } 
   | Case ';' ListCase { $1 : $3 }
 
-Equation :: { Equation }
-Equation
-  : ListPatt '->' Exp         { ($1,$3) } 
-
-ListEquation :: { [Equation] }
-ListEquation
-  : Equation                  { (:[]) $1  }
-  | Equation ';' ListEquation { (:) $1 $3 }
-
 Altern :: { (Term,Term) }
 Altern
   : Exp '/' Exp { ($1,$3) } 
@@ -621,9 +608,9 @@ listCatDef id pos cont size = [catd,nilfund,consfund]
     baseId = mkBaseId id
     consId = mkConsId id
 
-    catd     = (listId, pos,   AbsCat (Just cont')   (Just [Cn baseId,Cn consId]))
-    nilfund  = (baseId, pos, AbsFun (Just niltyp)  (Just EData))
-    consfund = (consId, pos, AbsFun (Just constyp) (Just EData))
+    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)
 
     cont' = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont]
     xs = map (Vr . fst) cont'
diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs
index 474b22fe9..b658cc9d1 100644
--- a/src/GF/Grammar/Printer.hs
+++ b/src/GF/Grammar/Printer.hs
@@ -84,10 +84,8 @@ ppJudgement q (id, AbsFun ptype pexp) =
      Just typ   -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
      Nothing    -> empty) $$
   (case pexp of
-     Just EData -> empty
-     Just (Eqs [(ps,e)]) -> text "def" <+> ppIdent id <+> hcat (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi
-     Just exp   -> text "def" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
-     Nothing    -> empty)
+     Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs]
+     Nothing  -> empty)
 ppJudgement q (id, ResParam pparams) = 
   text "param" <+> ppIdent id <+>
   (case pparams of
@@ -145,9 +143,6 @@ ppTerm q d (Prod x a b)= if x == identW
 ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt)
 ppTerm q d (Let l e)    = let (ls,e') = getLet e
                           in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e')
-ppTerm q d (Eqs es)     = text "fn" <+> lbrace $$
-                          nest 2 (vcat (map (\e -> ppEquation q e <+> semi) es)) $$
-                          rbrace
 ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> text (show s))
 ppTerm q d (C e1 e2)    =prec d 1 (ppTerm q 2 e1 <+> text "++" <+> ppTerm q 1 e2)
 ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+'  <+> ppTerm q 2 e2)
@@ -182,7 +177,6 @@ ppTerm q d (EInt n)    = integer n
 ppTerm q d (EFloat f)  = double f
 ppTerm q d (Meta _)    = char '?'
 ppTerm q d (Empty)     = text "[]"
-ppTerm q d (EData)     = text "data"
 ppTerm q d (R xs)      = braces (fsep (punctuate semi [ppLabel l <+> 
                                                        fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty},
                                                              equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs
index 19035dca2..e15193550 100644
--- a/src/GF/Source/GrammarToSource.hs
+++ b/src/GF/Source/GrammarToSource.hs
@@ -75,10 +75,9 @@ mkTopDefs ds = ds
 trAnyDef :: (Ident,Info) -> [P.TopDef]
 trAnyDef (i,info) = let i' = tri i in case info of
   AbsCat (Just co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]]
-  AbsFun (Just ty) (Just EData) -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
-  AbsFun (Just ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of
-    Just t  -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
-    Nothing -> []
+  AbsFun (Just ty) Nothing    -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
+  AbsFun (Just ty) (Just eqs) -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++
+                                 [P.DefDef [P.DPatt (mkName i') (map trp patts) (trt res)] | (patts,res) <- eqs]
 
   ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
   ResParam pp -> [P.DefPar [case pp of
@@ -129,7 +128,6 @@ trt trm = case trm of
                            error $ "not yet sort " +++ show trm
     App c a -> P.EApp (trt c) (trt a)
     Abs x b -> P.EAbstr [trb x] (trt b)
-    Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
     Meta m  -> P.EMeta
     Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
     Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
@@ -178,7 +176,6 @@ trt trm = case trm of
     Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
     FV ts -> P.EVariants $ map trt ts
     Strs tt -> P.EStrs $ map trt tt
-    EData -> P.EData
     Val te _ _ -> trt te ----
     _ -> error $ "not yet" +++ show trm ----
 
-- 
cgit v1.2.3