gfcc from GF now works for LangEng (except literals)

3 files changed, 88 insertions, 42 deletions

diff --git a/src/GF/Canon/GFCC/CheckGFCC.hs b/src/GF/Canon/GFCC/CheckGFCC.hs
index 113a1f311..19e816e95 100644
--- a/src/GF/Canon/GFCC/CheckGFCC.hs
+++ b/src/GF/Canon/GFCC/CheckGFCC.hs
@@ -29,50 +29,62 @@ checkLin gfcc lang (f,t) =
   labelBoolIO ("happened in function " ++ printTree f) $ 
     checkTerm (lintype gfcc lang f) $ inline gfcc lang t
 
-inferTerm :: [Tpe] -> Term -> Maybe Tpe
+inferTerm :: [Tpe] -> Term -> Err 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)
+  V i -> do
+    testErr (i < length args) ("too large index " ++ show i) 
+    return $ args !! 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)
-                 )
+    let tys' = filter (/=str) tys
+    testErr (null tys')
+      ("expected Str in " ++ prt trm ++ " not " ++ unwords (map prt tys')) 
+    return str 
   R ts -> do
     tys <- mapM infer ts
     return $ tuple tys
   P t u -> do
-    R tys <- infer t
-    case u of
+    tt <- infer t
+    tu <- infer u
+    case tt of
+     R tys -> case tu of
       R [v] -> infer $ P t v
       R (v:vs) -> infer $ P (head tys) (R vs) -----
         
-      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 
+      C i -> do
+        testErr (i < length tys) 
+          ("required more than " ++ show i ++ " fields in " ++ prt (R tys)) 
+        (return $ tys !! i)   -- record: index must be known
+      _ -> do
+        let typ = head tys
+        testErr (all (==typ) tys) ("different types in table " ++ prt trm) 
+        return typ            -- table: must be same
+     _ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt
+  FV [] -> return str ----
+  FV (t:ts) -> do
+    ty <- infer t
+    tys <- mapM infer ts
+    testErr (all (==ty) tys) ("different types in variants " ++ prt trm)
+    return ty
   W s r -> infer r
-  _ -> error ("no type inference for " ++ printTree trm)
+  _ -> Bad ("no type inference for " ++ prt trm)
  where
    infer = inferTerm args
+   prt = printTree
 
 checkTerm :: LinType -> Term -> IO Bool
 checkTerm (args,val) trm = case inferTerm args trm of
-  Just ty -> if eqType ty val then return True else do
+  Ok 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
+  Bad s -> do
+    putStrLn s
     return False
 
 eqType :: Tpe -> Tpe -> Bool
@@ -117,14 +129,31 @@ inline gfcc lang t = case t of
 
 composOp :: Monad m => (Term -> m Term) -> Term -> m Term
 composOp f trm = case trm of
-  R  ts -> liftM R $ mapM comp ts
-  S  ts -> liftM S $ mapM comp ts
-  FV ts -> liftM FV $ mapM comp ts
-  P t u -> liftM2 P (comp t) (comp u)
-  W s t -> liftM (W s) $ comp t
+  R  ts -> liftM R $ mapM f ts
+  S  ts -> liftM S $ mapM f ts
+  FV ts -> liftM FV $ mapM f ts
+  P t u -> liftM2 P (f t) (f u)
+  W s t -> liftM (W s) $ f t
   _ -> return trm
- where
-   comp = composOp f
 
 composSafeOp :: (Term -> Term) -> Term -> Term
 composSafeOp f = maybe undefined id . composOp (return . f)
+
+-- from GF.Data.Oper
+
+maybeErr :: String -> Maybe a -> Err a
+maybeErr s = maybe (Bad s) Ok
+
+testErr :: Bool -> String -> Err ()
+testErr cond msg = if cond then return () else Bad msg
+
+errVal :: a -> Err a -> a
+errVal a = err (const a) id
+
+errIn :: String -> Err a -> Err a
+errIn msg = err (\s -> Bad (s ++ "\nOCCURRED IN\n" ++ msg)) return
+
+err :: (String -> b) -> (a -> b) -> Err a -> b 
+err d f e = case e of
+  Ok a -> f a
+  Bad s -> d s
diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs
index 780ca3589..b841a0ce3 100644
--- a/src/GF/Canon/GFCC/DataGFCC.hs
+++ b/src/GF/Canon/GFCC/DataGFCC.hs
@@ -1,6 +1,7 @@
 module GF.Canon.GFCC.DataGFCC where
 
 import GF.Canon.GFCC.AbsGFCC
+import GF.Canon.GFCC.PrintGFCC
 import Data.Map
 import Data.List
 import Debug.Trace ----
@@ -92,10 +93,14 @@ compute mcfg lang args = comp where
 
   look = lookLin mcfg lang
 
-  idx xs i = if i > length xs - 1 then trace "overrun !!\n" (last xs) else xs !! i 
+  idx xs i = if i > length xs - 1 
+    then trace 
+         ("too large " ++ show i ++ " for\n" ++ unlines (Prelude.map prt xs) ++ "\n") TM 
+    else xs !! i 
 
   proj r p = case (r,p) of
     (_,     FV ts) -> FV $ Prelude.map (proj r) ts
+    (FV ts, _    ) -> FV $ Prelude.map (\t -> proj t r) ts
     (W s t, _)     -> kks (s ++ getString (proj t p))
     (_,R is)       -> comp $ foldl P r is
     _              -> comp $ getField r (getIndex p)
@@ -116,6 +121,8 @@ compute mcfg lang args = comp where
     TM     -> TM
     _ -> trace ("ERROR in grammar compiler: field from " ++ show t) t
 
+  prt = printTree
+
 mkGFCC :: Grammar -> GFCC
 mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC {
   absname = a,
diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs
index a7ac02689..7d0c19b60 100644
--- a/src/GF/Devel/GrammarToGFCC.hs
+++ b/src/GF/Devel/GrammarToGFCC.hs
@@ -10,6 +10,7 @@ import qualified GF.Grammar.Macros as GM
 import qualified GF.Infra.Modules as M
 import qualified GF.Infra.Option as O
 
+import GF.Devel.PrGrammar
 import GF.Devel.ModDeps
 import GF.Infra.Ident
 import GF.Infra.Option
@@ -38,7 +39,9 @@ mkCanon2gfcc opts cnc gr =
 
 canon2gfcc :: Options -> SourceGrammar -> C.Grammar
 canon2gfcc opts cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = 
-     C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs where
+  (if (oElem (iOpt "show_canon") opts) then trace (prGrammar cgr) else id) $
+     C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs 
+ where
   cs  = map (i2i . fst) cms
   adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) | 
             (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f]
@@ -66,7 +69,7 @@ mkCType t = case t of
   EInt i      -> C.C $ fromInteger i
   RecType rs  -> C.R [mkCType t | (_, t) <- rs]
   Table pt vt -> case pt of
-    EInt i -> C.R $ replicate (fromInteger i) $ mkCType vt
+    EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
     RecType rs -> mkCType $ foldr Table vt (map snd rs) 
   Sort "Str"        -> C.S [] --- Str only
   _ -> error  $ "mkCType " ++ show t
@@ -150,7 +153,7 @@ canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs
  where
   recollect = 
     M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
-  cl2cl cg = tr $ M.MGrammar $ map c2c $ M.modules cg where
+  cl2cl cg = {- tr $ -} M.MGrammar $ map c2c $ M.modules cg where
     c2c (c,m) = case m of
       M.ModMod mo@(M.Module _ _ _ _ _ js) ->
         (c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js)
@@ -202,7 +205,7 @@ paramValues cgr = (labels,untyps,typs) where
             ]
   typsFrom ty = case ty of
     Table p t  -> typsFrom p ++ typsFrom t
-    RecType ls -> RecType (unlockTyp ls) : concat [typsFrom t | (_, t) <- ls]
+    RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls]
     _ -> [ty]
  
   typsFromTrm :: Term -> STM [Type] Term
@@ -210,6 +213,8 @@ paramValues cgr = (labels,untyps,typs) where
     V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
     T (TTyped ty) cs -> 
       updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
+    T (TComp ty) cs -> 
+      updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
     _ -> GM.composOp typsFromTrm tr
 
   jments = 
@@ -244,7 +249,7 @@ type2type cgr env@(labels,untyps,typs) ty = case ty of
   _ -> ty
  where
    t2t = type2type cgr env
-   look ty = EInt $ toInteger $ case Map.lookup ty typs of
+   look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
      Just vs -> length $ Map.assocs vs
      _ -> trace ("unknown partype " ++ show ty) 66669
 
@@ -253,12 +258,13 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
   App _ _ -> mkValCase tr 
   QC  _ _ -> mkValCase tr 
   R rs    -> R [(mkLab i, (Nothing, t2t t)) | 
-                 (i,(l,(_,t))) <- zip [0..] (unlock rs)]
+                 (i,(l,(_,t))) <- zip [0..] (sort (unlock rs))]
   P  t l   -> r2r tr
   PI t l i -> EInt $ toInteger i
