work with GrammarToGFCC, not complete

src/GF/Canon/GFCC/CheckGFCC.hs

@@ -49,6 +49,9 @@ inferTerm args trm = case trm of
   P t u -> do
     R tys <- infer t
     case u 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))

src/GF/Devel/GrammarToGFCC.hs

@@ -64,34 +64,22 @@ mkType t = case GM.catSkeleton t of
 mkCType :: Type -> C.Term
 mkCType t = case t of
   EInt i      -> C.C $ fromInteger i
-  -- record parameter alias - created in gfc preprocessing
+  RecType rs  -> C.R [mkCType t | (_, t) <- rs]
-  ----RecType [(LIdent "_", i)] -> mkCType i
+  Table pt vt -> case pt of
-  --- RecType [(LIdent "_", i), (LIdent "__", t)] -> C.RP (mkCType i) (mkCType t)
+    EInt i -> C.R $ replicate (fromInteger i) $ mkCType vt
-  RecType rs     -> C.R [mkCType t | (_, t) <- rs]
+    RecType rs -> mkCType $ foldr Table vt (map snd rs) 
-  Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt
+  Sort "Str"        -> C.S [] --- Str only
-  _    -> C.S [] ----- TStr
+  _ -> error  $ "mkCType " ++ show t
- where
-  getI pt = case pt of
-    C.C i -> i
-    C.RP i _ -> getI i
-    _ -> 1 -----
 
 mkTerm :: Term -> C.Term
 mkTerm tr = case tr of
   Vr (IA (_,i)) -> C.V i
   Vr (IC s) | isDigit (last s) -> 
-    C.V (read (reverse (takeWhile (/='_') (reverse s)))) ---- from gf parser of gfc
+    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)), (LIdent "__", (_,t))] -> C.RP (mkTerm i) (mkTerm t)
-  -- ordinary record
   R rs     -> C.R [mkTerm t | (_, (_,t)) <- rs]
   P t l    -> C.P (mkTerm t) (C.C (mkLab l))
-
------  LI x     -> C.BV $ i2i x
------  T _ [(PV x, t)] -> C.L (i2i x) (mkTerm t)
-
   T _ cs   -> C.R [mkTerm t | (_,t) <- cs] ------
   V _ cs   -> C.R [mkTerm t | t <- cs]
   S t p    -> C.P (mkTerm t) (mkTerm p)
@@ -158,7 +146,8 @@ utf8Conv = M.MGrammar . map toUTF8 . M.modules where
 -- translate tables and records to arrays, parameters and labels to indices
 
 canon2canon :: Ident -> SourceGrammar -> SourceGrammar
-canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs where
+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
@@ -168,7 +157,7 @@ canon2canon abs = recollect . map cl2cl . repartition abs . purgeGrammar abs whe
       _ -> (c,m)
     j2j (f,j) = case j of
       CncFun x (Yes tr) z -> (f,CncFun x (Yes (t2t tr)) z)
-      CncCat (Yes ty) (Yes x) y   -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y)
+      CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y)
       _ -> (f,j)
     t2t = term2term cg pv
     ty2ty = type2type cg pv
@@ -196,7 +185,7 @@ type ParamEnv =
    Map.Map Term Integer,                   -- untyped terms to values
    Map.Map Type (Map.Map Term Integer))    -- types to their terms to values
 
---- gathers those param types that are actually used in lincats and in lin terms
+--- gathers those param types that are actually used in lincats and lin terms
 paramValues :: SourceGrammar -> ParamEnv
 paramValues cgr = (labels,untyps,typs) where
   params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps]
@@ -219,13 +208,16 @@ paramValues cgr = (labels,untyps,typs) where
   typsFromTrm :: Term -> STM [Type] Term
   typsFromTrm tr = case tr of
     V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
-    T (TTyped ty) cs -> updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
+    T (TTyped ty) cs -> 
+      updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
     _ -> GM.composOp typsFromTrm tr
 
