refactoring in GF.Compile.Optimize

src/GF/Compile.hs

@@ -219,8 +219,7 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
       (k',mo3r:_) <- putpp "  refreshing " $ ioeErr $ refreshModule (k,mos) mo3
       intermOut opts DumpRefresh (ppModule Qualified mo3r)
 
-      let eenv = () --- emptyEEnv
+      mo4 <- putpp "  optimizing " $ ioeErr $ optimizeModule opts mos mo3r
-      (mo4,eenv') <- putpp "  optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
       intermOut opts DumpOptimize (ppModule Qualified mo4)
 
       return (k',mo4)

src/GF/Compile/Optimize.hs

@@ -41,51 +41,33 @@ import Debug.Trace
 
 -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
 
-type EEnv = () --- not used
+optimizeModule :: Options -> [SourceModule] -> SourceModule -> Err SourceModule
-
+optimizeModule opts ms mo@(name,mi)
--- only do this for resource: concrete is optimized in gfc form
+  | mstatus mi == MSComplete = do
-optimizeModule :: Options -> ([SourceModule],EEnv) -> SourceModule -> Err (SourceModule,EEnv)
+      mo1 <- case mtype mi of
-optimizeModule opts mse@(ms,eenv) mo@(_,mi)
+               _ | isModRes mi -> do
-  | mstatus mi == MSComplete && isModRes mi = do
+                     let deps = allOperDependencies name (jments mi)
-      (mo1,_) <- evalModule oopts mse mo
+                     ids <- topoSortOpers deps
-      let mo2 = shareModule optim mo1
+                     if OptExpand `Set.member` optim
-      return (mo2,eenv)
+                       then do mi <- foldM evalOp mi ids
-  | otherwise = evalModule oopts mse mo
+                               return (name,mi)
+                       else return mo
+               MTConcrete a -> do
+                     js' <- mapMTree (evalCncInfo oopts gr name a) (jments mi)
+                     return (name,replaceJudgements mi js')
+               _ -> return mo
+      return (shareModule optim mo1)
+  | otherwise = return mo
  where
    oopts = opts `addOptions` flagsModule mo
    optim = flag optOptimizations oopts
    
-evalModule :: Options -> ([SourceModule],EEnv) -> SourceModule -> Err (SourceModule,EEnv)
-evalModule oopts (ms,eenv) mo@(name,m0)
-  | mstatus m0 == MSComplete =
-      case mtype m0 of
-         _ | isModRes m0 -> do
-               let deps = allOperDependencies name (jments m0)
-               ids <- topoSortOpers deps
-               MGrammar (mod' : _) <- foldM evalOp gr ids
-               return $ (mod',eenv)
-
-         MTConcrete a -> do
-               js' <- mapMTree (evalCncInfo oopts gr name a) (jments m0)
-               return $ ((name,replaceJudgements m0 js'),eenv)
-
-         _ -> return $ (mo,eenv)
-  | otherwise = return $ (mo,eenv)
- where
-   gr0 = MGrammar $ ms
    gr  = MGrammar $ mo : ms
 
-   evalOp g@(MGrammar ((_,m) : _)) i = do
+   evalOp mi i = do
-     info  <- lookupTree showIdent i $ jments m
+     info  <- lookupTree showIdent i (jments mi)
      info' <- evalResInfo oopts gr (i,info)
-     return $ updateRes g name i info'
+     return (updateModule mi i info')
-
--- | update a resource module by adding a new or changing an old definition
-updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar
-updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
-  upd (n,mo)
-    | n /= m = (n,mo)
-    | n == m = (n,updateModule mo i info)
 
 -- | only operations need be compiled in a resource, and this is local to each
 -- definition since the module is traversed in topological order
@@ -94,20 +76,16 @@ evalResInfo oopts gr (c,info) = case info of
 
   ResOper pty pde -> eIn (text "operation") $ do
     pde' <- case pde of
-              Just de | optres -> liftM Just $ comp de 
+              Just de -> liftM Just $ computeConcrete gr de 
-              _                -> return pde
+              Nothing -> return Nothing
     return $ ResOper pty pde'
 
   _ ->  return info
  where
-   comp = if optres then computeConcrete gr else computeConcreteRec gr
    eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon))
-   optim = flag optOptimizations oopts
-   optres = OptExpand `Set.member` optim
 
 
-evalCncInfo :: 
+evalCncInfo :: Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err Info
-  Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err Info
 evalCncInfo opts gr cnc abs (c,info) = do
 
  (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()