Clean up a bunch of FIXMEs

src/Stack/Build/Source.hs

@@ -92,7 +92,7 @@ loadSourceMapFull needTargets boptsCli = do
               ident <- getPackageLocationIdent pkgloc
               return $ PSRemote loc (lpiFlags lpi) configOpts pkgloc ident
             PLMutable dir -> do
-              lpv <- parseSingleCabalFile True dir
+              lpv <- mkLocalPackageView True dir
               lp' <- loadLocalPackage False boptsCli targets (n, lpv)
               return $ PSFilePath lp' loc
     sourceMap' <- Map.unions <$> sequence

src/Stack/Config.hs

@@ -80,7 +80,7 @@ import           Stack.Config.Nix
 import           Stack.Config.Urls
 import           Stack.Constants
 import qualified Stack.Image as Image
-import           Stack.Package (parseSingleCabalFile)
+import           Stack.Package (mkLocalPackageView)
 import           Stack.Snapshot
 import           Stack.Types.Config
 import           Stack.Types.Docker
@@ -606,7 +606,7 @@ loadBuildConfig mproject maresolver mcompiler = do
     packages <- for (projectPackages project) $ \fp@(RelFilePath t) -> do
       abs' <- resolveDir (parent stackYamlFP) (T.unpack t)
       let resolved = ResolvedPath fp abs'
-      (resolved,) <$> runOnce (parseSingleCabalFile True resolved)
+      (resolved,) <$> runOnce (mkLocalPackageView True resolved)
 
     let deps = projectDependencies project
 

src/Stack/Package.hs

@@ -29,8 +29,7 @@ module Stack.Package
   ,PackageException (..)
   ,resolvePackageDescription
   ,packageDependencies
-  ,cabalFilePackageId
-  ,parseSingleCabalFile)
+  ,mkLocalPackageView)
   where
 
 import qualified Data.ByteString.Lazy.Char8 as CL8
@@ -49,7 +48,6 @@ import           Distribution.Package hiding (Package,PackageName,packageName,pa
 import qualified Distribution.PackageDescription as D
 import           Distribution.PackageDescription hiding (FlagName)
 import           Distribution.PackageDescription.Parsec
-import qualified Distribution.PackageDescription.Parsec as D
 import           Distribution.Simple.Utils
 import           Distribution.System (OS (..), Arch, Platform (..))
 import qualified Distribution.Text as D
@@ -1389,20 +1387,13 @@ resolveDirOrWarn :: FilePath.FilePath
 resolveDirOrWarn = resolveOrWarn "Directory" f
   where f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir
 
--- | Extract the @PackageIdentifier@ given an exploded haskell package
--- path.
-cabalFilePackageId -- FIXME remove and use the caching logic in pantry
-    :: (MonadIO m, MonadThrow m)
-    => Path Abs File -> m PackageIdentifier
-cabalFilePackageId fp = do
-    D.package . D.packageDescription <$> liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp)
-
-parseSingleCabalFile -- FIXME rename and add docs
+-- | Create a 'LocalPackageView' from a directory containing a package.
+mkLocalPackageView
   :: forall env. HasConfig env
   => Bool -- ^ print warnings?
   -> ResolvedPath Dir
-  -> RIO env LocalPackageView -- FIXME kill off LocalPackageView? It's kinda worthless, right?
-parseSingleCabalFile printWarnings dir = do
+  -> RIO env LocalPackageView
+mkLocalPackageView printWarnings dir = do
   (gpd, cabalfp) <- parseCabalFilePath (resolvedAbsolute dir) printWarnings
   return LocalPackageView
     { lpvCabalFP = cabalfp

src/Stack/SDist.hs

@@ -444,7 +444,7 @@ buildExtractedTarball pkgDir = do
         localPackage <- readLocalPackage path
         return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild)
   pathsToKeep <- filterM (fmap not . isPathToRemove . resolvedAbsolute . fst) allPackagePaths
-  getLPV <- runOnce $ parseSingleCabalFile True pkgDir
+  getLPV <- runOnce $ mkLocalPackageView True pkgDir
   newPackagesRef <- liftIO (newIORef Nothing)
   let adjustEnvForBuild env =
         let updatedEnvConfig = envConfig

src/Stack/Script.hs

