refresh compilation phase in the new format

src/GF/Devel/Compile/CheckGrammar.hs

@@ -73,7 +73,7 @@ checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do
 ----  checkRestrictedInheritance gr (name, mo)
   mo1 <- case mtype mo of
     MTAbstract -> judgementOpModule (checkAbsInfo gr name) mo
-    MTGrammar -> judgementOpModule (checkResInfo gr name) mo
+    MTGrammar -> entryOpModule (checkResInfo gr name) mo
 
     MTConcrete aname -> do
       checkErr $ topoSortOpers $ allOperDependencies name $ mjments mo
@@ -81,12 +81,12 @@ checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do
       mo1 <- checkCompleteGrammar abs mo
       entryOpModule (checkCncInfo gr name (aname,abs)) mo1
 
-    MTInterface -> judgementOpModule (checkResInfo gr name) mo
+    MTInterface -> entryOpModule (checkResInfo gr name) mo
 
     MTInstance iname -> do
       intf <- checkErr $ lookupModule gr iname
       -- checkCompleteInstance abs mo -- this is done in Rebuild
-      judgementOpModule  (checkResInfo gr name) mo
+      entryOpModule  (checkResInfo gr name) mo
 
   return $ (name, mo1)
 
@@ -202,8 +202,8 @@ checkCompleteGrammar abs cnc = do
          return $ Map.insert c (Left (cncCat defLinType)) js
      _ -> return js
 
-checkResInfo :: GF -> Ident -> Judgement -> Check Judgement
-checkResInfo gr mo info = do
+checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement
+checkResInfo gr mo c info = do
   ----  checkReservedId c
   case jform info of
     JOper -> chIn "operation" $ case (jtype info, jdef info) of
@@ -212,6 +212,7 @@ checkResInfo gr mo info = do
         return info
       (Meta _,de) -> do
         (de',ty') <- infer de
+        ---- trace ("inferred" +++ prt de' +++ ":" +++ prt ty') $ 
         return (resOper ty' de')
       (ty, de) -> do
         ty'     <- check ty typeType >>= comp . fst
