cabal-install/src/Distribution/Client/Init/Utils.hs

   1 {-# LANGUAGE RecordWildCards #-}
   2
   3 module Distribution.Client.Init.Utils
   4   ( SourceFileEntry (..)
   5   , retrieveSourceFiles
   6   , retrieveModuleName
   7   , retrieveModuleImports
   8   , retrieveModuleExtensions
   9   , retrieveBuildTools
  10   , retrieveDependencies
  11   , isMain
  12   , isHaskell
  13   , isSourceFile
  14   , trim
  15   , currentDirPkgName
  16   , filePathToPkgName
  17   , mkPackageNameDep
  18   , fixupDocFiles
  19   , mkStringyDep
  20   , getBaseDep
  21   , addLibDepToExe
  22   , addLibDepToTest
  23   ) where
  24
  25 import Distribution.Client.Compat.Prelude hiding (Parsec, empty, many, putStrLn, readFile)
  26 import Distribution.Utils.Generic (isInfixOf, safeLast)
  27 import qualified Prelude ()
  28
  29 import Control.Monad (forM)
  30
  31 import qualified Data.List.NonEmpty as NE
  32 import qualified Data.Map as M
  33 import Language.Haskell.Extension (Extension (..))
  34 import System.FilePath
  35
  36 import Distribution.CabalSpecVersion (CabalSpecVersion (..))
  37 import Distribution.Client.Init.Defaults
  38 import Distribution.Client.Init.Types
  39 import Distribution.Client.Utils (pvpize)
  40 import qualified Distribution.Compat.NonEmptySet as NES
  41 import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed)
  42 import Distribution.ModuleName (ModuleName)
  43 import qualified Distribution.Package as P
  44 import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex)
  45 import Distribution.Simple.Setup (Flag (..))
  46 import Distribution.Types.Dependency (Dependency, mkDependency)
  47 import Distribution.Types.LibraryName
  48 import Distribution.Types.PackageName
  49 import Distribution.Utils.String (trim)
  50 import Distribution.Verbosity (silent)
  51 import Distribution.Version
  52
  53 -- | Data type of source files found in the working directory
  54 data SourceFileEntry = SourceFileEntry
  55   { relativeSourcePath :: FilePath
  56   , moduleName :: ModuleName
  57   , fileExtension :: String
  58   , imports :: [ModuleName]
  59   , extensions :: [Extension]
  60   }
  61   deriving (Show)
  62
  63 -- Unfortunately we cannot use the version exported by Distribution.Simple.Program
  64 knownSuffixHandlers :: CabalSpecVersion -> String -> String
  65 knownSuffixHandlers v s
  66   | v < CabalSpecV3_0 = case s of
  67       ".gc" -> "greencard"
  68       ".chs" -> "chs"
  69       ".hsc" -> "hsc2hs"
  70       ".x" -> "alex"
  71       ".y" -> "happy"
  72       ".ly" -> "happy"
  73       ".cpphs" -> "cpp"
  74       _ -> ""
  75   | otherwise = case s of
  76       ".gc" -> "greencard:greencard"
  77       ".chs" -> "chs:chs"
  78       ".hsc" -> "hsc2hs:hsc2hs"
  79       ".x" -> "alex:alex"
  80       ".y" -> "happy:happy"
  81       ".ly" -> "happy:happy"
  82       ".cpphs" -> "cpp:cpp"
  83       _ -> ""
  84
  85 -- | Check if a given file has main file characteristics
  86 isMain :: String -> Bool
  87 isMain f =
  88   (isInfixOf "Main" f || isInfixOf "main" f)
  89     && isSuffixOf ".hs" f
  90     || isSuffixOf ".lhs" f
  91
  92 -- | Check if a given file has a Haskell extension
  93 isHaskell :: String -> Bool
  94 isHaskell f = isSuffixOf ".hs" f || isSuffixOf ".lhs" f
  95
  96 isBuildTool :: CabalSpecVersion -> String -> Bool
  97 isBuildTool v = not . null . knownSuffixHandlers v . takeExtension
  98
  99 retrieveBuildTools :: Interactive m => CabalSpecVersion -> FilePath -> m [Dependency]
 100 retrieveBuildTools v fp = do
 101   exists <- doesDirectoryExist fp
 102   if exists
 103     then do
 104       files <- fmap takeExtension <$> listFilesRecursive fp
 105
 106       let tools =
 107             [ mkStringyDep (knownSuffixHandlers v f)
 108             | f <- files
 109             , isBuildTool v f
 110             ]
 111
 112       return tools
 113     else return []
 114
 115 retrieveSourceFiles :: Interactive m => FilePath -> m [SourceFileEntry]
 116 retrieveSourceFiles fp = do
 117   exists <- doesDirectoryExist fp
 118   if exists
 119     then do
 120       files <- filter isHaskell <$> listFilesRecursive fp
 121
 122       entries <- forM files $ \f -> do
 123         exists' <- doesFileExist f
 124         if exists'
 125           then do
 126             maybeModuleName <- retrieveModuleName f
 127             case maybeModuleName of
 128               Nothing -> return Nothing
 129               Just moduleName -> do
 130                 let fileExtension = takeExtension f
 131                 relativeSourcePath <- makeRelative f <$> getCurrentDirectory
 132                 imports <- retrieveModuleImports f
 133                 extensions <- retrieveModuleExtensions f
 134
 135                 return . Just $ SourceFileEntry{..}
 136           else return Nothing
 137
 138       return . catMaybes $ entries
 139     else return []
 140
 141 -- | Given a module, retrieve its name
 142 retrieveModuleName :: Interactive m => FilePath -> m (Maybe ModuleName)
 143 retrieveModuleName m = do
 144   rawModule <- trim . grabModuleName <$> readFile m
 145
 146   if isInfixOf rawModule (dirToModuleName m)
 147     then return $ Just $ fromString rawModule
 148     else do
 149       putStrLn $
 150         "Warning: found module that doesn't match directory structure: "
 151           ++ rawModule
 152       return Nothing
 153   where
 154     dirToModuleName = map (\x -> if x == '/' || x == '\\' then '.' else x)
 155
 156     stop c = (c /= '\n') && (c /= ' ')
 157
 158     grabModuleName [] = []
 159     grabModuleName ('-' : '-' : xs) = grabModuleName $ dropWhile' (/= '\n') xs
 160     grabModuleName ('m' : 'o' : 'd' : 'u' : 'l' : 'e' : ' ' : xs) = takeWhile' stop xs
 161     grabModuleName (_ : xs) = grabModuleName xs
 162
 163 -- | Given a module, retrieve all of its imports
 164 retrieveModuleImports :: Interactive m => FilePath -> m [ModuleName]
 165 retrieveModuleImports m = do
 166   map (fromString . trim) . grabModuleImports <$> readFile m
 167   where
 168     stop c = (c /= '\n') && (c /= ' ') && (c /= '(')
 169
 170     grabModuleImports [] = []
 171     grabModuleImports ('-' : '-' : xs) = grabModuleImports $ dropWhile' (/= '\n') xs
 172     grabModuleImports ('i' : 'm' : 'p' : 'o' : 'r' : 't' : ' ' : xs) = case trim xs of -- in case someone uses a weird formatting
 173       ('q' : 'u' : 'a' : 'l' : 'i' : 'f' : 'i' : 'e' : 'd' : ' ' : ys) -> takeWhile' stop ys : grabModuleImports (dropWhile' stop ys)
 174       _ -> takeWhile' stop xs : grabModuleImports (dropWhile' stop xs)
 175     grabModuleImports (_ : xs) = grabModuleImports xs
 176
 177 -- | Given a module, retrieve all of its language pragmas
 178 retrieveModuleExtensions :: Interactive m => FilePath -> m [Extension]
 179 retrieveModuleExtensions m = do
 180   catMaybes <$> map (simpleParsec . trim) . grabModuleExtensions <$> readFile m
 181   where
 182     stop c = (c /= '\n') && (c /= ' ') && (c /= ',') && (c /= '#')
 183
 184     grabModuleExtensions [] = []
 185     grabModuleExtensions ('-' : '-' : xs) = grabModuleExtensions $ dropWhile' (/= '\n') xs
 186     grabModuleExtensions ('L' : 'A' : 'N' : 'G' : 'U' : 'A' : 'G' : 'E' : xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs)
 187     grabModuleExtensions (_ : xs) = grabModuleExtensions xs
 188
 189     grabModuleExtensions' [] = []
 190     grabModuleExtensions' ('#' : xs) = grabModuleExtensions xs
 191     grabModuleExtensions' (',' : xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs)
 192     grabModuleExtensions' (_ : xs) = grabModuleExtensions xs
 193
 194 takeWhile' :: (Char -> Bool) -> String -> String
 195 takeWhile' p = takeWhile p . trim
 196
 197 dropWhile' :: (Char -> Bool) -> String -> String
 198 dropWhile' p = dropWhile p . trim
 199
 200 -- | Check whether a potential source file is located in one of the
 201 --   source directories.
 202 isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool
 203 isSourceFile Nothing sf = isSourceFile (Just ["."]) sf
 204 isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs
 205
 206 retrieveDependencies :: Interactive m => Verbosity -> InitFlags -> [(ModuleName, ModuleName)] -> InstalledPackageIndex -> m [P.Dependency]
 207 retrieveDependencies v flags mods' pkgIx = do
 208   let mods = mods'
 209
 210       modMap :: M.Map ModuleName [InstalledPackageInfo]
 211       modMap = M.map (filter exposed) $ moduleNameIndex pkgIx
 212
 213       modDeps :: [(ModuleName, ModuleName, Maybe [InstalledPackageInfo])]
 214       modDeps = map (\(mn, ds) -> (mn, ds, M.lookup ds modMap)) mods
 215   -- modDeps = map (id &&& flip M.lookup modMap) mods
 216
 217   message v Info "Guessing dependencies..."
 218   nub . catMaybes <$> traverse (chooseDep v flags) modDeps
 219
 220 -- Given a module and a list of installed packages providing it,
 221 -- choose a dependency (i.e. package + version range) to use for that
 222 -- module.
 223 chooseDep
 224   :: Interactive m
 225   => Verbosity
 226   -> InitFlags
 227   -> (ModuleName, ModuleName, Maybe [InstalledPackageInfo])
 228   -> m (Maybe P.Dependency)
 229 chooseDep v flags (importer, m, mipi) = case mipi of
 230   -- We found some packages: group them by name.
 231   Just ps@(_ : _) ->
 232     case NE.groupBy (\x y -> P.pkgName x == P.pkgName y) $ map P.packageId ps of
 233       -- if there's only one group, i.e. multiple versions of a single package,
 234       -- we make it into a dependency, choosing the latest-ish version.
 235
 236       -- Given a list of available versions of the same package, pick a dependency.
 237       [grp] -> fmap Just $ case grp of
 238         -- If only one version, easy. We change e.g. 0.4.2  into  0.4.*
 239         (pid :| []) ->
 240           return $
 241             P.Dependency
 242               (P.pkgName pid)
 243               (pvpize desugar . P.pkgVersion $ pid)
 244               P.mainLibSet -- TODO sublibraries
 245
 246         -- Otherwise, choose the latest version and issue a warning.
 247         pids -> do
 248           message v Warning ("multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.")
 249           return $
 250             P.Dependency
 251               (P.pkgName . NE.head $ pids)
 252               (pvpize desugar . maximum . fmap P.pkgVersion $ pids)
 253               P.mainLibSet -- TODO take into account sublibraries
 254
 255       -- if multiple packages are found, we refuse to choose between
 256       -- different packages and make the user do it
 257       grps -> do
 258         message v Warning ("multiple packages found providing " ++ prettyShow m ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps))
 259         message v Warning "You will need to pick one and manually add it to the build-depends field."
 260         return Nothing
 261   _ -> do
 262     message v Warning ("no package found providing " ++ prettyShow m ++ " in " ++ prettyShow importer ++ ".")
 263     return Nothing
 264   where
 265     -- desugar if cabal version lower than 2.0
 266     desugar = case cabalVersion flags of
 267       Flag x -> x < CabalSpecV2_0
 268       NoFlag -> defaultCabalVersion < CabalSpecV2_0
 269
 270 filePathToPkgName :: Interactive m => FilePath -> m P.PackageName
 271 filePathToPkgName =
 272   fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories)
 273     . canonicalizePathNoThrow
 274   where
 275     -- Treat each span of non-alphanumeric characters as a hyphen. Each
 276     -- hyphenated component of a package name must contain at least one
 277     -- alphabetic character. An arbitrary character ('x') will be prepended if
 278     -- this is not the case for the first component, and subsequent components
 279     -- will simply be run together. For example, "1+2_foo-3" will become
 280     -- "x12-foo3".
 281     repair = repair' ('x' :) id
 282     repair' invalid valid x = case dropWhile (not . isAlphaNum) x of
 283       "" -> repairComponent ""
 284       x' ->
 285         let (c, r) = first repairComponent $ span isAlphaNum x'
 286          in c ++ repairRest r
 287       where
 288         repairComponent c
 289           | all isDigit c = invalid c
 290           | otherwise = valid c
 291     repairRest = repair' id ('-' :)
 292
 293 currentDirPkgName :: Interactive m => m P.PackageName
 294 currentDirPkgName = filePathToPkgName =<< getCurrentDirectory
 295
 296 mkPackageNameDep :: PackageName -> Dependency
 297 mkPackageNameDep pkg = mkDependency pkg anyVersion (NES.singleton LMainLibName)
 298
 299 -- when cabal-version < 1.18, extra-doc-files is not supported
 300 -- so whatever the user wants as doc files should be dumped into
 301 -- extra-src-files.
 302 --
 303 fixupDocFiles :: Interactive m => Verbosity -> PkgDescription -> m PkgDescription
 304 fixupDocFiles v pkgDesc
 305   | _pkgCabalVersion pkgDesc < CabalSpecV1_18 = do
 306       message v Warning $
 307         concat
 308           [ "Cabal spec versions < 1.18 do not support extra-doc-files. "
 309           , "Doc files will be treated as extra-src-files."
 310           ]
 311
 312       return $
 313         pkgDesc
 314           { _pkgExtraSrcFiles =
 315               _pkgExtraSrcFiles pkgDesc
 316                 <> fromMaybe mempty (_pkgExtraDocFiles pkgDesc)
 317           , _pkgExtraDocFiles = Nothing
 318           }
 319   | otherwise = return pkgDesc
 320
 321 mkStringyDep :: String -> Dependency
 322 mkStringyDep = mkPackageNameDep . mkPackageName
 323
 324 getBaseDep :: Interactive m => InstalledPackageIndex -> InitFlags -> m [Dependency]
 325 getBaseDep pkgIx flags =
 326   retrieveDependencies
 327     silent
 328     flags
 329     [(fromString "Prelude", fromString "Prelude")]
 330     pkgIx
 331
 332 -- Add package name as dependency of test suite
 333 --
 334 addLibDepToTest :: PackageName -> Maybe TestTarget -> Maybe TestTarget
 335 addLibDepToTest _ Nothing = Nothing
 336 addLibDepToTest n (Just t) =
 337   Just $
 338     t
 339       { _testDependencies = _testDependencies t ++ [mkPackageNameDep n]
 340       }
 341
 342 -- Add package name as dependency of executable
 343 --
 344 addLibDepToExe :: PackageName -> ExeTarget -> ExeTarget
 345 addLibDepToExe n exe =
 346   exe
 347     { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n]
 348     }