Ticket #36: HaRe_20012006_ghc68.patch

StrategyLib-4.0-beta/library/MetricsTheme.hs

@@ -13 +13 @@
 module MetricsTheme where
 
 import Monad
-import Data.Monoid as Monoid
+import Data.Monoid as Monoid 
 import StrategyPrelude
 import OverloadingTheme
 import FlowTheme
@@ -21 +21 @@
 ------------------------------------------------------------------------------
 -- * An abstract datatype for metrics
 
--- | The type of metrics
-type Metrics            =  MetricName -> Integer
+-- | The type of metrics (changed to newtype to avoid overlapping)
+newtype Metrics                 =  Metrics (MetricName -> Integer)
 
 -- | The type of metric names
 type MetricName         =  String
 
 -- | Create 'Metrics' with given initial value for all metrics.
 initMetrics             :: Integer -> Metrics
-initMetrics n           =  \key -> n
+initMetrics n           =  Metrics $ \key -> n
 
 -- | Create 'Metrics' with 0 as initial value for all metrics.
 initMetrics0            :: Metrics
@@ -41 +41 @@
 
 -- | Increment metric with the given name with the given value.
 incMetrics              :: MetricName -> Integer -> Metrics -> Metrics
-incMetrics key n m      =  \key' -> let val = m key' 
+incMetrics key n (Metrics m)    =  Metrics $ \key' -> let val = m key' 
                                     in if key'==key then val+n else val
                                     
 -- | Increment metric with the given name by 1.
@@ -50 +50 @@
 
 -- | Print value of metric with the given name.
 putMetricLn             :: MetricName -> Metrics -> IO ()
-putMetricLn key m       =  putStrLn $ key++" = "++show (m key)
+putMetricLn key (Metrics m)     =  putStrLn $ key++" = "++show (m key)
 
 
 
 -- * Metrics as monoids 
 instance Monoid Metrics where
   mempty        = initMetrics0
-  mappend m1 m2 = \s -> (m1 s) + (m2 s) 
+  mappend (Metrics m1) (Metrics m2) = Metrics $ \s -> (m1 s) + (m2 s) 
 
 
 ------------------------------------------------------------------------------

StrategyLib-4.0-beta/models/drift-default/TermRep.hs

@@ -65 +65 @@
 getChildren (TermRep (_,ks,_))   = ks
 getConstr   (TermRep (_,_ ,c))   = \ks -> TermRep (c ks,ks,c)
 getTypeRep t                     = typeOf t
-hasTypeOf (TermRep (dx,_,_)) (x::t)
-  = ((fromDynamic dx)::Maybe t)
+hasTypeOf :: Typeable t => TermRep -> t -> Maybe t
+hasTypeOf (TermRep (dx,_,_)) x
+  = (fromDynamic dx)
 
 
 --- Instances for basic types and basic type constructors --------------------

diffs/tools/base/Modules/Relations.lhs

@@ -1 +1 @@
 >module Relations where
 
->#if __GLASGOW_HASKELL__ >= 604 
+#if __GLASGOW_HASKELL__ >= 604 
 >import qualified Data.Map as M
 >import qualified Data.Set as S
 
@@ -18 +18 @@
 >   add fmap (key,elt) = M.insertWith combiner key elt fmap
 
 >findWithDefault a k fm = M.findWithDefault a k fm
->#else
+#else
 >import qualified Data.FiniteMap as M
 >import qualified Sets as S
 
@@ -32 +32 @@
 >difference = S.minusSet
 >addListTo_C combiner fm key_elt_pairs = M.addListToFM_C combiner fm key_elt_pairs
 >findWithDefault a k fm = M.lookupWithDefaultFM fm  a k
->#endif 
+#endif 
 
 
 Relations

diffs/tools/base/defs/UniqueNames.hs

@@ -76 +76 @@
   ppiOp (PN i n) = ppiOp i<>n
 
 instance Printable Orig where
-  ppi (D n (N s)) = ppi (subnum n)<+>ppIfDebug ("«"<>s<>"»")
-  ppi (S p) = ppIfDebug ("«"<>p<>"»")
-  ppi (G m _ _) = ppIfDebug ("«"<>m<>"»")
-  --ppi (Sn n (SrcLoc f r c)) = "«"<>r<>","<>c<>"»"
+  ppi (D n (N s)) = ppi (subnum n)<+>ppIfDebug ("<<"<>s<>">>")
+  ppi (S p) = ppIfDebug ("<<"<>p<>">>")
+  ppi (G m _ _) = ppIfDebug ("<<"<>m<>">>")
+  --ppi (Sn n (SrcLoc f r c)) = "<<"<>r<>","<>c<>">>"
   ppi _ = empty
 
 subnum n = ppIfUnicode (subdigs (show n)) n

