new type checker type checks

4 files changed, 51 insertions, 38 deletions

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