diff --git a/liquidhaskell-cabal.cabal b/liquidhaskell-cabal.cabal --- a/liquidhaskell-cabal.cabal +++ b/liquidhaskell-cabal.cabal @@ -1,11 +1,11 @@ name: liquidhaskell-cabal -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Liquid Haskell integration for Cabal and Stack description: Provides support for checking projects using Cabal and/or stack with LiquidHaskell. Please see the - + on GitHub for setup and usage instructions. homepage: https://github.com/spinda/liquidhaskell-cabal#readme bug-reports: https://github.com/spinda/liquidhaskell-cabal/issues @@ -24,6 +24,7 @@ build-depends: base >= 4.4 && < 5 , Cabal , filepath >= 1.3 && <1.5 + , directory default-language: Haskell2010 source-repository head diff --git a/src/LiquidHaskell/Cabal.hs b/src/LiquidHaskell/Cabal.hs --- a/src/LiquidHaskell/Cabal.hs +++ b/src/LiquidHaskell/Cabal.hs @@ -1,9 +1,10 @@ -- | Please see the --- +-- -- for setup and usage instructions. {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module LiquidHaskell.Cabal ( -- defaults @@ -22,9 +23,12 @@ , liquidHaskellPostTestHook ) where +import Control.Applicative import Control.Exception import Control.Monad +import Data.Either +import Data.Foldable import Data.List import Data.Maybe @@ -44,6 +48,7 @@ import Distribution.Verbosity import Distribution.Utils.NubList +import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist) import System.FilePath import Debug.Trace @@ -127,20 +132,27 @@ withAllComponentsInBuildOrder pkg lbi $ \component clbi -> case component of CLib lib -> do - srcs <- findLibSources lib - verifyComponent verbosity lbi clbi (libBuildInfo lib) - "library" srcs + let desc = "library" + let buildInfo' = libBuildInfo lib + sourceFilter <- makeSourceFilter desc buildInfo' + srcs <- filterSources desc sourceFilter =<< findLibSources lib + verifyComponent verbosity lbi clbi buildInfo' desc srcs CExe exe -> do - srcs <- findExeSources exe - verifyComponent verbosity lbi clbi (buildInfo exe) - ("executable " ++ unUnqualComponentName (exeName exe)) srcs + let desc = "executable " ++ unUnqualComponentName (exeName exe) + let buildInfo' = buildInfo exe + sourceFilter <- makeSourceFilter desc buildInfo' + srcs <- filterSources desc sourceFilter =<< findExeSources exe + verifyComponent verbosity lbi clbi buildInfo' desc srcs _ -> return () -liquidHaskellOptions :: String -liquidHaskellOptions = "x-liquidhaskell-options" +liquidHaskellOptionsField :: String +liquidHaskellOptionsField = "x-liquidhaskell-options" +liquidHaskellVerifyField :: String +liquidHaskellVerifyField = "x-liquidhaskell-verify" + -------------------------------------------------------------------------------- -- Build Process Tweaks -------------------------------------------------------- -------------------------------------------------------------------------------- @@ -175,16 +187,98 @@ runProgram verbosity liquid args getUserArgs :: String -> BuildInfo -> IO [ProgArg] -getUserArgs desc bi = - case lookup liquidHaskellOptions (customFieldsBI bi) of - Nothing -> return [] - Just cmd -> - case parseCommandArgs cmd of - Right args -> return args - Left err -> dieNoVerbosity $ - "failed to parse LiquidHaskell options for " ++ desc ++ ": " ++ err +getUserArgs desc = + (concat <$>) . mapM (getUserArgs' desc) . getAllCustomFieldValues liquidHaskellOptionsField +getUserArgs' :: String -> String -> IO [ProgArg] +getUserArgs' desc cmd = case parseCommandArgs cmd of + Right args -> return args + Left err -> dieNoVerbosity $ + "failed to parse LiquidHaskell options for " ++ desc ++ ": " ++ err + -------------------------------------------------------------------------------- +-- Filter Input Sources -------------------------------------------------------- +-------------------------------------------------------------------------------- + +type SourcePattern = Either FilePattern DirectoryPattern + +data FilePattern = FilePattern + { filePatternSource :: !FilePath + , filePatternCompiled :: !FilePath + } + +data DirectoryPattern = DirectoryPattern + { directoryPatternSource :: !FilePath + , directoryPatternCompiled :: ![FilePath] + } + +data SourceFilter = + All + | Whitelist [FilePattern] [DirectoryPattern] + +makeSourceFilter :: String -> BuildInfo -> IO SourceFilter +makeSourceFilter desc bi + | null paths = return All + | otherwise = uncurry Whitelist . partitionEithers <$> mapM (makeSourcePattern desc) paths + where + paths = getAllCustomFieldValues liquidHaskellVerifyField bi + +makeSourcePattern :: String -> FilePath -> IO SourcePattern +makeSourcePattern desc = tryFilePattern + where + tryFilePattern path = do + fileExists <- doesFileExist path + if fileExists + then Left . FilePattern path <$> canonicalizePath path + else tryDirectoryPattern path + tryDirectoryPattern path = do + directoryExists <- doesDirectoryExist path + if directoryExists + then Right . DirectoryPattern path . splitDirectories <$> canonicalizePath path + else dieWithError path + dieWithError path = dieNoVerbosity $ + "Path passed to " ++ liquidHaskellVerifyField ++ + " for " ++ desc ++ + " does not exist: " ++ path + +filterSources :: String -> SourceFilter -> [FilePath] -> IO [FilePath] +filterSources _ All paths = return paths +filterSources desc (Whitelist filePatterns directoryPatterns) paths = do + results <- catMaybes <$> mapM (matchSourcePath filePatterns directoryPatterns) paths + + let consumedPatterns = snd <$> results + let (consumedFilePatterns, consumedDirectoryPatterns) = partitionEithers consumedPatterns + + let unconsumedFilePaths = (\\) (filePatternSource <$> filePatterns) + (filePatternSource <$> consumedFilePatterns) + let unconsumedDirectoryPaths = (\\) (directoryPatternSource <$> directoryPatterns) + (directoryPatternSource <$> consumedDirectoryPatterns) + let unconsumedPaths = unconsumedFilePaths ++ unconsumedDirectoryPaths + + unless (null unconsumedPaths) $ dieNoVerbosity $ + "Paths passed to " ++ liquidHaskellVerifyField ++ + " for " ++ desc ++ + " do not match any source files in the component:\n" ++ + unlines (("- " ++) <$> unconsumedPaths) + + return $ fst <$> results + +matchSourcePath + :: [FilePattern] + -> [DirectoryPattern] + -> FilePath + -> IO (Maybe (FilePath, SourcePattern)) +matchSourcePath filePatterns directoryPatterns path = do + path' <- canonicalizePath path + return $ (path, ) <$> (tryFilePatterns path' <|> tryDirectoryPatterns path') + where + tryFilePatterns path = + Left <$> find ((== path) . filePatternCompiled) filePatterns + tryDirectoryPatterns path = + let pathPieces = splitDirectories path + in Right <$> find ((`isPrefixOf` pathPieces) . directoryPatternCompiled) directoryPatterns + +-------------------------------------------------------------------------------- -- Construct GHC Options ------------------------------------------------------- -------------------------------------------------------------------------------- @@ -277,6 +371,14 @@ return $ maybe def flagDefault flag -------------------------------------------------------------------------------- +-- Cabal Field Handling -------------------------------------------------------- +-------------------------------------------------------------------------------- + +getAllCustomFieldValues :: String -> BuildInfo -> [String] +getAllCustomFieldValues field = + map snd . filter ((== field) . fst) . customFieldsBI + +-------------------------------------------------------------------------------- -- Splitting Command Line Arguments -------------------------------------------- -------------------------------------------------------------------------------- @@ -285,7 +387,7 @@ ParseOk _ out -> Right $ foldMap snd out ParseFailed err -> Left $ snd $ locatedErrorMsg err where - field = optsField liquidHaskellOptions + field = optsField liquidHaskellOptionsField (OtherCompiler "LiquidHaskell") id -- get :: opts -> opts (++) -- set :: opts -> opts -> opts