new type checker type checks

7 files changed, 160 insertions, 59 deletions

diff --git a/src/GF/Devel/CheckM.hs b/src/GF/Devel/CheckM.hs
new file mode 100644
index 000000000..7f85b0570
--- /dev/null
+++ b/src/GF/Devel/CheckM.hs
@@ -0,0 +1,90 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CheckM
+-- Maintainer  : (Maintainer)
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:33 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.5 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Devel.CheckM (Check,
+	       checkError, checkCond, checkWarn, checkUpdate, checkInContext,
+	       checkUpdates, checkReset, checkResets, checkGetContext, 
+	       checkLookup, checkStart, checkErr, checkVal, checkIn, 
+	       prtFail
+	      ) where
+
+import GF.Data.Operations
+import GF.Devel.Grammar.Modules
+import GF.Devel.Grammar.Terms
+import GF.Infra.Ident
+import GF.Devel.Grammar.PrGF
+
+-- | the strings are non-fatal warnings
+type Check a = STM (Context,[String]) a
+
+checkError :: String -> Check a
+checkError = raise
+
+checkCond :: String -> Bool -> Check ()
+checkCond s b = if b then return () else checkError s
+
+-- | warnings should be reversed in the end
+checkWarn :: String -> Check ()
+checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg))
+
+checkUpdate :: Decl -> Check ()
+checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg))
+
+checkInContext :: [Decl] -> Check r -> Check r
+checkInContext g ch = do
+  i <- checkUpdates g
+  r <- ch
+  checkResets i
+  return r
+
+checkUpdates :: [Decl] -> Check Int
+checkUpdates ds = mapM checkUpdate ds >> return (length ds)
+
+checkReset :: Check ()
+checkReset = checkResets 1
+
+checkResets :: Int -> Check ()
+checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg))
+
+checkGetContext :: Check Context
+checkGetContext = do
+  (co,_) <- readSTM
+  return co
+
+checkLookup :: Ident -> Check Type
+checkLookup x = do
+  co <- checkGetContext
+  checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co
+
+checkStart :: Check a -> Err (a,(Context,[String]))
+checkStart c = appSTM c ([],[])
+
+checkErr :: Err a -> Check a
+checkErr e = stm (\s -> do
+  v <- e
+  return (v,s)
+  )
+
+checkVal :: a -> Check a
+checkVal v = return v
+
+prtFail :: Print a => String -> a -> Check b
+prtFail s t = checkErr $ prtBad s t
+
+checkIn :: String -> Check a -> Check a
+checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of
+  Bad e -> Bad $ msg ++++ e
+  Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where
+    new = take (length ws' - length ws) ws'
+    ws2 = [msg ++++ w | w <- new] ++ ws
diff --git a/src/GF/Devel/Compile/CheckGrammar.hs b/src/GF/Devel/Compile/CheckGrammar.hs
index 1c957ca71..4bf9049f2 100644
--- a/src/GF/Devel/Compile/CheckGrammar.hs
+++ b/src/GF/Devel/Compile/CheckGrammar.hs
@@ -47,12 +47,13 @@ import GF.Infra.Ident
 
 --import GF.Grammar.LookAbs
 --import GF.Grammar.ReservedWords ----
-import GF.Grammar.PatternMatch (testOvershadow)
-import GF.Grammar.AppPredefined
+import GF.Devel.Grammar.PatternMatch (testOvershadow)
+import GF.Devel.Grammar.AppPredefined
 --import GF.Grammar.Lockfield (isLockLabel)
 
+import GF.Devel.CheckM
+
 import GF.Data.Operations
-import GF.Infra.CheckM
 
 import Data.List
 import qualified Data.Set as Set
@@ -77,8 +78,8 @@ checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do
     MTConcrete aname -> do
       checkErr $ topoSortOpers $ allOperDependencies name $ mjments mo
       abs <- checkErr $ lookupModule gr aname
-      js1 <- checkCompleteGrammar abs mo
-      judgementOpModule (checkCncInfo gr name (aname,abs)) js1
+      mo1 <- checkCompleteGrammar abs mo
+      entryOpModule (checkCncInfo gr name (aname,abs)) mo1
 
     MTInterface -> judgementOpModule (checkResInfo gr name) mo
 
@@ -124,8 +125,8 @@ justCheckLTerm src t = do
   ((t',_),_) <- checkStart (inferLType src t)
   return t'
 
-checkAbsInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement
-checkAbsInfo st m c info = return info ----
+checkAbsInfo :: GF -> Ident -> Judgement -> Check Judgement
+checkAbsInfo st m info = return info ----
 
 {-
 checkAbsInfo st m (c,info) = do
@@ -198,18 +199,18 @@ checkCompleteGrammar abs cnc = do
          checkWarn $ 
            "Warning: no linearization type for" +++ prt c ++ 
            ", inserting default {s : Str}" 
-         return $ Map.insert c (cncCat defLinType) js
+         return $ Map.insert c (Left (cncCat defLinType)) js
      _ -> return js
 
-checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement
-checkResInfo gr mo c info = do
+checkResInfo :: GF -> Ident -> Judgement -> Check Judgement
+checkResInfo gr mo info = do
   ----  checkReservedId c
   case jform info of
     JOper -> chIn "operation" $ case (jtype info, jdef info) of
       (_,Meta _) -> do
         checkWarn "No definition given to oper"
         return info
-      (Meta,de) -> do
+      (Meta _,de) -> do
         (de',ty') <- infer de
         return (resOper ty' de')
       (ty, de) -> do
@@ -237,7 +238,7 @@ checkResInfo gr mo c info = do
  where
    infer = inferLType gr
    check = checkLType gr
-   chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":")
+   chIn cat = checkIn ("Happened in" +++ cat) ---- +++ prt c +++ ":")
    comp = computeLType gr
 
    checkUniq xss = case xss of
@@ -265,7 +266,7 @@ checkCncInfo gr cnc (a,abs) c info = do
       ---- return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr)
                                                    -- cat for cf, typ for pe
 
-    JCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do
+    JCat -> chIn "linearization type of" $ do
       checkErr $ lookupCatContext gr a c
       typ'  <- checkIfLinType gr (jtype info)
     {- ----
@@ -278,7 +279,7 @@ checkCncInfo gr cnc (a,abs) c info = do
       checkPrintname gr (jprintname info)
       return (info {jtype = typ'})
 
-    _ -> checkResInfo gr cnc c info
+    _ -> checkResInfo gr cnc info
 
  where
    env = gr
@@ -620,7 +621,7 @@ inferLType gr trm = case trm of
      _ -> False
 
    inferPatt p = case p of
-     PP q c ps | q /= cPredef -> checkErr $ lookupOperType gr q c >>= snd . prodForm
+     PP q c ps | q /= cPredef -> checkErr $ lookupOperType gr q c >>= return . snd . prodForm
      PAs _ p  -> inferPatt p
      PNeg p   -> inferPatt p
      PAlt p q -> checks [inferPatt p, inferPatt q]
@@ -1053,14 +1054,12 @@ allOperDependencies m = allDependencies (==m)
 
 allDependencies :: (Ident -> Bool) -> Map.Map Ident JEntry -> [(Ident,[Ident])]
 allDependencies ism b = 
-  [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
+  [(f, nub (concatMap opersIn (pts i))) | (f,Left i) <- Map.assocs b]
   where
     opersIn t = case t of
       Q n c | ism n -> [c]
       QC n c | ism n -> [c]
       _ -> collectOp opersIn t
-    opty (Yes ty) = opersIn ty
-    opty _ = []
     pts i = [jtype i, jdef i]
     ----  AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual
  
diff --git a/src/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs
index 490117e27..3b8558586 100644
--- a/src/GF/Devel/Compile/Compile.hs
+++ b/src/GF/Devel/Compile/Compile.hs
@@ -4,10 +4,9 @@ module GF.Devel.Compile.Compile (batchCompile) where
 import GF.Devel.Compile.GetGrammar
 import GF.Devel.Compile.Extend
 import GF.Devel.Compile.Rename
+import GF.Devel.Compile.CheckGrammar
 ----import GF.Grammar.Refresh
-----import GF.Devel.CheckGrammar
 ----import GF.Devel.Optimize
---import GF.Compile.Evaluate ----
 ----import GF.Devel.OptimizeGF
 
 import GF.Devel.Grammar.Terms
@@ -157,7 +156,7 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do
   if null warnings then return () else putp warnings $ return ()
   intermOut opts (iOpt "show_typecheck") (prMod moc)
 
-  return (k,moc) ----
+  return (k,mor) ----
 
 
 {- ----
diff --git a/src/GF/Devel/Grammar/AppPredefined.hs b/src/GF/Devel/Grammar/AppPredefined.hs
index 6ff538148..41abf4886 100644
--- a/src/GF/Devel/Grammar/AppPredefined.hs
+++ b/src/GF/Devel/Grammar/AppPredefined.hs
@@ -20,7 +20,7 @@ module GF.Devel.Grammar.AppPredefined (
 
 import GF.Devel.Grammar.Terms
 import GF.Devel.Grammar.Macros
-import GF.Grammar.PrGF (prt,prt_,prtBad)
+import GF.Devel.Grammar.PrGF (prt,prt_,prtBad)
 import GF.Infra.Ident
 
 import GF.Data.Operations
@@ -41,29 +41,32 @@ typPredefined c@(IC f) = case f of
   "error"  -> return $ mkFunType [typeStr] (cnPredef "Error")  -- non-can. of empty set
   "PFalse" -> return $ cnPredef "PBool"
   "PTrue"  -> return $ cnPredef "PBool"
-  "dp"     -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
-  "drop"   -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+  "dp"     -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
+  "drop"   -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
   "eqInt"  -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
   "lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
-  "eqStr"  -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
-  "length" -> return $ mkFunType [typeTok] (cnPredef "Int")
-  "occur"  -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
-  "occurs" -> return $ mkFunType [typeTok,typeTok] (cnPredef "PBool")
+  "eqStr"  -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
+  "length" -> return $ mkFunType [typeStr] (cnPredef "Int")
+  "occur"  -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
+  "occurs" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
   "plus"   -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
 ----  "read"   -> (P : Type) -> Tok -> P
-  "show"   -> return $ mkProd -- (P : PType) -> P -> Tok
-    ([(zIdent "P",typePType),(wildIdent,Vr (zIdent "P"))],typeStr,[]) 
-  "toStr"  -> return $ mkProd -- (L : Type)  -> L -> Str
-    ([(zIdent "L",typeType),(wildIdent,Vr (zIdent "L"))],typeStr,[]) 
+  "show"   -> return $ mkProds -- (P : PType) -> P -> Tok
+    ([(identC "P",typePType),(wildIdent,Vr (identC "P"))],typeStr,[]) 
+  "toStr"  -> return $ mkProds -- (L : Type)  -> L -> Str
+    ([(identC "L",typeType),(wildIdent,Vr (identC "L"))],typeStr,[]) 
   "mapStr" -> 
-    let ty = zIdent "L" in
-    return $ mkProd -- (L : Type)  -> (Str -> Str) -> L -> L
+    let ty = identC "L" in
+    return $ mkProds -- (L : Type)  -> (Str -> Str) -> L -> L
     ([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[]) 
-  "take"   -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
-  "tk"     -> return $ mkFunType [cnPredef "Int",typeTok] typeTok
+  "take"   -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
+  "tk"     -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
   _        -> prtBad "unknown in Predef:" c
+
 typPredefined c = prtBad "unknown in Predef:" c
 
+mkProds (cont,t,xx) = foldr (uncurry Prod) (mkApp t xx) cont
+
 appPredefined :: Term -> Err (Term,Bool)
 appPredefined t = case t of
 
@@ -119,10 +122,10 @@ appPredefined t = case t of
 str2tag :: String -> Term
 str2tag s = case s of
 ----  '\'' : cs -> mkCn $ pTrm $ init cs
-  _ -> Cn $ IC s ---
+  _ -> Con $ IC s ---
  where
    mkCn t = case t of
-     Vr i -> Cn i
+     Vr i -> Con i
      App c a -> App (mkCn c) (mkCn a)
      _ -> t
 
@@ -140,7 +143,6 @@ trm2str :: Term -> Err Term
 trm2str t = case t of
   R ((_,(_,s)):_) -> trm2str s
   T _ ((_,s):_)   -> trm2str s
-  TSh _ ((_,s):_) -> trm2str s
   V _ (s:_)       -> trm2str s
   C _ _         -> return $ t
   K _           -> return $ t
@@ -153,7 +155,7 @@ trm2str t = case t of
 -- (this has been done in type checking)
 mapStr :: Type -> Term -> Term -> Term
 mapStr ty f t = case (ty,t) of
-  _ | elem ty [typeStr,typeTok] -> App f t
+  _ | elem ty [typeStr,typeStr] -> App f t
   (_,        R ts)    -> R [(l,mapField v)   | (l,v) <- ts]
   (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
   _    -> t 
diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs
index 659ddb107..51c1669f4 100644
--- a/src/GF/Devel/Grammar/Macros.hs
+++ b/src/GF/Devel/Grammar/Macros.hs
@@ -21,11 +21,22 @@ typeForm t = (co,f,a) where
   (co,t2) = prodForm t
   (f,a) = appForm t2
 
+termForm :: Term -> ([Ident],Term,[Term])
+termForm t = (co,f,a) where
+  (co,t2) = absForm t
+  (f,a) = appForm t2
+
 prodForm :: Type -> (Context,Term)
 prodForm t = case t of
   Prod x ty val -> ((x,ty):co,t2) where (co,t2) = prodForm val
   _ -> ([],t)
 
+absForm :: Term -> ([Ident],Term)
+absForm t = case t of
+  Abs x val -> (x:co,t2) where (co,t2) = absForm val
+  _ -> ([],t)
+
+
 appForm :: Term -> (Term,[Term])
 appForm tr = (f,reverse xs) where 
   (f,xs) = apps tr
@@ -171,6 +182,8 @@ isTypeInts ty = case ty of
   App c _ -> c == constPredefRes "Ints"
   _ -> False
 
+cnPredef = constPredefRes
+
 constPredefRes :: String -> Term
 constPredefRes s = Q (IC "Predef") (identC s)
 
@@ -214,6 +227,15 @@ judgementOpModule f m = do
   return m {mjments = mjs}
  where
   fj = either (liftM Left . f) (return . Right)
+
+entryOpModule :: Monad m => 
+                 (Ident -> Judgement -> m Judgement) -> Module -> m Module
+entryOpModule f m = do 
+  mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m
+  return $ m {mjments = mjs}
+ where
+  mapm = mapM (\ (i,j) -> liftM ((,) i) (fe i j)) 
+  fe i j = either (liftM Left . f i) (return . Right) j
    
 termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement
 termOpJudgement f j = do 
diff --git a/src/GF/Devel/Grammar/PatternMatch.hs b/src/GF/Devel/Grammar/PatternMatch.hs
index 38c20fa98..193694a27 100644
--- a/src/GF/Devel/Grammar/PatternMatch.hs
+++ b/src/GF/Devel/Grammar/PatternMatch.hs
@@ -18,9 +18,9 @@ module GF.Devel.Grammar.PatternMatch (matchPattern,
 		    ) where
 
 
-import GF.Grammar.Terms
-import GF.Grammar.Macros
-import GF.Grammar.PrGF
+import GF.Devel.Grammar.Terms
+import GF.Devel.Grammar.Macros
+import GF.Devel.Grammar.PrGF
 import GF.Infra.Ident
 
 import GF.Data.Operations
@@ -56,15 +56,12 @@ findMatch cases terms = case cases of
 
 tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
 tryMatch (p,t) = do 
-  t' <- termForm t
+  let t' = termForm t
   trym p t'
  where
   isInConstantFormt = True -- tested already
   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, _) | isInConstantFormt -> return [] -- optimization with wildcard
       (PV x,  _) | isInConstantFormt -> return [(x,t)]
@@ -94,7 +91,6 @@ tryMatch (p,t) = do
                             [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
             return (concat matches)
       (PT _ p',_) -> trym p' t'
-      (_, ([],Alias _ _ d,[])) -> tryMatch (p,d)
 
 --      (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do
 
@@ -119,10 +115,11 @@ tryMatch (p,t) = do
         ] >>
         return []
       _ -> prtBad "no match in case expr for" t
-  
+
+eqStrIdent = (==) ----  
+
 isInConstantForm :: Term -> Bool
 isInConstantForm trm = case trm of
-    Cn _     -> True
     Con _    -> True
     Q _ _    -> True
     QC _ _   -> True
@@ -131,7 +128,6 @@ isInConstantForm trm = case trm of
     R r      -> all (isInConstantForm . snd . snd) r
     K _      -> True
     Empty    -> True
-    Alias _ _ t -> isInConstantForm t
     EInt _   -> True
     _       -> False ---- isInArgVarForm trm
 
@@ -144,10 +140,3 @@ varsOfPatt p = case p of
   PT _ q -> varsOfPatt q
   _ -> []
 
--- | to search matching parameter combinations in tables
-isMatchingForms :: [Patt] -> [Term] -> Bool
-isMatchingForms ps ts = all match (zip ps ts') where
-  match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
-  match _ = True
-  ts' = map appForm ts
-
diff --git a/src/GF/Devel/Grammar/PrGF.hs b/src/GF/Devel/Grammar/PrGF.hs
index 589f5e9b4..83ab4c7f1 100644
--- a/src/GF/Devel/Grammar/PrGF.hs
+++ b/src/GF/Devel/Grammar/PrGF.hs
@@ -82,13 +82,13 @@ instance Print Term where
 instance Print Ident where
   prt = cprintTree . tri
 
-{- ----
 instance Print Patt where
   prt = P.printTree . trp
 
 instance Print Label where
   prt = P.printTree . trLabel
 
+{-
 instance Print MetaSymb where
   prt (MetaSymb i) = "?" ++ show i