more tc of gfcc

3 files changed, 72 insertions, 23 deletions

diff --git a/src/GF/Canon/GFCC/CheckGFCC.hs b/src/GF/Canon/GFCC/CheckGFCC.hs
index cc27f5c1e..b11ca146d 100644
--- a/src/GF/Canon/GFCC/CheckGFCC.hs
+++ b/src/GF/Canon/GFCC/CheckGFCC.hs
@@ -3,6 +3,7 @@ module GF.Canon.GFCC.CheckGFCC where
 import GF.Canon.GFCC.DataGFCC
 import GF.Canon.GFCC.AbsGFCC
 import GF.Canon.GFCC.PrintGFCC
+import GF.Canon.GFCC.ErrM
 
 import qualified Data.Map as Map
 import Control.Monad
@@ -20,31 +21,76 @@ checkGFCC gfcc = andMapM (checkConcrete gfcc) $ Map.assocs $ concretes gfcc
 
 checkConcrete :: GFCC -> (CId,Map.Map CId Term) -> IO Bool
 checkConcrete gfcc (lang,cnc) = 
-  labelBoolIO (printTree lang) $ andMapM (checkLin gfcc lang) $ linRules cnc
+  labelBoolIO ("happened in language " ++ printTree lang) $ 
+    andMapM (checkLin gfcc lang) $ linRules cnc
 
 checkLin :: GFCC -> CId -> (CId,Term) -> IO Bool
 checkLin gfcc lang (f,t) = 
-  labelBoolIO (printTree f) $ checkTerm (lintype gfcc lang f) $ inline gfcc lang t
+  labelBoolIO ("happened in function " ++ printTree f) $ 
+    checkTerm (lintype gfcc lang f) $ inline gfcc lang t
+
+inferTerm :: [Tpe] -> Term -> Maybe Tpe
+inferTerm args trm = case trm of
+  K _ -> return str
+  C i -> return $ ints i
+  V i -> if i < length args 
+           then (return $ args !! i) 
+           else error ("index " ++ show i)
+  S ts -> do
+    tys <- mapM infer ts
+    if all (==str) tys 
+      then return str 
+      else error ("only strings expected in: " ++ printTree trm
+                  ++ " instead of " ++ unwords (map printTree tys)
+                 )
+  R ts -> do
+    tys <- mapM infer ts
+    return $ tuple tys
+  P t u -> do
+    R tys <- infer t
+    case u of
+      C i -> if (i < length tys) 
+             then (return $ tys !! i) -- record: index must be known
+             else error ("too few fields in " ++ printTree (R tys))
+      _ -> if all (==head tys) tys    -- table: must be same
+             then return (head tys) 
+             else error ("projection " ++ printTree trm)
+  FV ts -> return $ head ts ---- empty variants; check equality 
+  W s r -> infer r
+  _ -> error ("no type inference for " ++ printTree trm)
+ where
+   infer = inferTerm args
 
 checkTerm :: LinType -> Term -> IO Bool
-checkTerm (args,val) trm = case (val,trm) of
-  (R tys, R trs) -> do
-    let (ntys,ntrs) = (length tys,length trs)
-    b <- checkCond 
-      ("number of fields in " ++ prtrm ++ " does not match " ++ prval) (ntys == ntrs)
-    bs <- andMapM (uncurry check) (zip tys trs)
-    return $ b && bs
-  (R _, W _ r) -> check val r
-  _ -> return True
- where
-   checkCond msg cond = if cond then return True else (putStrLn msg >> return False)
-   check ty tr = checkTerm (args,ty) tr
-   prtrm = printTree trm
-   prval = printTree val
+checkTerm (args,val) trm = case inferTerm args trm of
+  Just ty -> if eqType ty val then return True else do
+    putStrLn $ "term: " ++ printTree trm ++ 
+               "\nexpected type: " ++ printTree val ++
+               "\ninferred type: " ++ printTree ty
+    return False
+  _ -> do
+    putStrLn $ "cannot infer type of " ++ printTree trm
+    return False
+
+eqType :: Tpe -> Tpe -> Bool
+eqType inf exp = case (inf,exp) of
+  (C k, C n)  -> k <= n -- only run-time corr.
+  (R rs,R ts) -> length rs == length ts && and [eqType r t | (r,t) <- zip rs ts]
+  _ -> inf == exp
 
 -- should be in a generic module, but not in the run-time DataGFCC
 
-type LinType = ([Term],Term)
+type Tpe = Term
+type LinType = ([Tpe],Tpe)
+
+tuple :: [Tpe] -> Tpe
+tuple = R
+
+ints :: Int -> Tpe
+ints = C
+
+str :: Tpe
+str = S []
 
 lintype :: GFCC -> CId -> CId -> LinType
 lintype gfcc lang fun = case lookType gfcc fun of
diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs
index f42b48d1b..780ca3589 100644
--- a/src/GF/Canon/GFCC/DataGFCC.hs
+++ b/src/GF/Canon/GFCC/DataGFCC.hs
@@ -96,7 +96,8 @@ compute mcfg lang args = comp where
 
   proj r p = case (r,p) of
     (_,     FV ts) -> FV $ Prelude.map (proj r) ts
-    (W s t, _)     -> kks (s ++ getString (proj t p))      
+    (W s t, _)     -> kks (s ++ getString (proj t p))
+    (_,R is)       -> comp $ foldl P r is
     _              -> comp $ getField r (getIndex p)
 
   getString t = case t of
diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs
index 2742629d5..9fc48eaea 100644
--- a/src/GF/Devel/GrammarToGFCC.hs
+++ b/src/GF/Devel/GrammarToGFCC.hs
@@ -65,7 +65,7 @@ mkCType :: Type -> C.Term
 mkCType t = case t of
   EInt i      -> C.C $ fromInteger i
   -- record parameter alias - created in gfc preprocessing
-  RecType [(LIdent "_", i)] -> mkCType i
+  ----RecType [(LIdent "_", i)] -> mkCType i
   --- RecType [(LIdent "_", i), (LIdent "__", t)] -> C.RP (mkCType i) (mkCType t)
   RecType rs     -> C.R [mkCType t | (_, t) <- rs]
   Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt
@@ -83,7 +83,7 @@ mkTerm tr = case tr of
     C.V (read (reverse (takeWhile (/='_') (reverse s)))) ---- from gf parser of gfc
   EInt i      -> C.C $ fromInteger i
   -- record parameter alias - created in gfc preprocessing
-  R [(LIdent "_", (_,i))] -> mkTerm i
+  ----R [(LIdent "_", (_,i))] -> mkTerm i
   --- R [(LIdent "_", (_,i)), (LIdent "__", (_,t))] -> C.RP (mkTerm i) (mkTerm t)
   -- ordinary record
   R rs     -> C.R [mkTerm t | (_, (_,t)) <- rs]
@@ -273,10 +273,12 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
                (l,(_,t)) <- unlock rs]
       rs' = [(mkLab i, (Nothing, t2t t)) | 
                (i,(l,(_,t))) <- zip [0..] (unlock rs)]
-    in if (any (isStr . trmAss) rs)
-      then R rs'
+    in 
+      ----if (any (isStr . trmAss) rs)
+      ----then 
+      R rs'
   --- else mkValCase tr
-      else R [(LIdent "_", (Nothing, mkValCase tr'))]
+  ----else R [(LIdent "_", (Nothing, mkValCase tr'))]
   --- else R [(LIdent "_", (Nothing, mkValCase tr)), (LIdent "__",(Nothing,R rs'))]
   P t l    -> r2r tr
   PI t l i  -> EInt $ toInteger i