diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,19 @@
+Copyright (c) 2012 Roman Cheplyaka
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,72 @@
+There are two cases when you may need haskell-packages: if you are writing a
+Haskell compiler (or any tool that processes Haskell source code, such as a
+static analyzer), or if you want to integrate with an existing Haskell compiler
+that uses haskell-packages.
+
+## Writing a compiler
+
+If you are writing a compiler, you typically want to integrate it with Cabal, to
+be able to build ordinary Haskell packages.
+
+If you go the hard way, this involves:
+
+1. **Parsing command line parameters**. Sounds easy — just take a list of files to
+ compile. In reality you also need to handle package ids and package dbs, CPP
+ options (`-DFOO=1`), language extension flags (`-XRankNTypes`) etc.
+
+ To integrate with Cabal, you also need to tell it the list of installed
+ packages, supported languages and extensions etc.
+
+2. Actual **integration with Cabal** means understanding how Cabal works and
+ hard-coding support for your compiler. And then getting it accepted and
+ waiting for the next Cabal release.
+
+ You may pretend that you are GHC or other compiler that is already supported
+ by Cabal. It might work, but often it won't, for various reasons. Also,
+ GHC's command line protocol is quite complex.
+
+3. **Package management**. You need to implement a package db mechanism, which would
+ let you to keep track of installed packages. Then you'd have to implement a
+ `ghc-pkg`-like tool to manage those databases, for both Cabal and your users.
+
+**Or**, you can simply use this library!
+
+It already has command line options parsing, Cabal support, and package
+management. All you need to do is to provide the function to do actual
+compilation and tell a couple of other things about your compiler. See
+the `Distribution.HaskellSuite.Compiler` module for details.
+
+## Using other compilers
+
+Some compilers produce artifacts that you may want to use. A good example is the
+`gen-iface` compiler from haskell-names which generates an *interface* for each
+module — the set of all named entities (functions, types, classes) that are
+exported by that module. This information can be then used either by other
+compilers, or by tools like IDEs.
+
+Assuming the compiler uses haskell-packages and exports its database type, it's
+very easy to use its artifacts. See `Distribution.HaskellSuite.Packages` for
+package resolution and `Distribution.HaskellSuite.Modules` for module
+resolution.
+
+## Installation
+
+Note that haskell-packages uses (yet unreleased) haskell-src-exts 1.14. Get it
+[here][hse].
+
+It doesn't matter what Cabal version you use together with haskell-packages, but
+if you want to invoke a haskell-packages compiler from Cabal (see
+[Usage](#usage)), you need to build our [fork of Cabal][Cabal]. Eventually it
+will be merged into Cabal.
+
+[hse]: https://github.com/haskell-suite/haskell-src-exts
+[Cabal]: https://github.com/feuerbach/Cabal
+
+## Usage
+
+To compile a Haskell package using a haskell-packages tool:
+
+ cabal install --haskell-suite -w $TOOL
+
+where `$TOOL` may be either a full path to the compiler, or just an executable
+name if it's in `$PATH`.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/haskell-packages.cabal b/haskell-packages.cabal
new file mode 100644
--- /dev/null
+++ b/haskell-packages.cabal
@@ -0,0 +1,56 @@
+-- Initial haskell-packages.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: haskell-packages
+version: 0.1
+synopsis: Haskell suite library for package management and integration with Cabal
+description: See
+license: MIT
+license-file: LICENSE
+author: Roman Cheplyaka
+maintainer: Roman Cheplyaka
+copyright: (c) Roman Cheplyaka 2012
+category: Distribution
+homepage: http://haskell-suite.github.io/haskell-packages/
+bug-reports: https://github.com/haskell-suite/haskell-packages/issues
+build-type: Simple
+cabal-version: >=1.10
+extra-source-files:
+ README.md
+
+source-repository head
+ type: git
+ location: git://github.com/haskell-suite/haskell-packages.git
+
+source-repository this
+ type: git
+ location: git://github.com/haskell-suite/haskell-packages.git
+ tag: v0.1
+
+library
+ default-language: Haskell2010
+ Hs-source-dirs:
+ src
+ exposed-modules:
+ Distribution.HaskellSuite
+ Distribution.HaskellSuite.Compiler
+ Distribution.HaskellSuite.Packages
+ Distribution.HaskellSuite.Modules
+ other-modules:
+ Distribution.HaskellSuite.Cabal
+ Paths_haskell_packages
+ build-depends:
+ base >=4.5 && < 5
+ , optparse-applicative >= 0.5.1
+ , aeson == 0.6.*
+ , bytestring >=0.9
+ , Cabal >= 1.16
+ , deepseq
+ , directory
+ , filepath
+ , containers
+ , mtl
+ , hse-cpp
+ , EitherT
+ , haskell-src-exts >= 1.14
+ , tagged
diff --git a/src/Distribution/HaskellSuite.hs b/src/Distribution/HaskellSuite.hs
new file mode 100644
--- /dev/null
+++ b/src/Distribution/HaskellSuite.hs
@@ -0,0 +1,16 @@
+-- | This module re-exports all you need in order to /read/ package
+-- databases and module info files created by compilers that use
+-- haskell-packages.
+--
+-- If you are writing a compiler, i.e. a program that creates or writes
+-- package databases or module info files — then take a look at
+-- "Distribution.HaskellSuite.Compiler". It provides command-line
+-- options handling and Cabal integration.
+module Distribution.HaskellSuite
+ ( module Distribution.HaskellSuite.Packages
+ , module Distribution.HaskellSuite.Modules
+ )
+ where
+
+import Distribution.HaskellSuite.Packages
+import Distribution.HaskellSuite.Modules
diff --git a/src/Distribution/HaskellSuite/Cabal.hs b/src/Distribution/HaskellSuite/Cabal.hs
new file mode 100644
--- /dev/null
+++ b/src/Distribution/HaskellSuite/Cabal.hs
@@ -0,0 +1,213 @@
+-- | This module provides Cabal integration.
+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
+
+module Distribution.HaskellSuite.Cabal
+ ( main )
+ where
+
+import Data.Typeable
+import Data.Version
+import Data.List
+import Data.Monoid
+import Data.Proxy
+import Distribution.Simple.Compiler
+import Distribution.InstalledPackageInfo
+ ( showInstalledPackageInfo
+ , parseInstalledPackageInfo )
+import Distribution.ParseUtils
+import Distribution.Package
+import Distribution.Text
+import Distribution.ModuleName hiding (main)
+import Options.Applicative
+import Control.Monad
+import Control.Monad.Trans.Either
+import Control.Exception
+import Text.Printf
+import qualified Distribution.HaskellSuite.Compiler as Compiler
+import Distribution.HaskellSuite.Packages
+import Language.Haskell.Exts.Extension
+import Paths_haskell_packages as Our (version)
+import System.FilePath
+import System.Directory
+
+-- It is actually important that we import 'defaultCpphsOptions' from
+-- hse-cpp and not from cpphs, because they are different. hse-cpp version
+-- provides the defaults more compatible with haskell-src-exts.
+import Language.Haskell.Exts.Annotated.CPP
+
+main
+ :: forall c . Compiler.Is c
+ => c -> IO ()
+main t =
+ join $ customExecParser (prefs noBacktrack) $ info (helper <*> optParser) idm
+ where
+
+ optParser =
+ foldr (<|>) empty
+ [ version
+ , compilerVersion
+ , hspkgVersion
+ , supportedLanguages
+ , supportedExtensions
+ , subparser $ pkgCommand <> compilerCommand
+ ]
+
+ versionStr = showVersion $ Compiler.version t
+ ourVersionStr = showVersion Our.version
+
+ compilerVersion =
+ flag'
+ (printf "%s %s\n" (Compiler.name t) versionStr)
+ (long "compiler-version")
+
+ hspkgVersion =
+ flag'
+ (putStrLn ourVersionStr)
+ (long "hspkg-version")
+
+ supportedLanguages =
+ flag'
+ (mapM_ (putStrLn . prettyLanguage) $ Compiler.languages t)
+ (long "supported-languages")
+
+ supportedExtensions =
+ flag'
+ (mapM_ (putStrLn . prettyExtension) $ Compiler.languageExtensions t)
+ (long "supported-extensions")
+
+ version =
+ flag'
+ (printf "%s %s\nBased on haskell-packages version %s\n" (Compiler.name t) versionStr ourVersionStr)
+ (long "version")
+
+ pkgCommand =
+ command "pkg" (info (subparser pkgSubcommands) idm)
+ pkgSubcommands =
+ mconcat
+ [ pkgDump
+ , pkgInstallLib
+ , pkgUpdate
+ , pkgUnregister
+ , pkgList
+ , pkgInit
+ ]
+
+ pkgDump = command "dump" $ info (doDump <$> pkgDbStackParser) idm
+ where
+ doDump dbs = do
+ pkgs <-
+ fmap concat $
+ forM dbs $ \db ->
+ getInstalledPackages
+ (Proxy :: Proxy (Compiler.DB c))
+ db
+ putStr $ intercalate "---\n" $ map showInstalledPackageInfo pkgs
+
+ pkgInstallLib = command "install-library" $ flip info idm $
+ Compiler.installLib t <$>
+ (strOption (long "build-dir" <> metavar "PATH")) <*>
+ (strOption (long "target-dir" <> metavar "PATH")) <*>
+ (optional $ strOption (long "dynlib-target-dir" <> metavar "PATH")) <*>
+ (nullOption (long "package-id" <> metavar "ID" <> reader parsePackageId)) <*>
+ (arguments simpleParse (metavar "MODULE"))
+ where
+ parsePackageId str =
+ maybe
+ (Left . ErrorMsg $ "could not parse package-id: " ++ str)
+ Right
+ (simpleParse str)
+
+ pkgUpdate =
+ command "update" $ flip info idm $
+ doRegister <$> pkgDbParser
+
+ doRegister d = do
+ pi <- parseInstalledPackageInfo <$> getContents
+ case pi of
+ ParseOk _ a -> Compiler.register t d a
+ ParseFailed e -> putStrLn $ snd $ locatedErrorMsg e
+
+ pkgUnregister =
+ command "unregister" $ flip info idm $
+ Compiler.unregister t <$> pkgDbParser <*> pkgIdParser
+
+ pkgInit =
+ command "init" $ flip info idm $
+ initDB <$> argument str (metavar "PATH")
+
+ pkgList =
+ command "list" $ flip info idm $
+ Compiler.list t <$> pkgDbParser
+
+ compilerCommand =
+ command "compile" (info compiler idm)
+ compiler =
+ (\srcDirs buildDir lang exts cppOpts dbStack pkgids mods ->
+ Compiler.compile t buildDir lang exts cppOpts dbStack pkgids =<< findModules srcDirs mods) <$>
+ (many $ strOption (short 'i' <> metavar "PATH")) <*>
+ (strOption (long "build-dir" <> metavar "PATH") <|> pure ".") <*>
+ (optional $ classifyLanguage <$> strOption (short 'G' <> metavar "language")) <*>
+ (many $ parseExtension <$> strOption (short 'X' <> metavar "extension")) <*>
+ cppOptsParser <*>
+ pkgDbStackParser <*>
+ (many $ InstalledPackageId <$> strOption (long "package-id")) <*>
+ arguments str (metavar "MODULE")
+
+data ModuleNotFound = ModuleNotFound String
+ deriving Typeable
+
+instance Show ModuleNotFound where
+ show (ModuleNotFound mod) = printf "Module %s not found" mod
+instance Exception ModuleNotFound
+
+findModules srcDirs = mapM (findModule srcDirs)
+findModule srcDirs mod = do
+ r <- runEitherT $ sequence_ (checkInDir <$> srcDirs <*> exts)
+ case r of
+ Left found -> return found
+ Right {} -> throwIO $ ModuleNotFound mod
+
+ where
+ exts = ["hs", "lhs"]
+
+ checkInDir dir ext = EitherT $ do
+ let file = dir toFilePath (fromString mod) <.> ext
+ found <- doesFileExist file
+ return $ if found
+ then Left file
+ else Right ()
+
+pkgDbParser :: Parser PackageDB
+pkgDbParser =
+ flag' GlobalPackageDB (long "global") <|>
+ flag' UserPackageDB (long "user") <|>
+ (SpecificPackageDB <$> strOption (long "package-db" <> metavar "PATH"))
+
+pkgIdParser :: Parser PackageId
+pkgIdParser =
+ argument simpleParse (metavar "PACKAGE")
+
+pkgDbStackParser :: Parser PackageDBStack
+pkgDbStackParser =
+ (\fs -> if null fs then [GlobalPackageDB] else fs) <$>
+ many pkgDbParser
+
+cppOptsParser :: Parser CpphsOptions
+cppOptsParser = appEndo <$> allMod <*> pure defaultCpphsOptions
+ where
+ allMod = fmap mconcat $ many $ define <|> includeDir
+
+ define =
+ flip fmap (strOption (short 'D' <> metavar "sym[=var]")) $
+ \str ->
+ let
+ def :: (String, String)
+ def =
+ case span (/= '=') str of
+ (_, []) -> (str, "")
+ (sym, _:var) -> (sym, var)
+ in Endo $ \opts -> opts { defines = def : defines opts }
+
+ includeDir =
+ flip fmap (strOption (short 'I' <> metavar "PATH")) $
+ \str -> Endo $ \opts -> opts { includes = str : includes opts }
diff --git a/src/Distribution/HaskellSuite/Cabal.hs-boot b/src/Distribution/HaskellSuite/Cabal.hs-boot
new file mode 100644
--- /dev/null
+++ b/src/Distribution/HaskellSuite/Cabal.hs-boot
@@ -0,0 +1,7 @@
+module Distribution.HaskellSuite.Cabal where
+
+import {-# SOURCE #-} qualified Distribution.HaskellSuite.Compiler as Compiler
+
+main
+ :: Compiler.Is c
+ => c -> IO ()
diff --git a/src/Distribution/HaskellSuite/Compiler.hs b/src/Distribution/HaskellSuite/Compiler.hs
new file mode 100644
--- /dev/null
+++ b/src/Distribution/HaskellSuite/Compiler.hs
@@ -0,0 +1,197 @@
+{-# LANGUAGE TypeFamilies, FlexibleContexts, ScopedTypeVariables #-}
+-- | This module is designed to be imported qualified:
+--
+-- >import qualified Distribution.HaskellSuite.Compiler as Compiler
+module Distribution.HaskellSuite.Compiler
+ (
+ -- * Compiler description
+ Is(..)
+ , CompileFn
+
+ -- * Simple compiler
+ , Simple
+ , simple
+
+ -- * Command line
+ -- | Compiler's entry point.
+ --
+ -- It parses command line options (that are typically passed by Cabal) and
+ -- invokes the appropriate compiler's methods.
+ , main
+ )
+ where
+
+import Data.Version
+import Distribution.HaskellSuite.Packages
+import {-# SOURCE #-} Distribution.HaskellSuite.Cabal
+import Distribution.Simple.Compiler
+import Distribution.Simple.Utils
+import Distribution.Verbosity
+import Distribution.InstalledPackageInfo
+import Distribution.Package
+import Distribution.Text
+import Distribution.ModuleName (ModuleName)
+import Control.Monad
+import Control.Exception
+import Data.Maybe
+import Data.List
+import Data.Function
+import Language.Haskell.Exts.Annotated.CPP
+import Language.Haskell.Exts.Extension
+
+-- | Compilation function
+type CompileFn
+ = FilePath
+ -> Maybe Language
+ -> [Extension]
+ -> CpphsOptions
+ -> PackageDBStack
+ -> [InstalledPackageId]
+ -> [FilePath]
+ -> IO ()
+
+-- | An abstraction over a Haskell compiler.
+--
+-- Once you've written a @Compiler.@'Is' instance, you get Cabal
+-- integration for free (via @Compiler@.'main').
+--
+-- Consider whether @Compiler.@'Simple' suits your needs — then you need to
+-- write even less code.
+--
+-- Minimal definition: 'DB', 'name', 'version', 'fileExtensions',
+-- 'compile', 'languages', 'languageExtensions'.
+--
+-- 'fileExtensions' are only used for 'installLib', so if you define
+-- a custom 'installLib', 'fileExtensions' won't be used (but you'll still
+-- get a compiler warning if you do not define it).
+class IsPackageDB (DB compiler) => Is compiler where
+
+ -- | The database type used by the compiler
+ type DB compiler
+
+ -- | Compiler's name. Should not contain spaces.
+ name :: compiler -> String
+ -- | Compiler's version
+ version :: compiler -> Version
+ -- | File extensions of the files generated by the compiler. Those files
+ -- will be copied during the install phase.
+ fileExtensions :: compiler -> [String]
+ -- | How to compile a set of modules
+ compile :: compiler -> CompileFn
+ -- | Languages supported by this compiler (such as @Haskell98@,
+ -- @Haskell2010@ etc.)
+ languages :: compiler -> [Language]
+ -- | Extensions supported by this compiler
+ languageExtensions :: compiler -> [Extension]
+
+ installLib
+ :: compiler
+ -> FilePath -- ^ build dir
+ -> FilePath -- ^ target dir
+ -> Maybe FilePath -- ^ target dir for dynamic libraries
+ -> PackageIdentifier
+ -> [ModuleName]
+ -> IO ()
+ installLib t buildDir targetDir _dynlibTargetDir _pkg mods =
+ findModuleFiles [buildDir] (fileExtensions t) mods
+ >>= installOrdinaryFiles normal targetDir
+
+ -- | Register the package in the database. If a package with the same id
+ -- is already installed, it should be replaced by the new one.
+ register
+ :: compiler
+ -> PackageDB
+ -> InstalledPackageInfo
+ -> IO ()
+ register t dbspec pkg = do
+ mbDb <- locateDB dbspec
+
+ case mbDb :: Maybe (DB compiler) of
+ Nothing -> throwIO RegisterNullDB
+ Just db -> do
+ pkgs <- readPackageDB (maybeInitDB dbspec) db
+ let pkgid = installedPackageId pkg
+ writePackageDB db $ pkg : removePackage pkgid pkgs
+
+ -- | Unregister the package
+ unregister
+ :: compiler
+ -> PackageDB
+ -> PackageId
+ -> IO ()
+ unregister t dbspec pkg = do
+ let
+ pkgCriterion =
+ -- if the version is not specified, treat it as a wildcard
+ (case pkgVersion $ packageId pkg of
+ Version [] _ ->
+ ((==) `on` pkgName) pkg
+ _ ->
+ (==) pkg)
+ . sourcePackageId
+
+ mbDb <- locateDB dbspec
+
+ case mbDb :: Maybe (DB compiler) of
+ Nothing -> throwIO RegisterNullDB
+ Just db -> do
+ pkgs <- readPackageDB (maybeInitDB dbspec) db
+
+ let
+ (packagesRemoved, packagesLeft) = partition pkgCriterion pkgs
+
+ if null packagesRemoved
+ then
+ putStrLn $ "No packages removed"
+ else do
+ putStrLn "Packages removed:"
+ forM_ packagesRemoved $ \p ->
+ putStrLn $ " " ++ display (installedPackageId p)
+
+ writePackageDB db packagesLeft
+
+ list
+ :: compiler
+ -> PackageDB
+ -> IO ()
+ list t dbspec = do
+ mbDb <- locateDB dbspec
+
+ case mbDb :: Maybe (DB compiler) of
+ Nothing -> return ()
+ Just db -> do
+ pkgs <- readPackageDB (maybeInitDB dbspec) db
+
+ forM_ pkgs $ putStrLn . display . installedPackageId
+
+removePackage :: InstalledPackageId -> Packages -> Packages
+removePackage pkgid = filter ((pkgid /=) . installedPackageId)
+
+data Simple db = Simple
+ { stName :: String
+ , stVer :: Version
+ , stLangs :: [Language]
+ , stLangExts :: [Extension]
+ , stCompile :: CompileFn
+ , stExts :: [String]
+ }
+
+simple
+ :: String -- ^ compiler name
+ -> Version -- ^ compiler version
+ -> [Language]
+ -> [Extension]
+ -> CompileFn
+ -> [String] -- ^ extensions that generated file have
+ -> Simple db
+simple = Simple
+
+instance IsPackageDB db => Is (Simple db) where
+ type DB (Simple db) = db
+
+ name = stName
+ version = stVer
+ fileExtensions = stExts
+ compile = stCompile
+ languages = stLangs
+ languageExtensions = stLangExts
diff --git a/src/Distribution/HaskellSuite/Compiler.hs-boot b/src/Distribution/HaskellSuite/Compiler.hs-boot
new file mode 100644
--- /dev/null
+++ b/src/Distribution/HaskellSuite/Compiler.hs-boot
@@ -0,0 +1,3 @@
+module Distribution.HaskellSuite.Compiler where
+
+class Is compiler
diff --git a/src/Distribution/HaskellSuite/Modules.hs b/src/Distribution/HaskellSuite/Modules.hs
new file mode 100644
--- /dev/null
+++ b/src/Distribution/HaskellSuite/Modules.hs
@@ -0,0 +1,162 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies,
+ FlexibleInstances, TypeSynonymInstances,
+ DeriveDataTypeable #-}
+module Distribution.HaskellSuite.Modules
+ (
+ -- * Module monad
+ -- | When you need to resolve modules, you work in a 'ModuleT' monad (or
+ -- another monad that is an instance of 'MonadModule') and use the
+ -- 'getModuleInfo' function.
+ --
+ -- It finds an installed module by its name and reads (and caches) its
+ -- info from the info file. Then you run a 'ModuleT' monadic action
+ -- using 'evalModuleT' or 'runModuleT'.
+ --
+ -- To run a 'ModuleT' action you'll also need to provide the set of
+ -- packages (represented by their 'InstalledPackageInfo') in which to
+ -- search for modules. You can get such a set from either
+ -- 'getInstalledPackages' or 'readPackagesInfo', depending on your use
+ -- case.
+ ModuleT
+ , getModuleInfo
+ , evalModuleT
+ , runModuleT
+ , MonadModule(..)
+ -- * Module names
+ , ModName(..)
+ , convertModuleName
+ ) where
+
+import Distribution.HaskellSuite.Packages
+import Distribution.Simple.Compiler
+import Distribution.Simple.Utils
+import Distribution.InstalledPackageInfo
+import Distribution.Package
+import Distribution.Text
+import Distribution.ModuleName
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Reader
+import Control.Exception
+import Data.List
+import Data.Typeable
+import Data.Proxy
+import qualified Data.Map as Map
+import Text.Printf
+import System.FilePath
+
+-- | This class defines the interface that is used by 'getModuleInfo', so
+-- that you can use it in monads other than 'ModuleT'.
+--
+-- You don't typically have to define your own instances of this class, but
+-- here are a couple of cases when you might:
+--
+-- * A pure (non-'MonadIO') mockup module monad for testing purposes
+--
+-- * A transformer over 'ModuleT'
+--
+-- * You need a more complex way to retrieve the module info
+class Monad m => MonadModule m where
+ -- | The type of module info
+ type ModuleInfo m
+ lookupInCache :: ModName n => n -> m (Maybe (ModuleInfo m))
+ insertInCache :: ModName n => n -> ModuleInfo m -> m ()
+ getPackages :: m Packages
+
+ -- | Read the module info, given a list of search paths and the module
+ -- name
+ readModuleInfo :: ModName n => [FilePath] -> n -> m (ModuleInfo m)
+
+-- | Different libraries (Cabal, haskell-src-exts, ...) use different types
+-- to represent module names. Hence this class.
+class ModName n where
+ modToString :: n -> String
+
+instance ModName String where
+ modToString = id
+
+instance ModName ModuleName where
+ modToString = display
+
+-- | Convert module name from arbitrary representation to Cabal's one
+convertModuleName :: (ModName n) => n -> ModuleName
+convertModuleName = fromString . modToString
+
+-- | Tries to find the module in the current set of packages, then find the
+-- module's info file, and reads and caches its contents.
+--
+-- Returns 'Nothing' if the module could not be found in the current set of
+-- packages. If the module is found, but something else goes wrong (e.g.
+-- there's no info file for it), an exception is thrown.
+getModuleInfo :: (MonadModule m, ModName n) => n -> m (Maybe (ModuleInfo m))
+getModuleInfo name = do
+ cached <- lookupInCache name
+ case cached of
+ Just i -> return $ Just i
+ Nothing -> do
+ pkgs <- getPackages
+ case findModule'sPackage pkgs name of
+ Nothing -> return Nothing
+ Just pkg -> do
+ i <- readModuleInfo (libraryDirs pkg) name
+ insertInCache name i
+ return $ Just i
+
+findModule'sPackage :: ModName n => Packages -> n -> Maybe InstalledPackageInfo
+findModule'sPackage pkgs m = find ((convertModuleName m `elem`) . exposedModules) pkgs
+
+-- | A standard module monad transformer.
+--
+-- @i@ is the type of module info, @m@ is the underlying monad.
+newtype ModuleT i m a =
+ ModuleT
+ (StateT (Map.Map ModuleName i)
+ (ReaderT (Packages, [FilePath] -> ModuleName -> m i) m)
+ a)
+ deriving (Functor, Applicative, Monad)
+
+instance MonadTrans (ModuleT i) where
+ lift = ModuleT . lift . lift
+
+instance MonadIO m => MonadIO (ModuleT i m) where
+ liftIO = ModuleT . liftIO
+
+instance (Functor m, Monad m) => MonadModule (ModuleT i m) where
+ type ModuleInfo (ModuleT i m) = i
+ lookupInCache n = ModuleT $ Map.lookup (convertModuleName n) <$> get
+ insertInCache n i = ModuleT $ modify $ Map.insert (convertModuleName n) i
+ getPackages = ModuleT $ asks fst
+ readModuleInfo dirs mod =
+ lift =<< ModuleT (asks snd) <*> pure dirs <*> pure (convertModuleName mod)
+
+-- | Run a 'ModuleT' action
+runModuleT
+ :: MonadIO m
+ => ModuleT i m a -- ^ the monadic action to run
+ -> Packages -- ^ packages in which to look for modules
+ -> String -- ^ file extension of info files
+ -> (FilePath -> m i) -- ^ how to read information from an info file
+ -> Map.Map ModuleName i -- ^ initial set of module infos
+ -> m (a, Map.Map ModuleName i)
+ -- ^ return value, plus all cached module infos (that is, the initial set
+ -- plus all infos that have been read by the action itself)
+runModuleT (ModuleT a) pkgs suffix readInfo modMap =
+ runReaderT (runStateT a modMap) (pkgs, findAndReadInfo)
+ where
+ findAndReadInfo dirs name = do
+ (base, rel) <- liftIO $ findModuleFile dirs [suffix] name
+ readInfo $ base rel
+
+-- | Run a 'ModuleT' action.
+--
+-- This is a simplified version of 'runModuleT'.
+evalModuleT
+ :: MonadIO m
+ => ModuleT i m a -- ^ the monadic action to run
+ -> Packages -- ^ packages in which to look for modules
+ -> String -- ^ file extension of info files
+ -> (FilePath -> m i) -- ^ how to read information from an info file
+ -> m a
+evalModuleT a pkgs suffix readInfo =
+ fst `liftM` runModuleT a pkgs suffix readInfo Map.empty
diff --git a/src/Distribution/HaskellSuite/Packages.hs b/src/Distribution/HaskellSuite/Packages.hs
new file mode 100644
--- /dev/null
+++ b/src/Distribution/HaskellSuite/Packages.hs
@@ -0,0 +1,372 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable,
+ TemplateHaskell, ScopedTypeVariables, OverloadedStrings #-}
+module Distribution.HaskellSuite.Packages
+ (
+ -- * Querying package databases
+ -- | 'getInstalledPackages' and 'readPackagesInfo' can be used to get
+ -- package information from package databases.
+ --
+ -- They use the 'IsPackageDB' interface, so that you can use them with
+ -- your own, custom databases.
+ --
+ -- Use 'getInstalledPackages' to get all packages defined in a particular
+ -- database, and 'readPackagesInfo' when you're searching for
+ -- a particular set of packages in a set of databases.
+ Packages
+ , getInstalledPackages
+ , readPackagesInfo
+ -- * IsPackageDB class and friends
+ , IsPackageDB(..)
+ , MaybeInitDB(..)
+ , maybeInitDB
+ -- * StandardDB
+ -- | 'StandardDB' is a simple `IsPackageDB` implementation which cover many
+ -- (but not all) use cases. Please see the source code to see what
+ -- assumptions it makes and whether they hold for your use case.
+ , StandardDB(..)
+ , IsDBName(..)
+
+ -- * Auxiliary functions
+ -- | 'writeDB' and 'readDB' perform (de)serialization of a package
+ -- database using a simple JSON encoding. You may use these to implement
+ -- 'writePackageDB' and 'readPackageDB' for your own databases.
+ , writeDB
+ , readDB
+ , initDB
+ -- * Exceptions
+ , PkgDBError(..)
+ , PkgInfoError(..)
+ )
+ where
+
+import Data.Aeson
+import Data.Aeson.Types
+import Control.Applicative
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import Control.Exception as E
+import Control.Monad
+import Data.Typeable
+import Data.Tagged
+import Data.Proxy
+import qualified Data.Map as Map
+import Text.Printf
+import qualified Distribution.InstalledPackageInfo as Info
+import Distribution.Package
+import Distribution.Text
+import System.FilePath
+import System.Directory
+
+-- The following imports are needed only for JSON instances
+import Data.Version (Version(..))
+import Distribution.Simple.Compiler (PackageDB(..))
+import Distribution.License (License(..))
+import Distribution.ModuleName(ModuleName)
+
+--------------
+-- Querying --
+--------------
+
+type Packages = [Info.InstalledPackageInfo]
+
+-- | Get all packages that are registered in a particular database
+--
+-- If the database doesn't exist, the behaviour is determined by
+-- 'maybeInitDB'.
+getInstalledPackages
+ :: forall db. IsPackageDB db
+ => Proxy db
+ -> PackageDB
+ -> IO Packages
+getInstalledPackages _proxy dbspec = do
+ mbDb <- locateDB dbspec
+
+ maybe
+ (return [])
+ (readPackageDB $ maybeInitDB dbspec)
+ (mbDb :: Maybe db)
+
+-- | Try to retrieve an 'InstalledPackageInfo' for each of
+-- 'InstalledPackageId's from a specified set of 'PackageDB's.
+--
+-- May throw a 'PkgInfoNotFound' exception.
+--
+-- If a database doesn't exist, the behaviour is determined by
+-- 'maybeInitDB'.
+readPackagesInfo
+ :: IsPackageDB db
+ => Proxy db -> [PackageDB] -> [InstalledPackageId] -> IO Packages
+readPackagesInfo proxyDb dbs pkgIds = do
+ allPkgInfos <- concat <$> mapM (getInstalledPackages proxyDb) dbs
+ let
+ pkgMap =
+ Map.fromList
+ [ (Info.installedPackageId pkgInfo, pkgInfo)
+ | pkgInfo <- allPkgInfos
+ ]
+ forM pkgIds $ \pkgId ->
+ maybe
+ (throwIO $ PkgInfoNotFound pkgId)
+ return
+ (Map.lookup pkgId pkgMap)
+
+---------------------------
+-- IsPackageDB & friends --
+---------------------------
+
+-- | Package database class.
+--
+-- @db@ will typically be a newtype-wrapped path to the database file,
+-- although more sophisticated setups are certainly possible.
+ --
+ -- Consider using 'StandardDB' first, and implement your own database
+ -- type if that isn't enough.
+class IsPackageDB db where
+
+ -- | The name of the database. Used to construct some paths.
+ dbName :: Tagged db String
+
+ -- | Read a package database.
+ --
+ -- If the database does not exist, then the first argument tells whether
+ -- we should create and initialize it with an empty package list. In
+ -- that case, if 'Don'tInitDB' is specified, a 'BadPkgDb' exception is
+ -- thrown.
+ readPackageDB :: MaybeInitDB -> db -> IO Packages
+
+ -- | Write a package database
+ writePackageDB :: db -> Packages -> IO ()
+
+ -- | Get the location of a global package database (if there's one)
+ globalDB :: IO (Maybe db)
+
+ -- | Create a db object given a database file path
+ dbFromPath :: FilePath -> IO db
+
+ -- Methods that have default implementations
+
+ -- | Convert a package db specification to a db object
+ locateDB :: PackageDB -> IO (Maybe db)
+ locateDB GlobalPackageDB = globalDB
+ locateDB UserPackageDB = Just <$> userDB
+ locateDB (SpecificPackageDB p) = Just <$> dbFromPath p
+
+ -- | The user database
+ userDB :: IO db
+ userDB = do
+ let name = untag (dbName :: Tagged db String)
+ path <- () <$> haskellPackagesDir <*> pure (name <.> "db")
+ dbFromPath path
+
+-- | A flag which tells whether the library should create an empty package
+-- database if it doesn't exist yet
+data MaybeInitDB = InitDB | Don'tInitDB
+
+-- | This function determines whether a package database should be
+-- initialized if it doesn't exist yet.
+--
+-- The rule is this: if it is a global or a user database, then initialize
+-- it; otherwise, don't.
+--
+-- Rationale: if the database was specified by the user, she could have
+-- made a mistake in the path, and we'd rather report it. On the other
+-- hand, it is our responsibility to ensure that the user and global
+-- databases exist.
+maybeInitDB :: PackageDB -> MaybeInitDB
+maybeInitDB GlobalPackageDB = InitDB
+maybeInitDB UserPackageDB = InitDB
+maybeInitDB SpecificPackageDB {} = Don'tInitDB
+
+----------------
+-- StandardDB --
+----------------
+
+class IsDBName name where
+ getDBName :: Tagged name String
+
+data StandardDB name = StandardDB FilePath
+
+instance IsDBName name => IsPackageDB (StandardDB name) where
+ dbName = retag (getDBName :: Tagged name String)
+
+ readPackageDB init (StandardDB db) = readDB init db
+ writePackageDB (StandardDB db) = writeDB db
+ globalDB = return Nothing
+ dbFromPath path = return $ StandardDB path
+
+-------------------------
+-- Auxiliary functions --
+-------------------------
+
+writeDB :: FilePath -> Packages -> IO ()
+writeDB path db = LBS.writeFile path $ encode db
+
+readDB :: MaybeInitDB -> FilePath -> IO Packages
+readDB maybeInit path = do
+ maybeDoInitDB
+
+ cts <- LBS.fromChunks . return <$> BS.readFile path
+ `E.catch` \e ->
+ throwIO $ PkgDBReadError path e
+ maybe (throwIO $ BadPkgDB path) return $ decode' cts
+
+ where
+ maybeDoInitDB
+ | InitDB <- maybeInit = initDB path
+ | otherwise = return ()
+
+-- | If the path does not exist, create an empty database there. Otherwise,
+-- do nothing.
+initDB :: FilePath -> IO ()
+initDB path = do
+ dbExists <- doesFileExist path
+ unless dbExists $ do
+ writeDB path []
+
+haskellPackagesDir :: IO FilePath
+haskellPackagesDir = getAppUserDataDirectory "haskell-packages"
+
+----------------
+-- Exceptions --
+----------------
+
+errPrefix :: String
+errPrefix = "haskell-suite package manager"
+
+data PkgDBError
+ = BadPkgDB FilePath -- ^ package database could not be parsed or contains errors
+ | PkgDBReadError FilePath IOException -- ^ package db file could not be read
+ | PkgExists InstalledPackageId -- ^ attempt to register an already present package id
+ | RegisterNullDB -- ^ attempt to register in the global db when it's not present
+ deriving (Typeable)
+instance Show PkgDBError where
+ show (BadPkgDB path) =
+ printf "%s: bad package database at %s" errPrefix path
+ show (PkgDBReadError path e) =
+ printf "%s: package db at %s could not be read: %s"
+ errPrefix path (show e)
+ show (PkgExists pkgid) =
+ printf "%s: package %s is already in the database" errPrefix (display pkgid)
+ show (RegisterNullDB) =
+ printf "%s: attempt to register in a null global db" errPrefix
+instance Exception PkgDBError
+
+data PkgInfoError
+ = PkgInfoNotFound InstalledPackageId
+ -- ^ requested package id could not be found in any of the package databases
+ deriving Typeable
+instance Exception PkgInfoError
+instance Show PkgInfoError where
+ show (PkgInfoNotFound pkgid) =
+ printf "%s: package not found: %s" errPrefix (display pkgid)
+
+---------------------
+-- Aeson instances --
+---------------------
+
+stdToJSON :: Text a => a -> Value
+stdToJSON = toJSON . display
+stdFromJSON :: Text a => Value -> Parser a
+stdFromJSON = maybe mzero return . simpleParse <=< parseJSON
+
+instance ToJSON License where
+ toJSON = stdToJSON
+instance FromJSON License where
+ parseJSON = stdFromJSON
+
+instance ToJSON Version where
+ toJSON = stdToJSON
+instance FromJSON Version where
+ parseJSON = stdFromJSON
+
+instance ToJSON ModuleName where
+ toJSON = stdToJSON
+instance FromJSON ModuleName where
+ parseJSON = stdFromJSON
+
+instance ToJSON PackageName where
+ toJSON = stdToJSON
+instance FromJSON PackageName where
+ parseJSON = stdFromJSON
+
+instance ToJSON PackageIdentifier where
+ toJSON = stdToJSON
+instance FromJSON PackageIdentifier where
+ parseJSON = stdFromJSON
+
+instance ToJSON InstalledPackageId where
+ toJSON = stdToJSON
+instance FromJSON InstalledPackageId where
+ parseJSON = stdFromJSON
+
+instance ToJSON a => ToJSON (Info.InstalledPackageInfo_ a) where
+ toJSON i = object
+ [ "id" .= Info.installedPackageId i
+ , "name" .= Info.sourcePackageId i
+ , "license" .= Info.license i
+ , "copyright" .= Info.copyright i
+ , "maintainer" .= Info.maintainer i
+ , "author" .= Info.author i
+ , "stability" .= Info.stability i
+ , "homepage" .= Info.homepage i
+ , "package-url" .= Info.pkgUrl i
+ , "synopsis" .= Info.synopsis i
+ , "description" .= Info.description i
+ , "category" .= Info.category i
+ , "exposed" .= Info.exposed i
+ , "exposed-modules" .= Info.exposedModules i
+ , "hidden-modules" .= Info.hiddenModules i
+ , "trusted" .= Info.trusted i
+ , "import-dirs" .= Info.importDirs i
+ , "library-dirs" .= Info.libraryDirs i
+ , "hs-libraries" .= Info.hsLibraries i
+ , "extra-libraries" .= Info.extraLibraries i
+ , "extra-ghci-libraries" .= Info.extraGHCiLibraries i
+ , "include-dirs" .= Info.includeDirs i
+ , "includes" .= Info.includes i
+ , "depends" .= Info.depends i
+ , "hugs-options" .= Info.hugsOptions i
+ , "cc-options" .= Info.ccOptions i
+ , "ld-options" .= Info.ldOptions i
+ , "framework-dirs" .= Info.frameworkDirs i
+ , "frameworks" .= Info.frameworks i
+ , "haddock-interfaces" .= Info.haddockInterfaces i
+ , "haddock-html" .= Info.haddockHTMLs i
+ ]
+
+-- FIXME this will break silently if the order of fields changes in the
+-- future
+instance FromJSON a => FromJSON (Info.InstalledPackageInfo_ a) where
+ parseJSON (Object v) = Info.InstalledPackageInfo <$>
+ v .: "id" <*>
+ v .: "name" <*>
+ v .: "license" <*>
+ v .: "copyright" <*>
+ v .: "maintainer" <*>
+ v .: "author" <*>
+ v .: "stability" <*>
+ v .: "homepage" <*>
+ v .: "package-url" <*>
+ v .: "synopsis" <*>
+ v .: "description" <*>
+ v .: "category" <*>
+ v .: "exposed" <*>
+ v .: "exposed-modules" <*>
+ v .: "hidden-modules" <*>
+ v .: "trusted" <*>
+ v .: "import-dirs" <*>
+ v .: "library-dirs" <*>
+ v .: "hs-libraries" <*>
+ v .: "extra-libraries" <*>
+ v .: "extra-ghci-libraries" <*>
+ v .: "include-dirs" <*>
+ v .: "includes" <*>
+ v .: "depends" <*>
+ v .: "hugs-options" <*>
+ v .: "cc-options" <*>
+ v .: "ld-options" <*>
+ v .: "framework-dirs" <*>
+ v .: "frameworks" <*>
+ v .: "haddock-interfaces" <*>
+ v .: "haddock-html"
+ parseJSON _ = mzero