Monadify specialise/Specialise: use do, return, standard monad functions and MonadUnique

[ghc-hetmet.git] / compiler / ndpFlatten / FlattenMonad.hs

diff --git a/compiler/ndpFlatten/FlattenMonad.hs b/compiler/ndpFlatten/FlattenMonad.hs
index 4540508..245e88d 100644 (file)
--- a/compiler/ndpFlatten/FlattenMonad.hs
+++ b/compiler/ndpFlatten/FlattenMonad.hs
@@ -40,6 +40,13 @@
 --  * One FIXME left to resolve.
 --
 
 --  * One FIXME left to resolve.
 --
 

+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+

 module FlattenMonad (
 
   -- monad definition
 module FlattenMonad (
 
   -- monad definition

@@ -75,7 +82,7 @@ import VarEnv       (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv,
                     elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList)
 import Type        (Type, tyConAppTyCon)
 import HscTypes            (HomePackageTable,
                     elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList)
 import Type        (Type, tyConAppTyCon)
 import HscTypes            (HomePackageTable,

-                    ExternalPackageState(eps_PTE), HscEnv(hsc_HPT),
+                    ExternalPackageState(eps_PTE), HscEnv(..),

                     TyThing(..), lookupType)
 import PrelNames    ( fstName, andName, orName,
                     lengthPName, replicatePName, mapPName, bpermutePName,
                     TyThing(..), lookupType)
 import PrelNames    ( fstName, andName, orName,
                     lengthPName, replicatePName, mapPName, bpermutePName,

@@ -83,6 +90,7 @@ import PrelNames    ( fstName, andName, orName,
 import TysPrim      ( charPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon )
 import PrimOp      ( PrimOp(..) )
 import PrelInfo            ( primOpId )
 import TysPrim      ( charPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon )
 import PrimOp      ( PrimOp(..) )
 import PrelInfo            ( primOpId )

+import DynFlags            (DynFlags)

 import CoreSyn      (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps)
 import CoreUtils    (exprType)
 import FastString   (FastString)
 import CoreSyn      (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps)
 import CoreUtils    (exprType)
 import FastString   (FastString)

@@ -128,11 +136,12 @@ data FlattenState = FlattenState {
 
 -- initial value of the flattening state
 --
 
 -- initial value of the flattening state
 --

-initialFlattenState :: ExternalPackageState
+initialFlattenState :: DynFlags
+                   -> ExternalPackageState

                    -> HomePackageTable 
                    -> UniqSupply 
                    -> FlattenState
                    -> HomePackageTable 
                    -> UniqSupply 
                    -> FlattenState

-initialFlattenState eps hpt us = 
+initialFlattenState dflags eps hpt us = 

   FlattenState {
     us      = us,
     env      = lookup,
   FlattenState {
     us      = us,
     env      = lookup,

@@ -142,7 +151,7 @@ initialFlattenState eps hpt us =
   }
   where
     lookup n = 
   }
   where
     lookup n = 

-      case lookupType hpt (eps_PTE eps) n of
+      case lookupType dflags hpt (eps_PTE eps) n of

         Just (AnId v) -> v 
        _             -> pprPanic "FlattenMonad: unknown name:" (ppr n)
 
         Just (AnId v) -> v 
        _             -> pprPanic "FlattenMonad: unknown name:" (ppr n)
 

@@ -167,7 +176,8 @@ runFlatten :: HscEnv
           -> Flatten a 
           -> a    
 runFlatten hsc_env eps us m 
           -> Flatten a 
           -> a    
 runFlatten hsc_env eps us m 

-  = fst $ unFlatten m (initialFlattenState eps (hsc_HPT hsc_env) us)
+  = fst $ unFlatten m (initialFlattenState (hsc_dflags hsc_env) 
+                                               eps (hsc_HPT hsc_env) us)

 
 
 -- variable generation
 
 
 -- variable generation