@@ -26,6 +26,7 @@ import           Stack.Types.Config
 import           Stack.Types.PackageName
 import           System.FilePath            (dropExtension, replaceExtension)
 import           RIO.Process
+import qualified RIO.Text as T
 
 -- | Run a Stack Script
 scriptCmd :: ScriptOpts -> GlobalOpts -> IO ()
@@ -146,7 +147,7 @@ getPackagesFromModuleInfo mi scriptFP = do
                                 [pn] -> return $ Set.singleton pn
                                 pns' -> throwString $ concat
                                     [ "Module "
-                                    , S8.unpack $ unModuleName mn
+                                    , displayC mn
                                     , " appears in multiple packages: "
                                     , unwords $ map displayC pns'
                                     ]
@@ -247,6 +248,8 @@ parseImports =
             Nothing -> Just
                 ( Set.empty
                 , Set.singleton
-                    $ ModuleName
+                    $ fromString
+                    $ T.unpack
+                    $ decodeUtf8With lenientDecode
                     $ S8.takeWhile (\c -> c /= ' ' && c /= '(') bs3
                 )

src/Stack/Setup/Installed.hs

@@ -53,7 +53,7 @@ toolNameString (Tool ident) = displayC $ pkgName ident
 toolNameString ToolGhcjs{} = "ghcjs"
 
 parseToolText :: Text -> Maybe Tool
-parseToolText (parseCompilerVersion -> Just cv@ACGhcjs{}) = Just (ToolGhcjs cv)
+parseToolText (parseWantedCompiler -> Right (WCGhcjs x y)) = Just (ToolGhcjs (ACGhcjs x y))
 parseToolText (parsePackageIdentifier . T.unpack -> Just pkgId) = Just (Tool pkgId)
 parseToolText _ = Nothing
 

src/Stack/Sig/Sign.hs

@@ -21,10 +21,12 @@ import qualified Codec.Compression.GZip as GZip
 import           Stack.Prelude
 import qualified Data.ByteString.Lazy as BS
 import qualified Data.ByteString.Lazy as L
+import qualified Distribution.PackageDescription as D
+import qualified Distribution.PackageDescription.Parsec as D
+import qualified Distribution.Verbosity as D
 import           Network.HTTP.Download
 import           Network.HTTP.StackClient (RequestBody (RequestBodyBS), setRequestMethod, setRequestBody, getResponseStatusCode, methodPut)
 import           Path
-import           Stack.Package
 import           Stack.Sig.GPG
 import           Stack.Types.Sig
 import qualified System.FilePath as FP
@@ -106,3 +108,11 @@ signPackage url pkg filePath = do
         (throwM (GPGSignException "unable to sign & upload package"))
     logInfo ("Signature uploaded to " <> fromString fullUrl)
     return sig
+
+-- | Extract the @PackageIdentifier@ given an exploded haskell package
+-- path.
+cabalFilePackageId
+    :: (MonadIO m, MonadThrow m)
+    => Path Abs File -> m PackageIdentifier
+cabalFilePackageId fp = do
+    D.package . D.packageDescription <$> liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp)

src/Stack/Snapshot.hs

@@ -29,7 +29,6 @@ import qualified Data.Conduit.List as CL
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
-import           Data.Text.Encoding (encodeUtf8)
 import           Data.Yaml (ParseException (AesonException), decodeFileThrow)
 import           Distribution.InstalledPackageInfo (PError)
 import           Distribution.PackageDescription (GenericPackageDescription)
@@ -437,7 +436,7 @@ loadCompiler cv = do
                 , lpiFlags = Map.empty
                 , lpiGhcOptions = []
                 , lpiPackageDeps = Map.unions $ map goDep $ dpDepends dp
-                , lpiExposedModules = Set.fromList $ map (ModuleName . encodeUtf8) $ dpExposedModules dp
+                , lpiExposedModules = Set.fromList $ map (fromString . T.unpack) $ dpExposedModules dp
                 , lpiHide = not $ dpIsExposed dp
                 }
 
@@ -583,7 +582,7 @@ calculate gpd platform compilerVersion loc flags hide options =
                        $ packageDependencies pconfig pd
       , lpiExposedModules = maybe
           Set.empty
-          (Set.fromList . map fromCabalModuleName . C.exposedModules) -- FIXME remove fromCabalModuleName
+          (Set.fromList . C.exposedModules)
           (C.library pd)
       , lpiHide = hide
       }

