Make servant buildable with cabal new-build

This commit is contained in:
Oleg Grenrus 2017-01-16 09:06:22 +02:00
parent 8822c12530
commit d5e73bf577
13 changed files with 471 additions and 89 deletions

1
.gitignore vendored
View File

@ -1,4 +1,5 @@
**/*/dist
dist-newstyle
/bin
/lib
/share

7
cabal.project Normal file
View File

@ -0,0 +1,7 @@
packages:
servant/
servant-client/
servant-docs/
servant-foreign/
servant-server/
doc/tutorial/

View File

@ -47,6 +47,7 @@ library
, http-client
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit
test-suite spec
type: exitcode-stdio-1.0

View File

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

165
servant-server/Setup.lhs Normal file
View File

@ -0,0 +1,165 @@
\begin{code}
{-# LANGUAGE CPP #-}
#ifndef MIN_VERSION_Cabal
#define MIN_VERSION_Cabal(x,y,z) 0
#endif
#ifndef MIN_VERSION_directory
#define MIN_VERSION_directory(x,y,z) 0
#endif
#if MIN_VERSION_Cabal(1,24,0)
#define InstalledPackageId UnitId
#endif
module Main (main) where
import Control.Monad ( when )
import Data.List ( nub )
import Distribution.Package ( InstalledPackageId )
import Distribution.Package ( PackageId, Package (..), packageVersion )
import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..))
import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )
import Distribution.Simple.BuildPaths ( autogenModulesDir )
import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)
import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )
import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))
import Distribution.Text ( display , simpleParse )
import System.FilePath ( (</>) )
#if MIN_VERSION_Cabal(1,25,0)
import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )
#endif
#if MIN_VERSION_directory(1,2,2)
import System.Directory (makeAbsolute)
#else
import System.Directory (getCurrentDirectory)
import System.FilePath (isAbsolute)
makeAbsolute :: FilePath -> IO FilePath
makeAbsolute p | isAbsolute p = return p
| otherwise = do
cwd <- getCurrentDirectory
return $ cwd </> p
#endif
main :: IO ()
main = defaultMainWithHooks simpleUserHooks
{ buildHook = \pkg lbi hooks flags -> do
generateBuildModule flags pkg lbi
buildHook simpleUserHooks pkg lbi hooks flags
}
generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
generateBuildModule flags pkg lbi = do
let verbosity = fromFlag (buildVerbosity flags)
let distPref = fromFlag (buildDistPref flags)
-- Package DBs
let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]
let dbFlags = "-hide-all-packages" : packageDbArgs dbStack
withLibLBI pkg lbi $ \lib libcfg -> do
let libBI = libBuildInfo lib
-- modules
let modules = exposedModules lib ++ otherModules libBI
-- it seems that doctest is happy to take in module names, not actual files!
let module_sources = modules
-- We need the directory with library's cabal_macros.h!
#if MIN_VERSION_Cabal(1,25,0)
let libAutogenDir = autogenComponentModulesDir lbi libcfg
#else
let libAutogenDir = autogenModulesDir lbi
#endif
-- Lib sources and includes
iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI
includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI
-- CPP includes, i.e. include cabal_macros.h
let cppFlags = map ("-optP"++) $
[ "-include", libAutogenDir ++ "/cabal_macros.h" ]
++ cppOptions libBI
-- Actually we need to check whether testName suite == "doctests"
-- pending https://github.com/haskell/cabal/pull/4229 getting into GHC HEAD tree
withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == "doctests") $ do
-- get and create autogen dir
#if MIN_VERSION_Cabal(1,25,0)
let testAutogenDir = autogenComponentModulesDir lbi suitecfg
#else
let testAutogenDir = autogenModulesDir lbi
#endif
createDirectoryIfMissingVerbose verbosity True testAutogenDir
-- write autogen'd file
rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines
[ "module Build_doctests where"
, ""
-- -package-id etc. flags
, "pkgs :: [String]"
, "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)
, ""
, "flags :: [String]"
, "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)
, ""
, "module_sources :: [String]"
, "module_sources = " ++ show (map display module_sources)
]
where
-- we do this check in Setup, as then doctests don't need to depend on Cabal
isOldCompiler = maybe False id $ do
a <- simpleParse $ showCompilerId $ compiler lbi
b <- simpleParse "7.5"
return $ packageVersion (a :: PackageId) < b
formatDeps = map formatOne
formatOne (installedPkgId, pkgId)
-- The problem is how different cabal executables handle package databases
-- when doctests depend on the library
| packageId pkg == pkgId = "-package=" ++ display pkgId
| otherwise = "-package-id=" ++ display installedPkgId
-- From Distribution.Simple.Program.GHC
packageDbArgs :: [PackageDB] -> [String]
packageDbArgs | isOldCompiler = packageDbArgsConf
| otherwise = packageDbArgsDb
-- GHC <7.6 uses '-package-conf' instead of '-package-db'.
packageDbArgsConf :: [PackageDB] -> [String]
packageDbArgsConf dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
(GlobalPackageDB:dbs) -> ("-no-user-package-conf")
: concatMap specific dbs
_ -> ierror
where
specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]
specific _ = ierror
ierror = error $ "internal error: unexpected package db stack: "
++ show dbstack
-- GHC >= 7.6 uses the '-package-db' flag. See
-- https://ghc.haskell.org/trac/ghc/ticket/5977.
packageDbArgsDb :: [PackageDB] -> [String]
-- special cases to make arguments prettier in common scenarios
packageDbArgsDb dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs)
| all isSpecific dbs -> concatMap single dbs
(GlobalPackageDB:dbs)
| all isSpecific dbs -> "-no-user-package-db"
: concatMap single dbs
dbs -> "-clear-package-db"
: concatMap single dbs
where
single (SpecificPackageDB db) = [ "-package-db=" ++ db ]
single GlobalPackageDB = [ "-global-package-db" ]
single UserPackageDB = [ "-user-package-db" ]
isSpecific (SpecificPackageDB _) = True
isSpecific _ = False
testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
\end{code}

View File

@ -19,7 +19,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
category: Web
build-type: Simple
build-type: Custom
cabal-version: >=1.10
tested-with: GHC >= 7.8
extra-source-files:
@ -31,6 +31,9 @@ source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
custom-setup
setup-depends:
Cabal >=1.14, base, filepath, directory
library
exposed-modules:
@ -144,7 +147,7 @@ test-suite doctests
, directory
, filepath
type: exitcode-stdio-1.0
main-is: test/Doctests.hs
main-is: test/doctests.hs
buildable: True
default-language: Haskell2010
ghc-options: -Wall -threaded

View File

@ -1,41 +0,0 @@
module Main where
import Data.List (isPrefixOf)
import System.Directory
import System.FilePath
import System.FilePath.Find
import Test.DocTest
main :: IO ()
main = do
files <- find always (extension ==? ".hs") "src"
mCabalMacrosFile <- getCabalMacrosFile
doctest $ "-isrc" : "-Iinclude" :
(maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
"-XOverloadedStrings" :
"-XFlexibleInstances" :
"-XMultiParamTypeClasses" :
"-XDataKinds" :
"-XTypeOperators" :
files
getCabalMacrosFile :: IO (Maybe FilePath)
getCabalMacrosFile = do
exists <- doesDirectoryExist "dist"
if exists
then do
contents <- getDirectoryContents "dist"
let rest = "build" </> "autogen" </> "cabal_macros.h"
whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of
[x] -> "dist" </> x </> rest
[] -> "dist" </> rest
xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"
++ show xs ++ "\nTry cabal clean"
else return Nothing
where
whenExists :: FilePath -> IO (Maybe FilePath)
whenExists file = do
exists <- doesFileExist file
return $ if exists
then Just file
else Nothing

View File

@ -0,0 +1,61 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
-- |
-- Module : Main (doctests)
-- Copyright : (C) 2012-14 Edward Kmett
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : provisional
-- Portability : portable
--
-- This module provides doctests for a project based on the actual versions
-- of the packages it was built with. It requires a corresponding Setup.lhs
-- to be added to the project
-----------------------------------------------------------------------------
module Main where
import Build_doctests (flags, pkgs, module_sources)
import Data.Foldable (traverse_)
import Test.DocTest
##if defined(mingw32_HOST_OS)
##if defined(i386_HOST_ARCH)
##define USE_CP
import Control.Applicative
import Control.Exception
import Foreign.C.Types
foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
##elif defined(x86_64_HOST_ARCH)
##define USE_CP
import Control.Applicative
import Control.Exception
import Foreign.C.Types
foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
##endif
##endif
-- | Run in a modified codepage where we can print UTF-8 values on Windows.
withUnicode :: IO a -> IO a
##ifdef USE_CP
withUnicode m = do
cp <- c_GetConsoleCP
(c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp
##else
withUnicode m = m
##endif
main :: IO ()
main = withUnicode $ do
traverse_ putStrLn args
doctest args
where
args =
"-XOverloadedStrings" :
"-XFlexibleInstances" :
"-XMultiParamTypeClasses" :
"-XDataKinds" :
"-XTypeOperators" :
flags ++ pkgs ++ module_sources

View File

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

165
servant/Setup.lhs Normal file
View File

@ -0,0 +1,165 @@
\begin{code}
{-# LANGUAGE CPP #-}
#ifndef MIN_VERSION_Cabal
#define MIN_VERSION_Cabal(x,y,z) 0
#endif
#ifndef MIN_VERSION_directory
#define MIN_VERSION_directory(x,y,z) 0
#endif
#if MIN_VERSION_Cabal(1,24,0)
#define InstalledPackageId UnitId
#endif
module Main (main) where
import Control.Monad ( when )
import Data.List ( nub )
import Distribution.Package ( InstalledPackageId )
import Distribution.Package ( PackageId, Package (..), packageVersion )
import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..))
import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )
import Distribution.Simple.BuildPaths ( autogenModulesDir )
import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)
import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )
import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))
import Distribution.Text ( display , simpleParse )
import System.FilePath ( (</>) )
#if MIN_VERSION_Cabal(1,25,0)
import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )
#endif
#if MIN_VERSION_directory(1,2,2)
import System.Directory (makeAbsolute)
#else
import System.Directory (getCurrentDirectory)
import System.FilePath (isAbsolute)
makeAbsolute :: FilePath -> IO FilePath
makeAbsolute p | isAbsolute p = return p
| otherwise = do
cwd <- getCurrentDirectory
return $ cwd </> p
#endif
main :: IO ()
main = defaultMainWithHooks simpleUserHooks
{ buildHook = \pkg lbi hooks flags -> do
generateBuildModule flags pkg lbi
buildHook simpleUserHooks pkg lbi hooks flags
}
generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
generateBuildModule flags pkg lbi = do
let verbosity = fromFlag (buildVerbosity flags)
let distPref = fromFlag (buildDistPref flags)
-- Package DBs
let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]
let dbFlags = "-hide-all-packages" : packageDbArgs dbStack
withLibLBI pkg lbi $ \lib libcfg -> do
let libBI = libBuildInfo lib
-- modules
let modules = exposedModules lib ++ otherModules libBI
-- it seems that doctest is happy to take in module names, not actual files!
let module_sources = modules
-- We need the directory with library's cabal_macros.h!
#if MIN_VERSION_Cabal(1,25,0)
let libAutogenDir = autogenComponentModulesDir lbi libcfg
#else
let libAutogenDir = autogenModulesDir lbi
#endif
-- Lib sources and includes
iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI
includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI
-- CPP includes, i.e. include cabal_macros.h
let cppFlags = map ("-optP"++) $
[ "-include", libAutogenDir ++ "/cabal_macros.h" ]
++ cppOptions libBI
-- Actually we need to check whether testName suite == "doctests"
-- pending https://github.com/haskell/cabal/pull/4229 getting into GHC HEAD tree
withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == "doctests") $ do
-- get and create autogen dir
#if MIN_VERSION_Cabal(1,25,0)
let testAutogenDir = autogenComponentModulesDir lbi suitecfg
#else
let testAutogenDir = autogenModulesDir lbi
#endif
createDirectoryIfMissingVerbose verbosity True testAutogenDir
-- write autogen'd file
rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines
[ "module Build_doctests where"
, ""
-- -package-id etc. flags
, "pkgs :: [String]"
, "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)
, ""
, "flags :: [String]"
, "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)
, ""
, "module_sources :: [String]"
, "module_sources = " ++ show (map display module_sources)
]
where
-- we do this check in Setup, as then doctests don't need to depend on Cabal
isOldCompiler = maybe False id $ do
a <- simpleParse $ showCompilerId $ compiler lbi
b <- simpleParse "7.5"
return $ packageVersion (a :: PackageId) < b
formatDeps = map formatOne
formatOne (installedPkgId, pkgId)
-- The problem is how different cabal executables handle package databases
-- when doctests depend on the library
| packageId pkg == pkgId = "-package=" ++ display pkgId
| otherwise = "-package-id=" ++ display installedPkgId
-- From Distribution.Simple.Program.GHC
packageDbArgs :: [PackageDB] -> [String]
packageDbArgs | isOldCompiler = packageDbArgsConf
| otherwise = packageDbArgsDb
-- GHC <7.6 uses '-package-conf' instead of '-package-db'.
packageDbArgsConf :: [PackageDB] -> [String]
packageDbArgsConf dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
(GlobalPackageDB:dbs) -> ("-no-user-package-conf")
: concatMap specific dbs
_ -> ierror
where
specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]
specific _ = ierror
ierror = error $ "internal error: unexpected package db stack: "
++ show dbstack
-- GHC >= 7.6 uses the '-package-db' flag. See
-- https://ghc.haskell.org/trac/ghc/ticket/5977.
packageDbArgsDb :: [PackageDB] -> [String]
-- special cases to make arguments prettier in common scenarios
packageDbArgsDb dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs)
| all isSpecific dbs -> concatMap single dbs
(GlobalPackageDB:dbs)
| all isSpecific dbs -> "-no-user-package-db"
: concatMap single dbs
dbs -> "-clear-package-db"
: concatMap single dbs
where
single (SpecificPackageDB db) = [ "-package-db=" ++ db ]
single GlobalPackageDB = [ "-global-package-db" ]
single UserPackageDB = [ "-user-package-db" ]
isSpecific (SpecificPackageDB _) = True
isSpecific _ = False
testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
\end{code}

View File

@ -15,7 +15,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
category: Web
build-type: Simple
build-type: Custom
cabal-version: >=1.10
tested-with: GHC >= 7.8
extra-source-files:
@ -25,6 +25,10 @@ source-repository head
type: git
location: http://github.com/haskell-servant/servant.git
custom-setup
setup-depends:
Cabal >=1.14, base, filepath, directory
library
exposed-modules:
Servant.API
@ -134,8 +138,9 @@ test-suite doctests
, directory
, filepath
type: exitcode-stdio-1.0
main-is: test/Doctests.hs
main-is: test/doctests.hs
buildable: True
default-language: Haskell2010
ghc-options: -Wall -threaded
build-tools: hsc2hs
include-dirs: include

View File

@ -1,40 +0,0 @@
module Main where
import Data.List (isPrefixOf)
import System.Directory
import System.FilePath
import System.FilePath.Find
import Test.DocTest
main :: IO ()
main = do
files <- find always (extension ==? ".hs") "src"
tfiles <- find always (extension ==? ".hs") "test/Servant"
mCabalMacrosFile <- getCabalMacrosFile
doctest $ "-isrc" : "-Iinclude" :
(maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
"-XOverloadedStrings" :
"-XFlexibleInstances" :
"-XMultiParamTypeClasses" :
(files ++ tfiles)
getCabalMacrosFile :: IO (Maybe FilePath)
getCabalMacrosFile = do
exists <- doesDirectoryExist "dist"
if exists
then do
contents <- getDirectoryContents "dist"
let rest = "build" </> "autogen" </> "cabal_macros.h"
whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of
[x] -> "dist" </> x </> rest
[] -> "dist" </> rest
xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"
++ show xs ++ "\nTry cabal clean"
else return Nothing
where
whenExists :: FilePath -> IO (Maybe FilePath)
whenExists file = do
exists <- doesFileExist file
return $ if exists
then Just file
else Nothing

59
servant/test/doctests.hsc Normal file
View File

@ -0,0 +1,59 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
-- |
-- Module : Main (doctests)
-- Copyright : (C) 2012-14 Edward Kmett
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : provisional
-- Portability : portable
--
-- This module provides doctests for a project based on the actual versions
-- of the packages it was built with. It requires a corresponding Setup.lhs
-- to be added to the project
-----------------------------------------------------------------------------
module Main where
import Build_doctests (flags, pkgs, module_sources)
import Data.Foldable (traverse_)
import Test.DocTest
##if defined(mingw32_HOST_OS)
##if defined(i386_HOST_ARCH)
##define USE_CP
import Control.Applicative
import Control.Exception
import Foreign.C.Types
foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
##elif defined(x86_64_HOST_ARCH)
##define USE_CP
import Control.Applicative
import Control.Exception
import Foreign.C.Types
foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
##endif
##endif
-- | Run in a modified codepage where we can print UTF-8 values on Windows.
withUnicode :: IO a -> IO a
##ifdef USE_CP
withUnicode m = do
cp <- c_GetConsoleCP
(c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp
##else
withUnicode m = m
##endif
main :: IO ()
main = withUnicode $ do
traverse_ putStrLn args
doctest args
where
args =
"-XOverloadedStrings" :
"-XFlexibleInstances" :
"-XMultiParamTypeClasses" :
flags ++ pkgs ++ module_sources