Integration test for unlisted/TH dependencies (#32/#105)

Author: borsboom

src/Path/IO.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | IO actions that might be put in a package at some point.
 
@@ -30,7 +31,9 @@ module Path.IO
   ,copyFileIfExists
   ,copyDirectoryRecursive
   ,createTree
-  ,dropRoot)
+  ,dropRoot
+  ,parseCollapsedAbsFile
+  ,parseCollapsedAbsDir)
   where
 
 import           Control.Exception hiding (catch)
@@ -123,6 +126,44 @@ resolveFileMaybe :: (MonadIO m,MonadThrow m)
                  => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))
 resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile
 
+-- | Collapse intermediate "." and ".." directories from path, then parse
+-- it with 'parseAbsFile'.
+-- (probably should be moved to the Path module)
+parseCollapsedAbsFile :: MonadThrow m => FilePath -> m (Path Abs File)
+parseCollapsedAbsFile = parseAbsFile . collapseFilePath
+
+-- | Collapse intermediate "." and ".." directories from path, then parse
+-- it with 'parseAbsDir'.
+-- (probably should be moved to the Path module)
+parseCollapsedAbsDir :: MonadThrow m => FilePath -> m (Path Abs Dir)
+parseCollapsedAbsDir = parseAbsDir . collapseFilePath
+
+-- | Collapse intermediate "." and ".." directories from a path.
+--
+-- > collapseFilePath "./foo" == "foo"
+-- > collapseFilePath "/bar/../baz" == "/baz"
+-- > collapseFilePath "/../baz" == "/../baz"
+-- > collapseFilePath "parent/foo/baz/../bar" ==  "parent/foo/bar"
+-- > collapseFilePath "parent/foo/baz/../../bar" ==  "parent/bar"
+-- > collapseFilePath "parent/foo/.." ==  "parent"
+-- > collapseFilePath "/parent/foo/../../bar" ==  "/bar"
+--
+-- (borrowed from @Text.Pandoc.Shared@)
+collapseFilePath :: FilePath -> FilePath
+collapseFilePath = FP.joinPath . reverse . foldl go [] . FP.splitDirectories
+  where
+    go rs "." = rs
+    go r@(p:rs) ".." = case p of
+                            ".." -> ("..":r)
+                            (checkPathSeperator -> Just True) -> ("..":r)
+                            _ -> rs
+    go _ (checkPathSeperator -> Just True) = [[FP.pathSeparator]]
+    go rs x = x:rs
+    isSingleton [] = Nothing
+    isSingleton [x] = Just x
+    isSingleton _ = Nothing
+    checkPathSeperator = fmap FP.isPathSeparator . isSingleton
+
 -- | List objects in a directory, excluding "@.@" and "@..@".  Entries are not sorted.
 listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File])
 listDirectory dir =

src/Stack/Package.hs

@@ -801,15 +801,22 @@ findCandidate dirs exts name = do
         -> IO [Either ResolveException (Path Abs File)]
     makeDirCandidates dir =
         case name of
-            Right fp -> liftM return (try (resolveFile dir fp))
+            Right fp -> liftM return (try (resolveFile' dir fp))
             Left mn ->
                 mapM
                     (\ext ->
                           try
-                              (resolveFile
+                              (resolveFile'
                                    dir
                                    (Cabal.toFilePath mn ++ "." ++ ext)))
                     (map T.unpack exts)
+    resolveFile' :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath.FilePath -> m (Path Abs File)
+    resolveFile' x y = do
+        p <- parseCollapsedAbsFile (toFilePath x FilePath.</> y)
+        exists <- fileExists p
+        if exists
+            then return p
+            else throwM $ ResolveFileFailed x y (toFilePath p)
 
 -- | Warn the user that multiple candidates are available for an
 -- entry, but that we picked one anyway and continued.

test/integration/lib/StackTest.hs

@@ -66,3 +66,8 @@ doesFileOrDirExist fp = do
             if isDir
                 then return (Right ("Directory exists: " ++ fp))
                 else return (Left ())
+
+copy :: FilePath -> FilePath -> IO ()
+copy src dest = do
+    putStrLn ("Copy " ++ show src ++ " to " ++ show dest)
+    System.Directory.copyFile src dest

test/integration/tests/32-unlisted-module/Main.hs

@@ -0,0 +1,25 @@
+import Control.Concurrent
+import StackTest
+
+main :: IO ()
+main = do
+    copy "src/Unlisted_OK.hs" "src/Unlisted.hs"
+    copy "embed_OK.txt" "embed.txt"
+    stack ["build"]
+    pause
+    copy "src/Unlisted_FAIL.hs" "src/Unlisted.hs"
+    stackErr ["build"]
+    pause
+    copy "src/Unlisted_OK.hs" "src/Unlisted.hs"
+    stack ["build"]
+    stack ["exec", "files-exe"]
+    pause
+    copy "embed_FAIL.txt" "embed.txt"
+    stack ["build"]
+    stackErr ["exec", "files-exe"]
+    pause
+    copy "embed_OK.txt" "embed.txt"
+    stack ["build"]
+    stack ["exec", "files-exe"]
+
+pause = threadDelay 1000000

test/integration/tests/32-unlisted-module/files/embed_FAIL.txt

@@ -0,0 +1 @@
+FAIL

test/integration/tests/32-unlisted-module/files/embed_OK.txt

@@ -0,0 +1 @@
+OK

test/integration/tests/32-unlisted-module/files/files.cabal

@@ -0,0 +1,16 @@
+name:                files
+version:             0.1.0.0
+synopsis:            Initial project template from stack
+description:         Please see README.md
+homepage:            http://github.com/githubuser/files#readme
+license:             BSD3
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+executable files-exe
+  hs-source-dirs:      src/../src
+  main-is:             Main.hs
+  build-depends:       base >= 4.7 && < 5
+                     , file-embed
+  default-language:    Haskell2010

test/integration/tests/32-unlisted-module/files/src/Main.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Data.FileEmbed
+import Unlisted
+
+main :: IO ()
+main = do
+    putStrLn ("main " ++ show foo ++ " " ++ show embedded)
+    if embedded == "FAIL\n"
+        then error "embedded contains FAIL"
+        else return ()
+
+embedded  = $(embedFile "embed.txt")

test/integration/tests/32-unlisted-module/files/src/Unlisted_FAIL.hs

@@ -0,0 +1,5 @@
+-- | Version of Unlisted with different export that causes failure to compile.
+module Unlisted where
+
+fooRenamed :: String
+fooRenamed = "foo"

test/integration/tests/32-unlisted-module/files/src/Unlisted_OK.hs

@@ -0,0 +1,4 @@
+module Unlisted where
+
+foo :: String
+foo = "foo"

test/integration/tests/32-unlisted-module/files/src/main/Main.hs

@@ -0,0 +1,3 @@
+module Main where
+
+main = do putStrLn "Hello, world."

test/integration/tests/32-unlisted-module/files/stack.yaml

@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps: []
+resolver: lts-3.0