src/Stack/Types/BuildPlan.hs

@@ -16,8 +16,7 @@ module Stack.Types.BuildPlan
     , LoadedSnapshot (..)
     , loadedSnapshotVC
     , LoadedPackageInfo (..)
-    , ModuleName (..)
-    , fromCabalModuleName
+    , C.ModuleName
     , ModuleInfo (..)
     , moduleInfoVC
     , sdSnapshots
@@ -28,9 +27,8 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import           Data.Store.Version
 import           Data.Store.VersionTagged
-import qualified Data.Text as T
-import           Data.Text.Encoding (encodeUtf8)
 import qualified Distribution.ModuleName as C
+import           Distribution.ModuleName (ModuleName)
 import qualified Distribution.Version as C
 import           Pantry
 import           Stack.Prelude
@@ -49,7 +47,7 @@ import           Stack.Types.VersionIntervals
 -- of this additional information by package name, and later in the
 -- snapshot load step we will resolve the contents of tarballs and
 -- repos, figure out package names, and assigned values appropriately.
-data SnapshotDef = SnapshotDef -- FIXME temporary
+data SnapshotDef = SnapshotDef -- To be removed as part of https://github.com/commercialhaskell/stack/issues/3922
     { sdResolver        :: !SnapshotLocation
     , sdSnapshot        :: !(Maybe (Snapshot, SnapshotDef))
     , sdWantedCompilerVersion :: !WantedCompiler
@@ -146,7 +144,7 @@ configuration. Otherwise, we don't cache.
 -}
 
 loadedSnapshotVC :: VersionConfig LoadedSnapshot
-loadedSnapshotVC = storeVersionConfig "ls-v6" "7BcCWNHwk_2JZXi8E1mTe84y0Cc="
+loadedSnapshotVC = storeVersionConfig "ls-v6" "pmaNGNwdLx9dgFqd2TiMcRhTQzQ="
 
 -- | Information on a single package for the 'LoadedSnapshot' which
 -- can be installed.
@@ -211,12 +209,6 @@ data Component = CompLibrary
 instance Store Component
 instance NFData Component
 
-newtype ModuleName = ModuleName { unModuleName :: ByteString }
-  deriving (Show, Eq, Ord, Generic, Store, NFData, Typeable, Data)
-
-fromCabalModuleName :: C.ModuleName -> ModuleName
-fromCabalModuleName = ModuleName . encodeUtf8 . T.intercalate "." . map T.pack . C.components
-
 newtype ModuleInfo = ModuleInfo
     { miModules      :: Map ModuleName (Set PackageName)
     }

src/Stack/Types/Compiler.hs

@@ -14,7 +14,6 @@ module Stack.Types.Compiler
   , compilerExeName
   , compilerVersionText
   , compilerVersionString
-  , parseCompilerVersion
   , haddockExeName
   , isWantedCompiler
   , wantedToActual
@@ -45,41 +44,28 @@ data ActualCompiler
 instance Store ActualCompiler
 instance NFData ActualCompiler
 instance Display ActualCompiler where
-    display = display . compilerVersionText
+    display (ACGhc x) = display (WCGhc x)
+    display (ACGhcjs x y) = display (WCGhcjs x y)
 instance ToJSON ActualCompiler where
     toJSON = toJSON . compilerVersionText
 instance FromJSON ActualCompiler where
-    parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t)
+    parseJSON (String t) = either (const $ fail "Failed to parse compiler version") return (parseActualCompiler t)
     parseJSON _ = fail "Invalid CompilerVersion, must be String"
 instance FromJSONKey ActualCompiler where
     fromJSONKey = FromJSONKeyTextParser $ \k ->
-        case parseCompilerVersion k of
-            Nothing -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k
-            Just parsed -> return parsed
+        case parseActualCompiler k of
+            Left _ -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k
+            Right parsed -> return parsed
 
 wantedToActual :: WantedCompiler -> ActualCompiler
 wantedToActual (WCGhc x) = ACGhc x
 wantedToActual (WCGhcjs x y) = ACGhcjs x y
 