@@ -238,7 +239,7 @@ checkResInfo gr mo 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
@@ -279,7 +280,7 @@ checkCncInfo gr cnc (a,abs) c info = do
       checkPrintname gr (jprintname info)
       return (info {jtype = typ'})
 
-    _ -> checkResInfo gr cnc info
+    _ -> checkResInfo gr cnc c info
 
  where
    env = gr
@@ -377,8 +378,8 @@ computeLType gr t = do
       let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs
       liftM RecType $ mapPairsM comp fs'
 
-----    _ | ty == typeStr -> return typeStr
-----    _ | isPredefConstant ty -> return ty
+    _ | ty == typeTok -> return typeStr  ---- deprecated
+    _ | isPredefConstant ty -> return ty
 
     _ -> composOp comp ty
 
@@ -634,7 +635,7 @@ inferLType gr trm = case trm of
 -- the latter permits matching with value type
 getOverload :: GF -> Maybe Type -> Term -> Check (Maybe (Term,Type))
 getOverload env@gr mt t = case appForm t of
-     (f@(Q m c), ts) -> case (return []) of ---- lookupOverload gr m c of
+     (f@(Q m c), ts) -> case lookupOverload gr m c of
        Ok typs -> do
          ttys <- mapM infer ts
          v <- matchOverload f typs ttys
@@ -722,6 +723,8 @@ checkLType env trm typ0 = do
           (trm',ty') <- infer trm
           termWith trm' $ checkEq typ ty' trm'
 
+    EData -> return (trm,typ)
+
     T _ [] ->
       prtFail "found empty table in type" typ
     T _ cs -> case typ of 
@@ -729,11 +732,11 @@ checkLType env trm typ0 = do
         case allParamValues env arg of
           Ok vs -> do
             let ps0 = map fst cs
-            ps <- checkErr $ testOvershadow ps0 vs
+            ps <- return [] ---- checkErr $ testOvershadow ps0 vs
             if null ps 
               then return () 
-              else checkWarn $ "WARNING: patterns never reached:" +++ 
-                               concat (intersperse ", " (map prt ps))
+              else checkWarn $ "WARNING: patterns never reached:"
+                               ---- +++ concat (intersperse ", " (map prt ps))
 
           _ -> return () -- happens with variable types
         cs' <- mapM (checkCase arg val) cs
@@ -953,6 +956,9 @@ checkIfEqLType env t u trm = do
      -- error (the empty type!) is subtype of any other type
      (_,Q (IC "Predef") (IC "Error")) -> True
 
+     -- unknown type unifies with any type ----
+     (_,Meta _) -> True
+
      -- contravariance
      (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d 
                               
@@ -1010,7 +1016,7 @@ checkIfEqLType env t u trm = do
    ---- to revise
    allExtendsPlus _ n = [n]
 
-   sTypes = [typeStr, typeString]
+   sTypes = [typeStr, typeString, typeTok] ---- Tok deprecated
    comp = computeLType env
 
 -- printing a type with a lock field lock_C as C

src/GF/Devel/Compile/Compile.hs

@@ -5,7 +5,7 @@ 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.Compile.Refresh
 ----import GF.Devel.Optimize
 ----import GF.Devel.OptimizeGF
 
@@ -156,7 +156,12 @@ 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,mor) ----
+  (k',mox) <- putpp "  refreshing " $ ioeErr $ refreshModule k moc
+  intermOut opts (iOpt "show_refresh") (prMod mox)
+
+
+
+  return (k,mox) ----
 
 
 {- ----
@@ -173,10 +178,6 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do
       if null warnings then return () else putp warnings $ return ()
       intermOut opts (iOpt "show_typecheck") (prMod mo3)
 
-
-      (k',mo3r:_) <- putpp "  refreshing " $ ioeErr $ refreshModule (k,mos) mo3
-      intermOut opts (iOpt "show_refresh") (prMod mo3r)
-
       let eenv = () --- emptyEEnv
       (mo4,eenv') <- 
         ---- if oElem "check_only" opts 

src/GF/Devel/Compile/Refresh.hs

@@ -9,20 +9,33 @@
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.6 $
 --
--- (Description of the module)
+-- make variable names unique by adding an integer index to each
 -----------------------------------------------------------------------------
 
-module GF.Devel.Compile.Refresh (refreshTerm, refreshTermN,
-		refreshModule
-	       ) where
+module GF.Devel.Compile.Refresh (
+  refreshModule,
+  refreshTerm, 
+  refreshTermN
+  ) where
+
+import GF.Devel.Grammar.Modules
+import GF.Devel.Grammar.Terms
+import GF.Devel.Grammar.Macros
+import GF.Infra.Ident
 
 import GF.Data.Operations
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Infra.Modules
-import GF.Grammar.Macros
+
 import Control.Monad
 
+
+-- for concrete and resource in grammar, before optimizing
+
+refreshModule :: Int -> SourceModule -> Err (Int,SourceModule)
+refreshModule k (m,mo) = do
+  (mo',(_,k')) <- appSTM (termOpModule refresh mo) (initIdStateN k)
+  return (k',(m,mo'))
+
+
 refreshTerm :: Term -> Err Term
 refreshTerm = refreshTermN 0
 
@@ -103,31 +116,3 @@ refreshEquation :: Equation -> Err ([Patt],Term)
 refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where
   refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t)
 
--- for concrete and resource in grammar, before optimizing
-
-refreshGrammar :: SourceGrammar -> Err SourceGrammar
-refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
-
-refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
-refreshModule (k,ms) mi@(i,m) = case m of
-    ModMod mo@(Module mt fs st me ops js) | (isModCnc mo || isModRes mo) -> do
-      (k',js') <- foldM refreshRes (k,[]) $ tree2list js
-      return (k', (i, ModMod(Module mt fs st me ops (buildTree js'))) : ms)
-    _ -> return (k, mi:ms)
- where
-  refreshRes (k,cs) ci@(c,info) = case info of
-    ResOper ptyp (Yes trm) -> do   ---- refresh ptyp
-      (k',trm') <- refreshTermKN k trm
-      return $ (k', (c, ResOper ptyp (Yes trm')):cs)
-    ResOverload tyts -> do
-      (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ 
-                    appSTM (mapPairsM refresh tyts) (initIdStateN k)
-      return $ (k', (c, ResOverload tyts'):cs)
-    CncCat mt (Yes trm) pn -> do   ---- refresh mt, pn
-      (k',trm') <- refreshTermKN k trm
-      return $ (k', (c, CncCat mt (Yes trm') pn):cs)
-    CncFun mt (Yes trm) pn -> do   ---- refresh pn
-      (k',trm') <- refreshTermKN k trm
-      return $ (k', (c, CncFun mt (Yes trm') pn):cs)
-    _ -> return (k, ci:cs)
-

