[remove a lot of old dead code. move Utils to FrontEnd.Utils, move around some routines that are only used in one module
John Meacham <john@repetae.net>**20051203144557] hunk ./E/FromHs.hs 39
-import Utils
+import FrontEnd.Utils
hunk ./FrontEnd/Class.hs 78
-import Utils
+import FrontEnd.Utils
hunk ./FrontEnd/Class.hs 795
+
+nameOfTyCon :: HsType -> HsName
+nameOfTyCon (HsTyCon n) = n
+nameOfTyCon (HsTyTuple xs) = toTuple (length xs)
+nameOfTyCon (HsTyFun _ _) = nameName tc_Arrow
+nameOfTyCon t = error $ "nameOfTyCon: " ++ show t
+
+groupEquations :: [HsDecl] -> [(HsName, HsDecl)]
+groupEquations [] = []
+groupEquations (d:ds) = (getDeclName d, d) : groupEquations ds
+
+
hunk ./FrontEnd/DeclsDepends.hs 21
-import Utils                    (getDeclName)
+import FrontEnd.Utils                    (getDeclName)
hunk ./FrontEnd/FrontEnd.hs 82
-
-
---modInfoDeps m = snub $ map hsImportDeclModule $ modInfoModImports m
-
-
-{-
-doTime str action = do
-    start <- getCPUTime
-    x <- action
-    end <- getCPUTime
-    putStrLn $ "Timing: " ++ str ++ " " ++ show ((end - start) `div` cpuTimePrecision)
-    return x
-
-parseHsSource :: String -> String -> IO HsModule
---parseHsSource fn s = case parse s' (SrcLoc fn 1 1) 0 [] of
-parseHsSource fn s = case runParserWithMode ParseMode { parseFilename = fn } parse  s'  of
-                      ParseOk e -> return e
-                      ParseFailed sl err -> putErrDie $ show sl ++ err
-    where
-    s' = if "shl." `isPrefixOf` reverse fn  then unlit fn s else s
-                      -- warnF fn "parse-error" err >> return emptyHsModule
-
-satisfyDeps :: [String] -> [String] -> IO [HsModule]
-satisfyDeps have [] = return []
-satisfyDeps have (n:ns) | n `elem` have = satisfyDeps have ns
-satisfyDeps have (n:ns) = do
-    let fns n = concatMap (\i -> [i ++ "/" ++ n ++ ".hs",i ++ "/" ++ n ++ ".lhs"]) (optIncdirs options)
-    (fn,fc) <- catch (msum (map (\n -> CharIO.readFile n >>= return . (,) n) (fns n))) (\_ -> putErrDie ("Module not found: " ++ n))
-    wdump FD.Progress $ do
-        putErrLn $ "Found dependency:" <+> n <+> "at" <+> fn
-    hm <- parseHsSource fn fc
-    rm <- satisfyDeps (n:have) (ns ++ hsModuleRequires hm)
-    return (hm:rm)
-
-readFiles :: [String] -> IO [HsModule]
-readFiles fs = do
-    ss <- fmap (zip fs) $ mapM CharIO.readFile fs
-    mapM (uncurry parseHsSource) ss
-
--}
-
-
-{-
-parseFiles :: [String] -> [String] -> IO ModEnv
-parseFiles fs deps = do
-    wdump FD.Progress $ do
-        putErrLn $ "Compiling " ++ show fs
-    ms <- readFiles fs
-    let mh = [(fromModule (hsModuleName hsm)) | hsm <- ms ]
-        mn = concat [ hsModuleRequires x | x <- ms ]
-    ms' <- satisfyDeps mh (mn ++ deps)
-    ms <- return $ ms ++ ms'
-    ms <- mapM modInfo ms
-    --wdump FD.Progress $ do
-    --    putErrLn $ "Determining exports and imports"
-    --mis <- determineExports ms -- (map modInfo ms)
-    --processIOErrors
---    let me = M.fromList [( (modInfoName m), m) | m <- mis ]
---        --ps = [ (fromModule (hsModuleName hsm), (if optPrelude options then ("Prelude":) else id) [fromModule (hsImportDeclModule i) | i <- hsModuleImports hsm] ) | hsm <-  ms]
---        ps = [ (modInfoName m, modInfoDeps m)  | m <- mis ]
---        nodes   = map fst ps
---        targets = concat (map snd ps)
---    unless (all (`elem` nodes) targets) $
---        putErrDie $ "Modules not found!\n" ++ show ps
---    let ps' = Scc.scc ps
---        ps'' = map (map (me M.!)) ps'
-    let mss' = stronglyConnComp [ (m,toAtom (modInfoName m), map toAtom (modInfoDeps m))  | m <- ms]
-        mss = map f mss'
-        f (AcyclicSCC x) = [x]
-        f (CyclicSCC xs) = xs
-    when (dump FD.SccModules) $ putStrLn $ "scc modules:\n" ++ unlines (map  (show . map (fromModule . modInfoName) ) mss)
-    mss <- doExports [] mss []
-    me <- foldM tiModules emptyModEnv mss
-    when (dump FD.AllKind) $
-         do {putStrLn " ---- kind information ---- \n";
-             putStr $ PPrint.render $ pprintEnvMap (modEnvKinds me)}
-    when  (dump FD.AllDcons) $
-         do {putStr " ---- data constructor assumptions ---- \n";
-             putStrLn $ PPrint.render $ pprintEnv (modEnvDConsAssumptions me)}
-    processIOErrors
-    return me
--}
-
-
-{-
-
-type Entity = Name
---exports ModInfo { modInfoHsModule = m@HsModule { hsModuleExports = Nothing } } _ =
---        case namesHsModule m of { (xs,ts) -> R.fromList $ [ ((False,n),n) | (n,_) <- xs] ++ [ ((True,n),n) | (n,_) <- ts];   }
-exports :: ModInfo -> Rel (Name) Entity -> Rel (Name) Entity
-exports mi@ModInfo { modInfoHsModule = m@HsModule { hsModuleExports = Nothing } } _ = defsToRel $ modInfoDefs mi
-exports mi is | HsModule { hsModuleExports = Just es } <- modInfoHsModule mi = mapDomain h (R.unions $ map f es) where
-    f (HsEModuleContents m) = mapDomain g unqs `R.intersection` qs where
-        (qs,unqs) = partitionDomain (isJust . getModule ) is
-        --g (x,UnQual i) = (x,Qual m i)
-        g x = Name.qualifyName m x
-    f z = entSpec False is z
-    h n = toUnqualified n
-
-imports :: ModInfo -> (Module -> Rel (Name) Entity) -> Rel (Name) Entity -> Rel (Name) Entity
-imports mi em rel = mconcatMap f is where
-    f x = rel `mappend` z where
-        z = (mapDomain (\n -> (Name.qualifyName as n)) es `mappend` if hsImportDeclQualified x then mempty else es)
-        Just as = hsImportDeclAs x `mplus` Just (hsImportDeclModule x)
-        es = em (hsImportDeclModule x)
-
-    is = modInfoModImports mi
-    --is' = hsModuleImports $ modInfoHsModule mi
-    --is = is' ++ if any ( (== Module "Prelude") . hsImportDeclModule) is' then [] else [prelude]
-    --prelude = HsImportDecl { hsImportDeclSrcLoc = bogusASrcLoc, hsImportDeclModule = Module "Prelude", hsImportDeclSpec = Nothing, hsImportDeclAs = Nothing, hsImportDeclQualified = False }
-
---mEntSpec isHiding rel es
- determineExports ::  MonadWarn m => (Map.Map Module  (Rel Name Name) ) -> [ModInfo] -> m [ModInfo]
-determineExports soFar mi = mapM g [ (m,i,o) | (i,o) <- lfp start | m <- mi] where
-    start = [(h m,mempty) |  m <- mi]
-    f xs = [ (imports m mp i, o `mappend` exports m i) | (m,i,o) <- z] where
-        z = [ (m,i,o) | m <- mi | (i,o) <- xs]
-        mp :: Module -> Rel Name Entity
-        mp m = case M.lookup m (soFar `mappend` M.fromList [ (modInfoName m,o)  | (m,_,o) <- z ]) of
-            Nothing -> error $ "Could not find Module Exports for: " ++ show m
-            Just x -> x
-    lfp x = let fx = f x in if fx == x then fx else lfp fx
-    g (m,i,o) = ce m o >>= \o' -> ci i >>= \i' -> return m { modInfoExport = o', modInfoImport = i' }
-    h m = R.fromList $  concat [ [(toUnqualified z,z),(z,z)]| (z, _, _) <- modInfoDefs m]
-    ce m x = mapM f (toRelationList x) where
-        f (x,[y]) = return y
-        f (_,[]) = error "can't happen"
-        f (x,ys) = warn bogusASrcLoc "ambiguous-export" ("module " <> fromModule (modInfoName m) <> " has ambiguous exports: " ++ show ys) >> return (head ys)
-    ci x = mapM f (toRelationList x) where
-        f (x,[]) = error "can't happen"
-        f (x,ys) = return (x,ys)
-
-hsModuleRequires x = (if optPrelude options then ("Prelude":) else id) [ fromModule $ hsImportDeclModule y | y <- hsModuleImports x]
-
-    {-
-parseFile verb mi fn = do
-    src <- readFile fn
-    moduleSyntax <- parseHsSource fn src
-    x <- tiModule (if verb then ["all"] else []) moduleSyntax mi
-    return $ x `joinModuleInfo` mi
--}
--}
-
hunk ./FrontEnd/HsErrors.hs 7
-import Class
+import Class()
hunk ./FrontEnd/KindInfer.hs 39
-import Utils
+import FrontEnd.Utils
hunk ./FrontEnd/KindInfer.hs 401
-   = nub $ namesFromContext cntxt ++ (concat [ namesFromQualType (typeFromSig s) | s <- decls,  isSigDecl s])
+   = nub $ namesFromContext cntxt ++ (concat [ namesFromQualType (typeFromSig s) | s <- decls,  isHsTypeSig s])
hunk ./FrontEnd/KindInfer.hs 403
-   = nub $ concat [ namesFromQualType (typeFromSig s) | s <- decls,  isSigDecl s]
+   = nub $ concat [ namesFromQualType (typeFromSig s) | s <- decls,  isHsTypeSig s]
hunk ./FrontEnd/KindInfer.hs 468
-   newClassBodies = map typeFromSig $ filter isSigDecl sigsAndDefaults
+   newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults
hunk ./FrontEnd/Rename.hs 87
-import Utils
+import FrontEnd.Utils
hunk ./FrontEnd/Rename.hs 1682
-{-
-printIdentTable :: IdentTable -> IO ()
-printIdentTable idt
-   = putStr $ unlines $ map showIdentTabEntry $ toListFM idt
-   where
-   showIdentTabEntry :: (HsName, (SrcLoc, Binding)) -> String
-   showIdentTabEntry (name, (SrcLoc fn row col, bind))
-      = lJustify 40 (fromHsName name) ++
-        fn ++ ":" ++ showPos (row, col) ++
-        rJustify 10 (show bind)
-   showPos pos@(row, col)
-      | row < 0 || col < 0 = rJustify 10 "none"
-      | otherwise          = rJustify 10 $ show pos
hunk ./FrontEnd/Rename.hs 1683
--- returns the binding type of a given identifier
-
-bindOfId :: IdentTable -> HsName -> Binding
-bindOfId idtab i
-   = case lookupFM idtab i of
-        Nothing -> error $ "bindOfId: could not find binding for this identifier: " ++ show i
-        Just (_sloc, bind) -> bind
-addToIdentTable :: HsName -> (SrcLoc,Binding) -> ScopeSM ()
-addToIdentTable hsName srcLocAndBinding
-   = modify (\state -> state {identTable = addToFM (identTable state) hsName srcLocAndBinding })
--}
+qualifyName :: Module -> HsName -> HsName
+qualifyName _ name@(Qual {}) = name
+qualifyName mod (UnQual name) = Qual mod name
hunk ./FrontEnd/Representation.hs 54
-import Utils
hunk ./FrontEnd/Representation.hs 193
-  pprint t = fst $ runVarName [] Utils.nameSupply $ prettyPrintTypeM t
+  pprint t = fst $ runVarName [] nameSupply $ prettyPrintTypeM t
hunk ./FrontEnd/Representation.hs 295
-     = fst $ runVarName [] Utils.nameSupply $ prettyPrintPredM pred
+     = fst $ runVarName [] nameSupply $ prettyPrintPredM pred
hunk ./FrontEnd/Representation.hs 341
-    pprint inst = fst $ runVarName [] Utils.nameSupply $ prettyPrintQualPredM inst
+    pprint inst = fst $ runVarName [] nameSupply $ prettyPrintQualPredM inst
hunk ./FrontEnd/Representation.hs 344
-    pprint inst = fst $ runVarName [] Utils.nameSupply $ prettyPrintQualTypeM inst
+    pprint inst = fst $ runVarName [] nameSupply $ prettyPrintQualTypeM inst
hunk ./FrontEnd/Representation.hs 372
-    = fst $ runVarName [] Utils.nameSupply $ prettyPrintSchemeM scheme
+    = fst $ runVarName [] nameSupply $ prettyPrintSchemeM scheme
hunk ./FrontEnd/Representation.hs 456
+-- an infinite list of alphabetic strings in the usual order
+nameSupply :: [String]
+nameSupply = [ x++[y] | x <- []:nameSupply, y <- ['a'..'z'] ]
+
+instance FromTupname HsName where
+    fromTupname (Qual (Module "Prelude") (HsIdent xs))  = fromTupname xs
+    fromTupname _ = fail "fromTupname: not Prelude"
+
+instance ToTuple HsName where
+    toTuple n = (Qual (Module "Prelude") (HsIdent $ toTuple n))
+
+-- pretty printing a HsName, Module and HsIdentifier
+
+instance DocLike d => PPrint d HsName where
+   pprint (Qual mod ident)
+      -- don't print the Prelude module qualifier
+      | mod == Module "Prelude" = pprint ident
+      | otherwise               = pprint mod <> text "." <> pprint ident
+   pprint (UnQual ident)
+      = pprint ident
+
+instance DocLike d => PPrint d Module where
+   pprint (Module s) = text s
+
+instance DocLike d => PPrint d HsIdentifier where
+   pprint (HsIdent   s) = text s
hunk ./FrontEnd/TIMain.hs 39
-import Utils                    (getDeclName,
-                                 fst3,
-                                 snd3,
-                                 trd3)
+import FrontEnd.Utils                    (getDeclName)
hunk ./FrontEnd/TIMain.hs 60
+
+fst3 :: (a,b,c) -> a
+fst3 (a,_,_) = a
+snd3 :: (a,b,c) -> b
+snd3 (_,b,_) = b
+trd3 :: (a,b,c) -> c
+trd3 (_,_,c) = c
hunk ./FrontEnd/TIModule.hs 38
-import Utils
+import FrontEnd.Utils
hunk ./FrontEnd/TIModule.hs 286
-    {-
-    let me''' =
-            addItems modEnvVarAssumptions_u (trimEnv localVarEnv) .
-            addItems modEnvDConsAssumptions_u localDConsEnv .
-            addItems modEnvAllAssumptions_u allAssumps .
-            addItems modEnvKinds_u (trimMapEnv kindInfo) .
-            modEnvTypeSynonyms_s ts . --  (++ [ d | d <- ds, isHsTypeDecl d ]) .
-            modEnvClassHierarchy_s cHierarchyWithInstances .
-            modEnvLiftedInstances_u (M.union $ M.fromList [ (getDeclName d,d) | d <- liftedInstances]) .
-            --modEnvFixities_u (++ [ d | d <- ds, isHsInfixDecl d ])
-            modEnvFixities_s fixityMap
-            $ me''
-    --let mi = ModuleInfo { varAssumps = localVarEnv, dconsAssumps = localDConsEnv,
-    --                    classHierarchy = cHierarchyWithInstances, kinds = kindInfo, infixDecls = getInfixDecls mod,
-    --                    tyconsMembers = getTyconsMembers mod, synonyms = tidyTyDecls tidyMod,
-    --                    renamedModule =  [addDecls mod liftedInstances]}
-    return me'''
hunk ./FrontEnd/TIModule.hs 287
-tiModules ::  ModEnv -> [ModInfo] -> IO ModEnv
-tiModules me ms = do
-    let importVarEnv = modEnvVarAssumptions me
-        importDConsEnv = modEnvDConsAssumptions me
-        importClassHierarchy = modEnvClassHierarchy me
-        importKindEnv = modEnvKinds me
-    wdump FD.Progress $ do
-        putErrLn $ "Typing: " ++ show ([ m | Module m <- map modInfoName ms])
-
-    let me' = modEnvModules_u (M.union (M.fromList (shwartz modInfoName ms))) me
-    ms <- mapM (processModule me') ms
-    let fixityMap = buildFixityMap (concat [ filter isHsInfixDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms]) `mappend` modEnvFixities me
-    let ts = (declsToTypeSynonyms $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])  `mappend` modEnvTypeSynonyms me
-    let f x = expandTypeSyns ts (modInfoHsModule x) >>= FrontEnd.Infix.infixHsModule fixityMap >>= \z -> return (modInfoHsModule_s ( z) x)
-    ms <- mapM f ms
-    let me'' = modEnvModules_u (M.union (M.fromList (shwartz modInfoName ms))) me'
-    let ds = concat [ hsModuleDecls $ modInfoHsModule m | m <- ms ]
-
-    wdump FD.Decls $ do
-        putStrLn "  ---- processed decls ---- "
-        putStrLn $ HsPretty.render (HsPretty.ppHsDecls ds)
-
-
-    -- kind inference for all type constructors type variables and classes in the module
-    let classAndDataDecls = filter (or' [isHsDataDecl, isHsNewTypeDecl, isHsClassDecl]) ds  -- rDataDecls ++ rNewTyDecls ++ rClassDecls
-    --print (importKindEnv, classAndDataDecls)
-
-    wdump FD.Progress $ do
-        putErrLn $ "Kind inference"
-    kindInfo <- kiDecls importKindEnv classAndDataDecls
-
-    when (dump FD.Kind) $
-         do {putStrLn " \n ---- kind information ---- \n";
-             --mapM_ (putStrLn . show) (envToList kindInfo);
-             putStr $ PPrint.render $ pprintEnvMap kindInfo}
-
-    -- collect types for data constructors
-
-    let localDConsEnv = dataConsEnv (error "modName") kindInfo classAndDataDecls -- (rDataDecls ++ rNewTyDecls)
-
-    when  (dump FD.Dcons) $
-         do {putStr "\n ---- data constructor assumptions ---- \n";
-             putStrLn $ PPrint.render $ pprintEnv localDConsEnv}
-
-
-    let globalDConsEnv = localDConsEnv `joinEnv` importDConsEnv
-
-    -- generate the class hierarchy skeleton
-
-    classHierarchy  <- foldM (flip (addClassToHierarchy kindInfo)) importClassHierarchy ds -- ds -- rClassDecls
-    cHierarchyWithInstances <- addInstancesToHierarchy kindInfo classHierarchy ds -- (rInstDecls ++ rDataDecls)
-    when (dump FD.ClassSummary) $ do
-        putStrLn "  ---- class summary ---- "
-        printClassSummary cHierarchyWithInstances
-
-    when (dump FD.Class) $
-         do {putStrLn "  ---- class hierarchy ---- ";
-             printClassHierarchy cHierarchyWithInstances}
-
-    -- lift the instance methods up to top-level decls
-
-    let cDefBinds = concat [ [ z | z <- ds] | HsClassDecl _ _ ds <- ds]
-    let myClassAssumps = concat  [ classAssumps as | as <- (classRecords cHierarchyWithInstances)]
-        --ca = listToEnv $ [ (x,y) | (x :>: y) <- myClassAssumps  ++ instAssumps ]
-        --ca' = listToEnv $ [ (x,y) | (x :>: y) <- myClassAssumps  ]
-        instanceEnv   = Map.fromList $ [ (x,y) | (x :>: y) <-  instAssumps ]
-        classDefs = snub (concatMap getDeclNames cDefBinds)
-        classEnv  = Map.fromList $ [ (x,y) | (x :>: y) <- myClassAssumps, x `elem` classDefs  ]
-        (liftedInstances,instAssumps) =  mconcatMap (instanceToTopDecls kindInfo cHierarchyWithInstances) ds -- rInstDecls
-
-
-    when (not (null liftedInstances) && (dump FD.Instance) ) $ do
-        putStrLn "  ---- lifted instance declarations ---- "
-        putStr $ unlines $ map (HsPretty.render . HsPretty.ppHsDecl) liftedInstances
-        putStrLn $ PPrint.render $ pprintEnvMap instanceEnv
-
-
-    let funPatBinds =  [ d | d <- ds, or' [isHsFunBind, isHsPatBind, isHsForeignDecl] d]
-    let rTySigs =  [ d | d <- ds, or' [isHsTypeSig] d]
-
-    -- build an environment of assumptions for all the type signatures
-    let allTypeSigs = collectSigs (funPatBinds ++ liftedInstances) ++ rTySigs
-
-    when (dump FD.Srcsigs) $
-         do {putStrLn " ---- type signatures from source code (after renaming) ---- ";
-             putStr $ unlines $ map (HsPretty.render . HsPretty.ppHsDecl) allTypeSigs}
-
-    let sigEnv = Map.unions [listSigsToSigEnv kindInfo allTypeSigs,instanceEnv, classEnv]
-    when (dump FD.Sigenv) $
-         do {putStrLn "  ---- initial sigEnv information ---- ";
-             --mapM_ (putStrLn . show) (envToList kindInfo);
-             putStrLn $ PPrint.render $ pprintEnvMap sigEnv}
-    let bindings = (funPatBinds ++ [ z | z <- cDefBinds, isHsFunBind z || isHsPatBind z] ++ liftedInstances)
-        classDefaults  = snub [ getDeclName z | z <- cDefBinds, isHsFunBind z || isHsPatBind z ]
-        classNoDefaults = snub (concat [ getDeclNames z | z <- cDefBinds ])  List.\\ classDefaults
-        noDefaultSigs = Env.fromList [ (n,Map.find n sigEnv) | n <- classNoDefaults ]
-        fakeForeignDecls = [ [HsForeignDecl bogusASrcLoc ForeignPrimitive "" x (HsUnQualType $ HsTyTuple []) ] | (x,_) <- Env.toList noDefaultSigs]
-    --when verbose2 $ putStrLn (show bindings)
-    let programBgs
-           = getBindGroups bindings getDeclName getDeclDeps
-
-    when (dump FD.Bindgroups) $
-         do {putStrLn " \n ---- toplevel variable binding groups ---- ";
-             putStrLn " ---- Bindgroup # = [members] [vars depended on] [missing vars] ---- \n";
-             putStr $ debugDeclBindGroups programBgs}
-
-    let program = makeProgram sigEnv ( fakeForeignDecls ++ programBgs )
-    when (dump FD.Program) $ do
-        putStrLn " ---- Program ---- "
-        mapM_ putStrLn $ map (PPrint.render . PPrint.pprint) $  program
-
-    -- type inference/checking for all variables
-
-    wdump FD.Progress $ do
-        putErrLn $ "Type inference"
-    let moduleName = modInfoName (head ms)
-    localVarEnv <- tiProgram
-                moduleName                     -- name of the module
-                sigEnv                         -- environment of type signatures
-                kindInfo                       -- kind information about classes and type constructors
-                cHierarchyWithInstances        -- class hierarchy with instances
-                globalDConsEnv                 -- data constructor type environment
-                (importVarEnv  )               -- type environment
-                program                        -- binding groups
-
-
-    when (dump FD.Types) $
-         do {putStrLn " ---- the types of identifiers ---- ";
-             putStrLn $ PPrint.render $ pprintEnv (if verbose2 then localVarEnv else trimEnv localVarEnv) }
-
-    localVarEnv <- return $  localVarEnv `joinFM` noDefaultSigs
-
-    let allAssumps = M.fromList $ [ (toName Name.DataConstructor x,y) | (x,y) <- Env.toList localDConsEnv ] ++ [ (toName Name.Val x,y) | (x,y) <- Env.toList localVarEnv ]
-    let me''' =
-            addItems modEnvVarAssumptions_u (trimEnv localVarEnv) .
-            addItems modEnvDConsAssumptions_u localDConsEnv .
-            addItems modEnvAllAssumptions_u allAssumps .
-            addItems modEnvKinds_u (trimMapEnv kindInfo) .
-            modEnvTypeSynonyms_s ts . --  (++ [ d | d <- ds, isHsTypeDecl d ]) .
-            modEnvClassHierarchy_s cHierarchyWithInstances .
-            modEnvLiftedInstances_u (M.union $ M.fromList [ (getDeclName d,d) | d <- liftedInstances]) .
-            --modEnvFixities_u (++ [ d | d <- ds, isHsInfixDecl d ])
-            modEnvFixities_s fixityMap
-            $ me''
-    --let mi = ModuleInfo { varAssumps = localVarEnv, dconsAssumps = localDConsEnv,
-    --                    classHierarchy = cHierarchyWithInstances, kinds = kindInfo, infixDecls = getInfixDecls mod,
-    --                    tyconsMembers = getTyconsMembers mod, synonyms = tidyTyDecls tidyMod,
-    --                    renamedModule =  [addDecls mod liftedInstances]}
-    return me'''
-
-addItems mu env = mu (mappend env)
-    -}
-
-{-
-{-# NOINLINE tiModule #-}
-tiModule dumps modSyntax imports = do
-    let importVarEnv = varAssumps imports
-        importDConsEnv = dconsAssumps imports
-        importClassHierarchy = classHierarchy imports
-        importKindEnv = kinds imports
-        importSynonyms = synonyms imports
-        importTyconMembers = tyconsMembers imports
-
-    let moduleName = hsModuleName modSyntax
-    let tidyMod = tidyModule modSyntax
-    -- make all pattern bindings simple and remove type synonyms, convert do-notation into expression form
-    let desugaredTidyModule = desugarTidyModule importSynonyms tidyMod
-    when (doDump dumps "desugar") $
-         do {putStrLn "\n\n ---- desugared code ---- \n\n";
-             putStrLn $ HsPretty.render
-                      $ HsPretty.ppHsModule
-                      $ tidyModuleToHsModule desugaredTidyModule}
-    -- uniquely rename variables and generate a table of information about identifiers
-
-        -- TODO: we probably need to worry about synonyms and
-        --       the like as well but at the moment we can live
-        --       with vars and datacons only.
-    let
-        importVarEnv' = trimEnv $ importVarEnv
-        isGlobal (Qual _ x) =  not $ isDigit $ head (hsIdentString x)
-        isGlobal _ = error "isGlobal"
-    let importedNames = getNamesFromEnv importVarEnv'
-                     ++ getNamesFromEnv importDConsEnv
-                     ++ getNamesFromTycons importTyconMembers
-                     ++ getNamesFromEnv importClassHierarchy
-                     ++ [ n | (n :>: _) <- classAssumps ]
-                     ++ getNamesFromEnv importKindEnv
-                    --  ++ getNamesFromInfix  -- shouldn't need this as we get
-                    -- them as part of getting their types in the varEnv
-        -- because we need to know to rename True to Prelude.True
-        -- as well, and this is a convenient way to do it:
-        classAssumps = concat  [ as | (_,_,as) <- (eltsFM importClassHierarchy)]
-        getNamesFromTycons :: [(HsName, [HsName])] -> [HsName]
-        getNamesFromTycons = concatMap snd
-
-    putVerbose $ show (namesHsModule (tidyModuleToHsModule desugaredTidyModule))
-    let (renamedTidyModule', errs) =  renameTidyModule importSynonyms (filter isGlobal importedNames) (filter isGlobal importedNames) (tidyModuleToHsModule desugaredTidyModule)
-        -- we pass in the imported infix decls and also the ones from the local module
-        renamedTidyModule'' = Infix.infixer (tidyInFixDecls (tidyModule renamedTidyModule') ++ infixDecls imports) (tidyModule renamedTidyModule')
-
-    let renamedTidyModule =  renamedTidyModule''
-
-    when (doDump dumps "desugar") $
-         do {putStrLn "\n\n ---- desugared code ---- \n\n";
-             putStrLn $ HsPretty.render
-                      $ HsPretty.ppHsModule
-                      $ tidyModuleToHsModule desugaredTidyModule}
-
-    -- All the names are getting qualified but they are unqualified by fromHsModule
-    processErrors errs
-
-    when (doDump dumps "renamed") $
-         do {putStrLn " \n\n ---- renamed code ---- \n\n";
-             putStrLn $ HsPretty.render
-                      $ HsPretty.ppHsModule
-                      $ tidyModuleToHsModule renamedTidyModule}
-
-
-    -- separate the renamed decls apart
-    let --rTyDecls    = tidyTyDecls    renamedTidyModule
-        rDataDecls  = tidyDataDecls  renamedTidyModule
-        rNewTyDecls = tidyNewTyDecls renamedTidyModule
-        rClassDecls = tidyClassDecls renamedTidyModule
-        rInstDecls  = tidyInstDecls  renamedTidyModule
-        rTySigs     = tidyTySigs     renamedTidyModule
-        rFunBinds   = tidyFunBinds   renamedTidyModule
-        rPatBinds   = tidyPatBinds   renamedTidyModule
-
-
-    -- collect all the type signatures from the module (this must be done after renaming)
-
-        --   = getBindGroups (rFunBinds ++ rPatBinds ++ cDefBinds ++ liftedInstances) getDeclName getDeclDeps
-
-    -- kind inference for all type constructors type variables and classes in the module
-
-    let classAndDataDecls = rDataDecls ++ rNewTyDecls ++ rClassDecls
-
-    let kindInfo = kiModule (trimEnv importKindEnv) classAndDataDecls
-
-    when (doDump dumps "kinds") $
-         do {putStrLn " \n\n ---- kind information ---- \n\n";
-             putStr $ PPrint.render $ pprintEnv kindInfo}
-
-
--- collect types for data constructors
-
-    let localDConsEnv = dataConsEnv moduleName kindInfo (rDataDecls ++ rNewTyDecls)
-
-    when (doDump dumps "dconstypes") $
-         do {putStr "\n\n ---- data constructor assumptions ---- \n\n";
-             putStrLn $ PPrint.render $ pprintEnv localDConsEnv}
-
-
-    let globalDConsEnv = localDConsEnv `joinEnv` importDConsEnv
-
--- generate the class hierarchy skeleton
-
-    let classHierarchy = foldl (flip (addClassToHierarchy moduleName kindInfo)) importClassHierarchy rClassDecls
-    let cHierarchyWithInstances
-            = addInstancesToHierarchy kindInfo classHierarchy (rInstDecls ++ rDataDecls)
-    when (doDump dumps "classes") $
-         do {putStrLn " \n\n ---- class hierarchy ---- \n\n";
-             printClassHierarchy cHierarchyWithInstances}
-
- -- lift the instance methods up to top-level decls
-
-    let myClassAssumps = concat  [ as | (_,_,as) <- (eltsFM cHierarchyWithInstances)]
-        ca = listToEnv $ [ (x,y) | (x :>: y) <- myClassAssumps  ++ instAssumps ]
-    --print ca
-        (liftedInstances,instAssumps) = unzip $ concatMap (instanceToTopDecls kindInfo cHierarchyWithInstances) rInstDecls
-
-
-    when (not (null liftedInstances) &&  doDump dumps "instances") $
-       do {putStrLn " \n\n ---- lifted instance declarations ---- \n\n";
-           putStr $ unlines $
-              map (HsPretty.render . HsPretty.ppHsDecl) liftedInstances}
-
-
--- build an environment of assumptions for all the type signatures
-    let cDefBinds = concat [ [ z | z <- ds] | HsClassDecl _ _ ds <- rClassDecls]
-    let allTypeSigs = (collectSigs (rFunBinds ++ rPatBinds {- ++ cDefBinds -} ++ liftedInstances)) ++ rTySigs
-
-    when (doDump dumps "srcsigs") $
-         do {putStrLn " \n\n ---- type signatures from source code (after renaming) ---- \n\n";
-             putStr $ unlines $ map (HsPretty.render . HsPretty.ppHsDecl) allTypeSigs}
-
-    let sigEnv = listSigsToSigEnv kindInfo allTypeSigs `joinEnv` ca
-
--- binding groups for top-level variables
-    let programBgs
-           = getBindGroups (rFunBinds ++ rPatBinds ++ [ z | z <- cDefBinds, isHsFunBind z || isHsPatBind z] ++ liftedInstances) getDeclName getDeclDeps
-
-
-    when (doDump dumps "varbindgroups") $
-         do {putStrLn " \n\n ---- toplevel variable binding groups ---- ";
-             putStrLn " ---- Bindgroup # = [members] [vars depended on] [missing vars] ---- \n";
-             putStr $ debugDeclBindGroups programBgs}
-
-    let program = makeProgram sigEnv programBgs
-
--- type inference/checking for all variables
-
-    when (doDump dumps "types") $
-         do {putStr "\n\n ---- the types of identifiers assumed... ---- \n\n";
-             putStrLn $ PPrint.render $ pprintEnv (importVarEnv' `joinEnv` ca )}
-
-
-
-
-    let localVarEnv = tiProgram
-                moduleName                     -- name of the module
-                sigEnv                         -- environment of type signatures
-                kindInfo                       -- kind information about classes and type constructors
-                cHierarchyWithInstances        -- class hierarchy with instances
-                globalDConsEnv                 -- data constructor type environment
-                (importVarEnv' `joinEnv` ca )  -- type environment
-                program                        -- binding groups
-
-
-    when (doDump dumps "types") $
-         do {putStr "\n\n ---- the types of identifiers ---- \n\n";
-             putStrLn $ PPrint.render $ pprintEnv localVarEnv}
-
-    let mod = tidyModuleToHsModule renamedTidyModule
-
-    let mi = ModuleInfo { varAssumps = localVarEnv, dconsAssumps = localDConsEnv,
-                        classHierarchy = cHierarchyWithInstances, kinds = kindInfo, infixDecls = getInfixDecls mod,
-                        tyconsMembers = getTyconsMembers mod, synonyms = tidyTyDecls tidyMod,
-                        renamedModule =  [addDecls mod liftedInstances]}
-
-    return mi
- -}
hunk ./FrontEnd/TIMonad.hs 54
-import Utils()
+import FrontEnd.Utils()
hunk ./FrontEnd/Utils.hs 1
-{-------------------------------------------------------------------------------
hunk ./FrontEnd/Utils.hs 2
-        Copyright:              The Hatchet Team (see file Contributors)
+module FrontEnd.Utils where
hunk ./FrontEnd/Utils.hs 4
-        Module:                 Utils
-
-        Description:            Generic utilities that don't have a good home
-                                anywhere else.
-
-        Primary Authors:        Bernie Pope
-
-        Notes:                  See the file License for license information
-
--------------------------------------------------------------------------------}
-
-module Utils where
-
-import HsSyn
hunk ./FrontEnd/Utils.hs 6
+import qualified Data.Map as Map
+
hunk ./FrontEnd/Utils.hs 10
-import Name.VConsts
-import Name.Names
+import HsSyn
hunk ./FrontEnd/Utils.hs 12
-import qualified Data.Map as Map
+import Name.Names
+import Name.VConsts
+import Representation()
hunk ./FrontEnd/Utils.hs 18
-
-
-instance FromTupname HsName where
-    fromTupname (Qual (Module "Prelude") (HsIdent xs))  = fromTupname xs
-    fromTupname _ = fail "fromTupname: not Prelude"
-
-instance ToTuple HsName where
-    toTuple n = (Qual (Module "Prelude") (HsIdent $ toTuple n))
-
hunk ./FrontEnd/Utils.hs 26
-maybeGetDeclName (HsClassDecl _ qualType _)
-   = case qualType of
-        HsQualType _cntxt t
-           -> return $ leftMostTyCon t
-        HsUnQualType t
-           -> return $ leftMostTyCon t
+maybeGetDeclName (HsClassDecl _ qualType _) = case qualType of
+            HsQualType _cntxt t -> return $ leftMostTyCon t
+            HsUnQualType t -> return $ leftMostTyCon t
+        where
+            leftMostTyCon (HsTyTuple ts) = toTuple (length ts)
+            leftMostTyCon (HsTyApp t1 _) = leftMostTyCon t1
+            leftMostTyCon (HsTyVar _) = error "leftMostTyCon: applied to a variable"
+            leftMostTyCon (HsTyCon n) = n
+            leftMostTyCon x = error $ "leftMostTyCon: " ++ show x
hunk ./FrontEnd/Utils.hs 43
-
---leftMostTyCon (HsTyTuple ts) = error "leftMostTyCon: applied to a tuple"
-leftMostTyCon (HsTyTuple ts) = toTuple (length ts)
-leftMostTyCon (HsTyApp t1 _) = leftMostTyCon t1
-leftMostTyCon (HsTyVar _) = error "leftMostTyCon: applied to a variable"
-leftMostTyCon (HsTyCon n) = n
-leftMostTyCon x = error $ "leftMostTyCon: " ++ show x
-
-
hunk ./FrontEnd/Utils.hs 51
-
-
-isSigDecl :: HsDecl -> Bool
-isSigDecl HsTypeSig {} = True
-isSigDecl _ = False
-
-fst3 :: (a,b,c) -> a
-fst3 (a,_,_) = a
-snd3 :: (a,b,c) -> b
-snd3 (_,b,_) = b
-trd3 :: (a,b,c) -> c
-trd3 (_,_,c) = c
-
--- an infinite list of alphabetic strings in the usual order
-nameSupply :: [String]
-nameSupply
-  = [ x++[y] | x <- []:nameSupply, y <- ['a'..'z'] ]
-
-nameOfTyCon :: HsType -> HsName
-nameOfTyCon (HsTyCon n) = n
-nameOfTyCon (HsTyTuple xs) = toTuple (length xs)
-nameOfTyCon (HsTyFun _ _) = nameName tc_Arrow
-nameOfTyCon t = error $ "nameOfTyCon: " ++ show t
-
-groupEquations :: [HsDecl] -> [(HsName, HsDecl)]
-groupEquations [] = []
-groupEquations (d:ds)
-   = (getDeclName d, d) : groupEquations ds
-
-
hunk ./FrontEnd/Utils.hs 57
-
-
-
-
-
--- module qualifies a name if it isn't already qualified
-
-qualifyName :: Module -> HsName -> HsName
-qualifyName _ name@(Qual {}) = name
-qualifyName mod (UnQual name) = Qual mod name
-
-qualifyName' :: Module -> HsName -> HsName
-qualifyName' mod (Qual _ name) = Qual mod name
-qualifyName' mod (UnQual name) = Qual mod name
-
-unqualifyName :: HsName -> HsName
-unqualifyName (Qual _ n)  = UnQual n
-unqualifyName n = n
-
--- -- The possible bindings for names
-
-
--- pretty printing a HsName, Module and HsIdentifier
-
-instance DocLike d => PPrint d HsName where
-   pprint (Qual mod ident)
-      -- don't print the Prelude module qualifier
-      | mod == Module "Prelude" = pprint ident
-      | otherwise               = pprint mod <> text "." <> pprint ident
-   pprint (UnQual ident)
-      = pprint ident
-
-instance DocLike d => PPrint d Module where
-   pprint (Module s) = text s
-
-instance DocLike d => PPrint d HsIdentifier where
-   pprint (HsIdent   s) = text s