--- FIXME remove
-parseCompilerVersion :: T.Text -> Maybe ActualCompiler
-parseCompilerVersion t
-    | Just t' <- T.stripPrefix "ghc-" t
-    , Just v <- parseVersion $ T.unpack t'
-        = Just (ACGhc v)
-    | Just t' <- T.stripPrefix "ghcjs-" t
-    , [tghcjs, tghc] <- T.splitOn "_ghc-" t'
-    , Just vghcjs <- parseVersion $ T.unpack tghcjs
-    , Just vghc <- parseVersion $ T.unpack tghc
-        = Just (ACGhcjs vghcjs vghc)
-    | otherwise
-        = Nothing
+parseActualCompiler :: T.Text -> Either PantryException ActualCompiler
+parseActualCompiler = fmap wantedToActual . parseWantedCompiler
 
-compilerVersionText :: ActualCompiler -> T.Text -- FIXME remove, should be in pantry only
-compilerVersionText (ACGhc vghc) =
-    "ghc-" <> displayC vghc
-compilerVersionText (ACGhcjs vghcjs vghc) =
-    "ghcjs-" <> displayC vghcjs <> "_ghc-" <> displayC vghc
+compilerVersionText :: ActualCompiler -> T.Text
+compilerVersionText = utf8BuilderToText . display
 
 compilerVersionString :: ActualCompiler -> String
 compilerVersionString = T.unpack . compilerVersionText

src/Stack/Types/Package.hs

@@ -229,7 +229,7 @@ type SourceMap = Map PackageName PackageSource
 data PackageSource
   = PSFilePath LocalPackage InstallLocation
   -- ^ Package which exist on the filesystem
-  | PSRemote InstallLocation (Map FlagName Bool) [Text] PackageLocationImmutable PackageIdentifier -- FIXME consider using runOnce on the PackageIdentifier
+  | PSRemote InstallLocation (Map FlagName Bool) [Text] PackageLocationImmutable PackageIdentifier
   -- ^ Package which is downloaded remotely.
     deriving Show
 

src/Stack/Types/VersionIntervals.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-module Stack.Types.VersionIntervals -- FIXME remove this module
+module Stack.Types.VersionIntervals -- to be removed with https://github.com/commercialhaskell/stack/issues/4213
   ( VersionIntervals
   , toVersionRange
   , fromVersionRange

subs/pantry/src/Pantry/Repo.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-module Pantry.Repo -- FIXME needs to be implemented!
+module Pantry.Repo
   ( fetchRepos
   , getRepo
   , getRepoKey

subs/pantry/src/Pantry/Storage.hs

@@ -58,7 +58,7 @@ import RIO
 import qualified RIO.ByteString as B
 import Pantry.Types
 import Database.Persist
-import Database.Persist.Sqlite -- FIXME allow PostgreSQL too
+import Database.Persist.Sqlite
 import Database.Persist.TH
 import RIO.Orphans ()
 import Pantry.StaticSHA256
@@ -307,8 +307,6 @@ storeHackageRevision name version key = do
     , hackageCabalTree = Nothing
     }
 
--- FIXME something to update the hackageCabalTree when we have it
-
 loadHackagePackageVersions
   :: (HasPantryConfig env, HasLogFunc env)
   => PackageName

subs/pantry/src/Pantry/Types.hs

@@ -100,6 +100,8 @@ import Distribution.Types.VersionRange (VersionRange)
 import Distribution.PackageDescription (FlagName)
 import Distribution.Types.PackageId (PackageIdentifier (..))
 import qualified Distribution.Text
+import Distribution.ModuleName (ModuleName)
+import qualified Distribution.ModuleName as ModuleName
 import Distribution.Types.Version (Version)
 import Data.Store (Size (..), Store (..)) -- FIXME remove
 import Network.HTTP.Client (parseRequest)
@@ -1286,6 +1288,14 @@ instance Store FlagName where
       VarSize f -> f (displayC fname :: String)
   peek = peek >>= maybe (fail "Invalid flag name") pure . parseFlagName
   poke fname = poke (displayC fname :: String)
+instance Store ModuleName where
+  size =
+    VarSize $ \mname ->
+    case size of
+      ConstSize x -> x
+      VarSize f -> f $ ModuleName.components mname
+  peek = ModuleName.fromComponents <$> peek
+  poke = poke . ModuleName.components
 instance Store PackageIdentifierRevision where
   size =
     VarSize $ \(PackageIdentifierRevision name version cfi) ->