src/GF/Devel/Grammar/Lookup.hs

@@ -9,6 +9,7 @@ import GF.Infra.Ident
 
 import GF.Data.Operations
 
+import Control.Monad (liftM)
 import Data.Map
 import Data.List (sortBy) ----
 
@@ -39,11 +40,26 @@ lookupLincat :: GF -> Ident -> Ident -> Err Term
 lookupLincat = lookupJField jtype
 
 lookupOperType :: GF -> Ident -> Ident -> Err Term
-lookupOperType = lookupJField jtype 
+lookupOperType gr m c = do
+  ju <- lookupJudgement gr m c
+  case jform ju of
+    JParam -> return typePType
+    _ -> case jtype ju of
+      Meta _ -> fail "no type given"
+      ty -> return ty
+---- can't be just lookupJField jtype 
 
 lookupOperDef :: GF -> Ident -> Ident -> Err Term
 lookupOperDef = lookupJField jdef
 
+lookupOverload :: GF -> Ident -> Ident -> Err [([Type],(Type,Term))]
+lookupOverload gr m c = do
+  tr <- lookupJField jdef gr m c
+  case tr of
+    Overload tysts -> return 
+      [(lmap snd args,(val,tr)) | (ty,tr) <- tysts, let (args,val) = prodForm ty]
+    _   -> Bad $ prt c +++ "is not an overloaded operation"
+
 lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)]
 lookupParams gf m c = do
   ty <- lookupJField jtype gf m c
@@ -56,8 +72,14 @@ lookupParamValues :: GF -> Ident -> Ident -> Err [Term]
 lookupParamValues gf m c = do
   d <- lookupJField jdef gf m c
   case d of
-    V _ ts -> return ts
-    _ -> raise "no parameter values"
+    ---- V _ ts -> return ts
+    _ -> do
+      ps <- lookupParams gf m c
+      liftM concat $ mapM mkPar ps
+ where
+   mkPar (f,co) = do
+     vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co
+     return $ lmap (mkApp (QC m f)) vs
 
 allParamValues :: GF -> Type -> Err [Term]
 allParamValues cnc ptyp = case ptyp of
@@ -95,4 +117,5 @@ mlookup = Data.Map.lookup
 
 raiseIdent msg i = raise (msg +++ prIdent i)
 
+lmap = Prelude.map
 

src/GF/Devel/Grammar/Macros.hs

@@ -163,6 +163,9 @@ typePType = Sort "PType"
 typeStr :: Type
 typeStr = Sort "Str"
 
+typeTok :: Type      ---- deprecated
+typeTok = Sort "Tok"  
+
 cPredef :: Ident
 cPredef = identC "Predef"
 

src/GF/Infra/CompactPrint.hs

@@ -5,7 +5,9 @@ compactPrint = compactPrintCustom keywordGF (const False)
 
 compactPrintGFCC = compactPrintCustom (const False) keywordGFCC
 
-compactPrintCustom pre post = tail . concat . map (spaceIf pre post) . words 
+compactPrintCustom pre post = dps . concat . map (spaceIf pre post) . words 
+
+dps = dropWhile isSpace
 
 spaceIf pre post w = case w of
   _ | pre w -> "\n" ++ w