refactorer/EditorCommands.hs

@@ -12 +12 @@
          ,Handle
          ,stdin
          ,stderr)
-import Control.Exception as Exception
+import Control.Exception as Exception hiding (bracketOnError)
 import Foreign
 import Foreign.C
 import Network hiding (listenOn,connectTo,accept)

refactorer/PFE0.hs

@@ -176 +176 @@
           sendMsg dialog msg = lift (sendEditorMsg editorCmds dialog msg)
           sendModified f = lift (sendEditorModified editorCmds f)
       l <- catchEnv getCmd (const $ return "stop")
-      let cmdArgs@(cmd: ~(mod:_)) = words l
+      let cmdArgs@(cmd: _) = case words l of ws | null ws -> ["empty"]; ws -> ws
       sendMsg False $ "CMD:"++show cmdArgs
       unless (cmd=="stop") $ do
         if (cmd=="undo") then (undoLatestInHistory >> loop prg args) 

refactorer/RefacUnGuard.hs

@@ -191 +191 @@
 -- | Applies the transformation to a given declaration, using the auxiliary functions
 --  defined bellow
 replaceGuards d@(Dec (HsFunBind loc matches)) (_,_,mod)
-    = do let newMs1 = findConsist matches --:: [(Bool,Match)]
+    = do let newMs1 = findConsist matches -- :: [(Bool,Match)]
              initSt = getInitSt [m | (b,m) <- newMs1, b]
              newMs2 = map declsToLet' newMs1
              newMs3 = dmerge newMs2 initSt

refactorer/RefacUtils.hs

@@ -50 +50 @@
     ,findPNT,findPN      -- Try to remove this.
     ,findPNs, findEntity
     ,sameOccurrence   
-    ,defines,definesTypeSig, isTypeSigOf, 
+    ,defines,definesTypeSig, isTypeSigOf
     ,HasModName(hasModName), HasNameSpace(hasNameSpace)  
    
     
@@ -64 +64 @@
  -- * Program transformation 
     -- ** Adding
     ,addDecl ,addItemsToImport, addHiding, rmItemsFromImport, addItemsToExport
-    ,addParamsToDecls, addGuardsToRhs, addImportDecl, duplicateDecl, moveDecl,
+    ,addParamsToDecls, addGuardsToRhs, addImportDecl, duplicateDecl, moveDecl
     -- ** Rmoving
-    ,rmDecl, rmTypeSig, commentOutTypeSig, rmParams,
+    ,rmDecl, rmTypeSig, commentOutTypeSig, rmParams
     ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete)
     -- ** Updating
-    ,Update(update),
+    ,Update(update)
     ,qualifyPName,rmQualifier,renamePN,replaceNameInPN,autoRenameLocalVar
 
 -- * Miscellous
@@ -89 +89 @@
    ,mkNewName, applyRefac, applyRefacToClientMods
                    
     -- The following functions are not in the the API yet.
-    ,getDeclToks, causeNameClashInExports, inRegion , ghead, glast, gfromJust, unmodified, prettyprint,
-    getDeclAndToks
+    ,getDeclToks, causeNameClashInExports, inRegion , ghead, glast, gfromJust, unmodified, prettyprint
+    ,getDeclAndToks
  )
 where
 import Prelude hiding (putStr,putStrLn,writeFile,readFile)

refactorer/myghc--make

@@ -7 +7 @@
 
 case `uname` in
   CYGWIN*)
-    ghc --make $GHCFLAGS -cpp -ffi -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances -fno-monomorphism-restriction -package lang -package network -i${SRC_DIRS} -odir odir/$SYSTEM -hidir hidir/$SYSTEM -osuf o -hisuf hi $*
+    ghc --make $GHCFLAGS -cpp -ffi -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances -fno-monomorphism-restriction  -i${SRC_DIRS} -odir odir/$SYSTEM -hidir hidir/$SYSTEM -osuf o -hisuf hi $*
     ;;
   SunOS*)
