fixup! Resolve #698: sometimes we trigger custom type error

.travis.yml

@@ -6,6 +6,7 @@ env:
   - STACK_YAML=stack-ghc-7.8.4.yaml
   - STACK_YAML=stack.yaml
   - STACK_YAML=stack-ghc-8.0.1.yaml
+  - STACK_YAML=stack-ghc-8.0.2.yaml
 
 addons:
   apt:

servant/Setup.lhs

@@ -1,5 +1,19 @@
 \begin{code}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main (main) where
+
+#ifndef MIN_VERSION_cabal_doctest
+#define MIN_VERSION_cabal_doctest(x,y,z) 0
+#endif
+
+
+#if MIN_VERSION_cabal_doctest(1,0,0)
+import Distribution.Extra.Doctest ( defaultMainWithDoctests )
+#else
+
+-- Otherwise we provide a shim
+
 #ifndef MIN_VERSION_Cabal
 #define MIN_VERSION_Cabal(x,y,z) 0
 #endif
@@ -9,10 +23,10 @@
 #if MIN_VERSION_Cabal(1,24,0)
 #define InstalledPackageId UnitId
 #endif
-module Main (main) where
 
 import Control.Monad ( when )
 import Data.List ( nub )
+import Data.String ( fromString )
 import Distribution.Package ( InstalledPackageId )
 import Distribution.Package ( PackageId, Package (..), packageVersion )
 import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..))
@@ -42,15 +56,8 @@ makeAbsolute p | isAbsolute p = return p
     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
+generateBuildModule :: String -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+generateBuildModule testsuiteName flags pkg lbi = do
   let verbosity = fromFlag (buildVerbosity flags)
   let distPref = fromFlag (buildDistPref flags)
 
@@ -74,7 +81,7 @@ generateBuildModule flags pkg lbi = do
 #endif
 
     -- Lib sources and includes
-    iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ "test" : libAutogenDir : hsSourceDirs libBI
+    iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI
     includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI
 
     -- CPP includes, i.e. include cabal_macros.h
@@ -82,9 +89,7 @@ generateBuildModule flags pkg lbi = do
             [ "-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
+    withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testsuiteName) $ do
 
       -- get and create autogen dir
 #if MIN_VERSION_Cabal(1,25,0)
@@ -106,7 +111,7 @@ generateBuildModule flags pkg lbi = do
         , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)
         , ""
         , "module_sources :: [String]"
-        , "module_sources = " ++ show ("Servant.Utils.LinksSpec" : map display module_sources)
+        , "module_sources = " ++ show (map display module_sources)
         ]
   where
     -- we do this check in Setup, as then doctests don't need to depend on Cabal
@@ -162,4 +167,16 @@ generateBuildModule flags pkg lbi = do
 testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
 testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
 
+defaultMainWithDoctests :: String -> IO ()
+defaultMainWithDoctests testSuiteName = defaultMainWithHooks simpleUserHooks
+  { buildHook = \pkg lbi hooks flags -> do
+     generateBuildModule testSuiteName flags pkg lbi
+     buildHook simpleUserHooks pkg lbi hooks flags
+  }
+
+#endif
+
+main :: IO ()
+main = defaultMainWithDoctests "doctests"
+
 \end{code}

servant/servant.cabal

@@ -27,7 +27,7 @@ source-repository head
 
 custom-setup
   setup-depends:
-     Cabal >=1.14, base, filepath, directory
+     Cabal >=1.14, base, cabal-doctest
 
 library
   exposed-modules:
@@ -134,7 +134,7 @@ test-suite spec
 test-suite doctests
  build-depends: base
               , servant
-              , doctest
+              , doctest >=0.11.0 && <0.12
               , filemanip
               , directory
               , filepath
@@ -144,5 +144,4 @@ test-suite doctests
  buildable: True
  default-language: Haskell2010
  ghc-options: -Wall -threaded
- build-tools: hsc2hs
  include-dirs: include

servant/test/Servant/Utils/LinksSpec.hs

@@ -83,7 +83,7 @@ spec = describe "Servant.Utils.Links" $ do
 --
 -- >>> apiLink (Proxy :: Proxy WrongContentType)
 -- ...
--- ...Could not deduce...
+-- ...interactive...
 -- ...
 --
 -- >>> apiLink (Proxy :: Proxy WrongMethod)

servant/test/doctests.hs

@@ -0,0 +1,39 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 Data.List (isPrefixOf, isSuffixOf)
+import Test.DocTest
+
+main :: IO ()
+main = do
+    traverse_ putStrLn args
+    doctest args
+  where
+    args = 
+      "-XOverloadedStrings" :
+      "-XFlexibleInstances" :
+      "-XMultiParamTypeClasses" :
+      flags ++ flags' ++ pkgs ++
+      "Servant.Utils.LinksSpec" :
+      module_sources
+
+    -- HACK: find -i.../src, and change it ot -i.../test
+    flags'
+        = map (\x -> take (length x - 4) x ++ "/test")
+        . filter (\x -> "-i" `isPrefixOf` x && "/src" `isSuffixOf` x)
+        $ flags
+

servant/test/doctests.hsc

@@ -1,59 +0,0 @@
-{-# 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

stack-ghc-8.0.2.yaml

@@ -0,0 +1,9 @@
+resolver: nightly-2017-02-11
+packages:
+- servant/
+- servant-client/
+- servant-docs/
+- servant-foreign/
+- servant-server/
+- doc/tutorial
+extra-deps: []