{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module LiquidHaskell.Cabal
(
liquidHaskellMain
, liquidHaskellMainHooks
, liquidHaskellHooks
, simpleUserHooksLH
, enableLiquid
, runLiquidPostBuild
, runLiquidPostTest
, liquidHaskellPostBuildHook
, liquidHaskellPostTestHook
) where
import Control.Applicative
import Control.Exception
import Control.Monad
import Data.Either
import Data.Foldable
import Data.List
import Data.Maybe
import Distribution.Types.UnqualComponentName
import Distribution.ModuleName hiding (main)
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec
import Distribution.ParseUtils
import Distribution.Simple
import Distribution.Simple.GHC
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Program.Db
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup as DS
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Utils.NubList
import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist)
import System.FilePath
import Debug.Trace
liquidHaskellMain :: IO ()
liquidHaskellMain = defaultMainWithHooks liquidHaskellHooks
liquidHaskellMainHooks :: IO ()
liquidHaskellMainHooks = defaultMainWithHooks $
simpleUserHooks { postBuild = liquidHaskellPostBuildHook }
liquidHaskellHooks :: UserHooks
liquidHaskellHooks = runLiquidPostBuild simpleUserHooksLH
simpleUserHooksLH :: UserHooks
simpleUserHooksLH = enableLiquid simpleUserHooks
enableLiquid :: UserHooks -> UserHooks
enableLiquid hooks = hooks { hookedPrograms = liquidProgram : hookedPrograms hooks }
runLiquidPostBuild :: UserHooks -> UserHooks
runLiquidPostBuild hooks = hooks { postBuild = liquidHaskellPostBuildHook
, buildHook = quietWhenNoCode (buildHook hooks)
}
runLiquidPostTest :: UserHooks -> UserHooks
runLiquidPostTest hooks = hooks { postTest = liquidHaskellPostTestHook
}
liquidHaskellPostBuildHook :: Args -> BuildFlags-> PackageDescription -> LocalBuildInfo -> IO ()
liquidHaskellPostBuildHook args flags pd lbi = liquidHaskellHook args (buildVerbosity flags) pd lbi
liquidHaskellPostTestHook :: Args -> TestFlags-> PackageDescription -> LocalBuildInfo -> IO ()
liquidHaskellPostTestHook args flags pd lbi = liquidHaskellHook args (testVerbosity flags) pd lbi
liquidHaskellHook :: Args -> DS.Flag Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
liquidHaskellHook args verbosityFlag pkg lbi = do
enabled <- isFlagEnabled "liquidhaskell" lbi
when enabled $ do
let verbosity = fromFlag verbosityFlag
withAllComponentsInBuildOrder pkg lbi $ \component clbi ->
case component of
CLib lib -> do
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
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 ()
liquidHaskellOptionsField :: String
liquidHaskellOptionsField = "x-liquidhaskell-options"
liquidHaskellVerifyField :: String
liquidHaskellVerifyField = "x-liquidhaskell-verify"
type CabalBuildHook = PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
quietWhenNoCode :: CabalBuildHook -> CabalBuildHook
quietWhenNoCode hook pd lbi uh bf = do
hook pd lbi uh bf `catch` continueWhenNoCode
where
noCode = any (== "-fno-code") (concatMap snd (buildProgramArgs bf))
continueWhenNoCode
| noCode = \(e :: SomeException) -> return ()
| otherwise = throw
verifyComponent :: Verbosity -> LocalBuildInfo -> ComponentLocalBuildInfo
-> BuildInfo -> String -> [FilePath] -> IO ()
verifyComponent verbosity lbi clbi bi desc sources = do
userArgs <- getUserArgs desc bi
let ghcFlags = makeGhcFlags verbosity lbi clbi bi
let args = concat
[ ("--ghc-option=" ++) <$> ghcFlags
, ("--c-files=" ++) <$> cSources bi
, userArgs
, sources
]
liquid <- requireLiquidProgram verbosity $ withPrograms lbi
runProgram verbosity liquid args
getUserArgs :: String -> BuildInfo -> IO [ProgArg]
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
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
makeGhcFlags
:: Verbosity
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> BuildInfo
-> [String]
makeGhcFlags verbosity lbi clbi bi =
#if MIN_VERSION_Cabal(1,24,0)
renderGhcOptions (compiler lbi) (hostPlatform lbi)
#else
renderGhcOptions (compiler lbi)
#endif
$ sanitizeGhcOptions
$ componentGhcOptions verbosity lbi bi clbi (buildDir lbi)
sanitizeGhcOptions :: GhcOptions -> GhcOptions
sanitizeGhcOptions opts =
opts { ghcOptNoLink = NoFlag
, ghcOptOptimisation = NoFlag
, ghcOptProfilingMode = NoFlag
#if MIN_VERSION_Cabal(1,20,0)
, ghcOptNumJobs = NoFlag
#endif
#if MIN_VERSION_Cabal(1,22,0)
, ghcOptHPCDir = NoFlag
#endif
, ghcOptGHCiScripts = mempty -- may interfere with interactive mode?
, ghcOptExtra = filter (not . isPrefixOf "-O") (ghcOptExtra opts)
}
--------------------------------------------------------------------------------
-- Find Component Haskell Sources ----------------------------------------------
--------------------------------------------------------------------------------
findLibSources :: Library -> IO [FilePath]
findLibSources lib = findModuleSources (libBuildInfo lib) (exposedModules lib)
findExeSources :: Executable -> IO [FilePath]
findExeSources exe = do
moduleSrcs <- findModuleSources (buildInfo exe) []
mainSrc <- findFile (hsSourceDirs (buildInfo exe)) (modulePath exe)
return (mainSrc : moduleSrcs)
findModuleSources :: BuildInfo -> [ModuleName] -> IO [FilePath]
findModuleSources bi exposed = do
let modules = exposed ++ otherModules bi
hsSources <- mapM (findModuleSource ["hs", "lhs"] bi) modules
hsBootSources <- mapM (findModuleSource ["hs-boot", "lhs-boot"] bi) modules
return $ catMaybes (hsSources ++ hsBootSources)
findModuleSource :: [String] -> BuildInfo -> ModuleName -> IO (Maybe FilePath)
findModuleSource suffixes bi mod =
findFileWithExtension suffixes (hsSourceDirs bi) (toFilePath mod)
--------------------------------------------------------------------------------
-- Locating the LiquidHaskell Binary -------------------------------------------
--------------------------------------------------------------------------------
requireLiquidProgram :: Verbosity -> ProgramDb -> IO ConfiguredProgram
requireLiquidProgram verbosity db =
fst <$> requireProgram verbosity liquidProgram db
liquidProgram :: Program
liquidProgram = simpleProgram "liquid"
--------------------------------------------------------------------------------
-- Cabal Flag Handling ---------------------------------------------------------
--------------------------------------------------------------------------------
isFlagEnabled :: String -> LocalBuildInfo -> IO Bool
isFlagEnabled name lbi = case getOverriddenFlagValue name lbi of
Just enabled -> return enabled
Nothing -> getDefaultFlagValue name lbi False
getOverriddenFlagValue :: String -> LocalBuildInfo -> Maybe Bool
getOverriddenFlagValue name lbi = lookupFlagAssignment (mkFlagName name) overriddenFlags
where
overriddenFlags = configConfigurationsFlags (configFlags lbi)
getDefaultFlagValue :: String -> LocalBuildInfo -> Bool -> IO Bool
getDefaultFlagValue name lbi def = case pkgDescrFile lbi of
Nothing -> return def
Just cabalFile -> do
descr <- readGenericPackageDescription silent cabalFile
let flag = find ((mkFlagName name ==) . flagName) $ genPackageFlags descr
return $ maybe def flagDefault flag
--------------------------------------------------------------------------------
-- Cabal Field Handling --------------------------------------------------------
--------------------------------------------------------------------------------
getAllCustomFieldValues :: String -> BuildInfo -> [String]
getAllCustomFieldValues field =
map snd . filter ((== field) . fst) . customFieldsBI
--------------------------------------------------------------------------------
-- Splitting Command Line Arguments --------------------------------------------
--------------------------------------------------------------------------------
parseCommandArgs :: String -> Either String [ProgArg]
parseCommandArgs cmd = case fieldSet field 0 cmd [] of
ParseOk _ out -> Right $ foldMap snd out
ParseFailed err -> Left $ snd $ locatedErrorMsg err
where
field = optsField liquidHaskellOptionsField
(OtherCompiler "LiquidHaskell")
id -- get :: opts -> opts
(++) -- set :: opts -> opts -> opts
-- where opts=[(CompilerFlavor,[String])]