-
+  jments = 
-  jments = [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo]
+    [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo]
-  typs = Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
+  typs = 
-  untyps = Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
+    Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
+  untyps = 
+    Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
   lincats = 
     [(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Int", "Float", "String"]] ++
     [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments]
@@ -246,48 +238,26 @@ paramValues cgr = (labels,untyps,typs) where
 type2type :: SourceGrammar -> ParamEnv -> Type -> Type
 type2type cgr env@(labels,untyps,typs) ty = case ty of
   RecType rs ->
-    let
+    RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)]
-      rs' = [(mkLab i, t2t t) | 
-               (i,(l, t)) <- zip [0..] (unlockTyp rs)]
-    in if (any isStrType [t | (_, t) <- rs])
-      then RecType rs'
-      else look ty
-  --- else RecType [(LIdent "_", look ty), (LIdent "__", RecType rs')]
-
   Table pt vt -> Table (t2t pt) (t2t vt)
-  Cn _ -> look ty
+  QC _ _ -> look ty
   _ -> ty
  where
    t2t = type2type cgr env
    look ty = EInt $ toInteger $ case Map.lookup ty typs of
      Just vs -> length $ Map.assocs vs
-     _ -> trace ("unknown partype " ++ show ty) 1 ---- 66669
+     _ -> trace ("unknown partype " ++ show ty) 66669
 
 term2term :: SourceGrammar -> ParamEnv -> Term -> Term
 term2term cgr env@(labels,untyps,typs) tr = case tr of
   App _ _ -> mkValCase tr 
   QC  _ _ -> mkValCase tr 
-  R rs ->
+  R rs    -> R [(mkLab i, (Nothing, t2t t)) | 
-    let
+                 (i,(l,(_,t))) <- zip [0..] (unlock rs)]
-      tr' = R [(l, (Nothing,t)) | 
+  P  t l   -> r2r tr
-               (l,(_,t)) <- unlock rs]
+  PI t l i -> EInt $ toInteger i
-      rs' = [(mkLab i, (Nothing, t2t t)) | 
+  T (TTyped ty) cs  -> mkCurry $ V ty [t2t t | (_, t) <- cs]
-               (i,(l,(_,t))) <- zip [0..] (unlock rs)]
+  V ty ts  -> mkCurry $ V ty [t2t t | t <- ts]
-    in 
-      ----if (any (isStr . trmAss) rs)
-      ----then 
-      R rs'
-  --- else 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
-
------  T ti [Cas ps@[PV _] t] -> T ti [Cas ps (t2t t)]
-
-  T (TTyped ty) cs  -> V ty [t2t t | (_, t) <- cs]
-  ----    _ -> K (KS (A.prt tr +++ prtTrace tr "66668"))
-  V ty ts  -> V ty [t2t t | t <- ts]
   S t p    -> S (t2t t) (t2t p)
   _ -> GM.composSafeOp t2t tr
  where
@@ -297,6 +267,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
      Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
      _ -> valNum tr
 
+   --- this is mainly needed for parameter record projections
+   comp t = t ----- $ Look.ccompute cgr [] t
+
    doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term
    doVar tr = case getLab tr of
      Ok (cat, lab) -> do
@@ -355,36 +328,23 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
       valNumFV ts = case ts of
         [tr] -> EInt 66667 ----K (KS (A.prt tr +++ prtTrace tr "66667"))
         _ -> FV $ map valNum ts
-   isStr tr = case tr of
-     App _ _ -> False
-     QC _ _  -> False
-     EInt _  -> False
-     R rs    -> any (isStr . trmAss) rs
-     FV ts   -> any isStr ts
-     S t _   -> isStr t
-     Empty   -> True
-     T _ cs  -> any isStr [v | (_, v) <- cs]
-     V _ ts  -> any isStr ts
-     P t r   -> case getLab tr of
-       Ok (cat,labs) -> case 
-          Map.lookup (cat,labs) labels of
-            Just (ty,_) -> isStrType ty 
-            _ -> True ---- TODO?
-       _ -> True
-     _ -> True ----
-   trmAss (_,(_, t)) = t
 
-   --- this is mainly needed for parameter record projections
+   mkCurry trm = case trm of
-   comp t = t ----- $ Look.ccompute cgr [] t
+     V (RecType [(_,ty)]) ts -> V ty ts 
+     V (RecType ((_,ty):ltys)) ts -> 
+       V ty [mkCurry (V (RecType ltys) cs) | cs <- chop (lengthtyp ty) ts] 
+     _ -> trm
+   lengthtyp ty = case Map.lookup ty typs of
+     Just m -> length (Map.assocs m)
+     _ -> error $ "length of type " ++ show ty
+   chop i xs = case splitAt i xs of 
+     (xs1,[])  -> [xs1]
+     (xs1,xs2) -> xs1:chop i xs2
 
-isStrType ty = case ty of
-     Sort "Str" -> True
-     RecType ts -> any isStrType [t | (_, t) <- ts]
-     Table _ t -> isStrType t
-     _ -> False
 
 mkLab k = LIdent (("_" ++ show k))
 
+
 -- remove lock fields; in fact, any empty records and record types
 unlock = filter notlock where
   notlock (l,(_, t)) = case t of --- need not look at l
@@ -395,7 +355,6 @@ unlockTyp = filter notlock where
      RecType [] -> False
      _ -> True
 
-
 prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n
 prTrace  tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
 
@@ -498,3 +457,31 @@ collectSubterms t = case t of
          _ ->            ((1,   i ), i+1)
      writeSTM (Map.insert t (count,id) ts, next)
 
+{-
+-- needed in the past
+isStr tr = case tr of
+     App _ _ -> False
+     QC _ _  -> False
+     EInt _  -> False
+     R rs    -> any (isStr . trmAss) rs
+     FV ts   -> any isStr ts
+     S t _   -> isStr t
+     Empty   -> True
+     T _ cs  -> any isStr [v | (_, v) <- cs]
+     V _ ts  -> any isStr ts
+     P t r   -> case getLab tr of
+       Ok (cat,labs) -> case 
+          Map.lookup (cat,labs) labels of
+            Just (ty,_) -> isStrType ty 
+            _ -> True ---- TODO?
+       _ -> True
+     _ -> True ----
+   trmAss (_,(_, t)) = t
+
+
+isStrType ty = case ty of
+     Sort "Str" -> True
+     RecType ts -> any isStrType [t | (_, t) <- ts]
+     Table _ t -> isStrType t
+     _ -> False
+-}