-  T (TTyped ty) cs  -> mkCurry $ V ty [t2t t | (_, t) <- cs]
+  T (TComp  ty) cs  -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
+  T (TTyped ty) cs  -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
   V ty ts  -> mkCurry $ V ty [t2t t | t <- ts]
-  S t p    -> S (t2t t) (t2t p)
+  S t p    -> mkCurrySel (t2t t) (t2t p)
   _ -> GM.composSafeOp t2t tr
  where
    t2t = term2term cgr env
@@ -321,9 +327,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
 	  Just v -> EInt v
           _ -> valNumFV $ tryVar tr
         _ -> valNumFV $ tryVar tr
-      tryVar tr = case tr of
------        Par c ts -> [Par c ts' | ts' <- combinations (map tryVar ts)]
-        FV ts -> ts
+      tryVar tr = case GM.appForm tr of
+        ---(c, ts) -> [ts' | ts' <- combinations (map tryVar ts)]
+        (FV ts,_) -> ts
         _ -> [tr]
       valNumFV ts = case ts of
         [tr] -> EInt 66667 ----K (KS (A.prt tr +++ prtTrace tr "66667"))
@@ -332,7 +338,8 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
    mkCurry trm = case trm of
      V (RecType [(_,ty)]) ts -> V ty ts 
      V (RecType ((_,ty):ltys)) ts -> 
-       V ty [mkCurry (V (RecType ltys) cs) | cs <- chop (lengthtyp ty) ts] 
+       V ty [mkCurry (V (RecType ltys) cs) | 
+         cs <- chop (product (map (lengthtyp . snd) ltys)) ts] 
      _ -> trm
    lengthtyp ty = case Map.lookup ty typs of
      Just m -> length (Map.assocs m)
@@ -342,6 +349,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
      (xs1,xs2) -> xs1:chop i xs2
 
 
+   mkCurrySel t p = S t p ----
+
+
 mkLab k = LIdent (("_" ++ show k))