-    ghc --make $GHCFLAGS -cpp -ffi -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances -fno-monomorphism-restriction -package lang -package network -i${SRC_DIRS} -odir odir/$SYSTEM -hidir hidir/$SYSTEM -osuf o -hisuf hi $*
+    ghc --make $GHCFLAGS -cpp -ffi -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances -fno-monomorphism-restriction  -i${SRC_DIRS} -odir odir/$SYSTEM -hidir hidir/$SYSTEM -osuf o -hisuf hi $*
     ;;
   *)
     # default case for unixish systems, confirmed for Mac OS X (10.2.6), Linux (Redhat, Mandrake)
-    ghc --make $GHCFLAGS -cpp -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances -fno-monomorphism-restriction -package lang -package network -i${SRC_DIRS} -odir odir/$SYSTEM -hidir hidir/$SYSTEM -osuf o -hisuf hi $*
+    ghc --make $GHCFLAGS -cpp -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances -fno-monomorphism-restriction  -i${SRC_DIRS} -odir odir/$SYSTEM -hidir hidir/$SYSTEM -osuf o -hisuf hi $*
     ;;
 esac
 

tools/base/Modules/Relations.lhs

@@ -1 +1 @@
 >module Relations where
 
->#if __GLASGOW_HASKELL__ >= 604 
+#if __GLASGOW_HASKELL__ >= 604 
 >import qualified Data.Map as M
 >import qualified Data.Set as S
 
@@ -18 +18 @@
 >   add fmap (key,elt) = M.insertWith combiner key elt fmap
 
 >findWithDefault a k fm = M.findWithDefault a k fm
->#else
+#else
 >import qualified Data.FiniteMap as M
 >import qualified Sets as S
 
@@ -32 +32 @@
 >difference = S.minusSet
 >addListTo_C combiner fm key_elt_pairs = M.addListToFM_C combiner fm key_elt_pairs
 >findWithDefault a k fm = M.lookupWithDefaultFM fm  a k
->#endif 
+#endif 
 
 
 Relations

tools/base/TI/OrigTiMonad.hs

@@ -10 +10 @@
    (>:),freshInt
   ) where
 import Prelude hiding (lookup) -- for Hugs
-import Monad(MonadPlus(..))
+--import Monad(MonadPlus(..))
+import Control.Monad
+import Control.Monad.Error () -- instance for Either String
 import HsIdent(HsIdentI)
 import HsName(ModuleName,Id,noModule)
 import TiTypes

tools/base/defs/UniqueNames.hs

@@ -76 +76 @@
   ppiOp (PN i n) = ppiOp i<>n
 
 instance Printable Orig where
-  ppi (D n (N s)) = ppi (subnum n)<+>ppIfDebug ("«"<>s<>"»")
-  ppi (S p) = ppIfDebug ("«"<>p<>"»")
-  ppi (G m _ _) = ppIfDebug ("«"<>m<>"»")
-  --ppi (Sn n (SrcLoc f r c)) = "«"<>r<>","<>c<>"»"
+  ppi (D n (N s)) = ppi (subnum n)<+>ppIfDebug ("<<"<>s<>">>")
+  ppi (S p) = ppIfDebug ("<<"<>p<>">>")
+  ppi (G m _ _) = ppIfDebug ("<<"<>m<>">>")
+  --ppi (Sn n (SrcLoc f r c)) = "<<"<>r<>","<>c<>">>"
   ppi _ = empty
 
 subnum n = ppIfUnicode (subdigs (show n)) n

tools/base/parse2/SourceNames.hs

@@ -57 +57 @@
 ---
 
 instance Printable   i => Printable   (SN i) where
-  ppi (SN n p) = ppi n<>ppIfDebug ("«"<>p<>"»")
-  wrap (SN n p) = wrap n<>ppIfDebug ("«"<>p<>"»")
+  ppi (SN n p) = ppi n<>ppIfDebug ("<<"<>p<>">>")
+  wrap (SN n p) = wrap n<>ppIfDebug ("<<"<>p<>">>")
 
             -- positions ends up outside parenthesis...
 
 instance PrintableOp i => PrintableOp (SN i) where
   isOp (SN n p) = isOp n
-  ppiOp (SN n p) = ppiOp n<>ppIfDebug ("«"<>p<>"»")
+  ppiOp (SN n p) = ppiOp n<>ppIfDebug ("<<"<>p<>">>")
 
 
 hsName2modName (SN hs loc) =