diff options
Diffstat (limited to 'CabalHelper')
| -rw-r--r-- | CabalHelper/Main.hs | 55 | ||||
| -rw-r--r-- | CabalHelper/Types.hs | 5 |
2 files changed, 57 insertions, 3 deletions
diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs index 9dca50d..48a6ed4 100644 --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -19,8 +19,12 @@ import Distribution.Simple.Utils (cabalVersion) import Distribution.Simple.Configure -import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId) +import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId, + packageName, packageVersion) import Distribution.PackageDescription (PackageDescription, + GenericPackageDescription(..), + Flag(..), + FlagName(..), FlagAssignment, Executable(..), Library(..), @@ -65,9 +69,11 @@ import Distribution.Utils.NubList #endif import Control.Applicative ((<$>)) +import Control.Arrow (first, (&&&)) import Control.Monad import Control.Exception (catch, PatternMatchFail(..)) import Data.List +import qualified Data.Map as Map import Data.Maybe import Data.Monoid import Data.IORef @@ -92,6 +98,10 @@ usage = do ++"PROJ_DIR DIST_DIR [--with-* ...] (\n" ++" version\n" ++" | print-lbi [--human]\n" + ++" | package-id\n" + ++" | flags\n" + ++" | config-flags\n" + ++" | non-default-config-flags\n" ++" | write-autogen-files\n" ++" | compiler-version\n" ++" | ghc-options [--with-inplace]\n" @@ -107,6 +117,10 @@ usage = do commands :: [String] commands = [ "print-bli" + , "package-id" + , "flags" + , "config-flags" + , "non-default-config-flags" , "write-autogen-files" , "compiler-version" , "ghc-options" @@ -131,8 +145,12 @@ main = do errMsg $ "distdir '"++distdir++"' does not exist" exitFailure + -- ghc-mod will catch multiple cabal files existing before we get here + [cfile] <- filter isCabalFile <$> getDirectoryContents projdir + v <- maybe silent (const deafening) . lookup "GHC_MOD_DEBUG" <$> getEnvironment lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir + gpd <- unsafeInterleaveIO $ readPackageDescription v (projdir </> cfile) let pd = localPkgDescr lbi let lvd = (lbi, v, distdir) @@ -162,6 +180,30 @@ main = do print =<< flip mapM cmds $$ \cmd -> do case cmd of + "package-id":[] -> + return $ Just $ + ChResponseVersion (display (packageName pd)) (packageVersion pd) + + "flags":[] -> do + return $ Just $ ChResponseFlags $ sort $ + map (flagName' &&& flagDefault) $ genPackageFlags gpd + + "config-flags":[] -> do + return $ Just $ ChResponseFlags $ sort $ + map (first unFlagName') $ configConfigurationsFlags $ configFlags lbi + + "non-default-config-flags":[] -> do + let flagDefinitons = genPackageFlags gpd + flagAssgnments = configConfigurationsFlags $ configFlags lbi + nonDefaultFlags = + [ (fn, v) + | MkFlag {flagName=FlagName fn, flagDefault=dv} <- flagDefinitons + , (FlagName fn', v) <- flagAssgnments + , fn == fn' + , v /= dv + ] + return $ Just $ ChResponseFlags $ sort nonDefaultFlags + "write-autogen-files":[] -> do -- calls writeAutogenFiles initialBuildSteps distdir pd lbi v @@ -256,6 +298,8 @@ main = do _ -> errMsg "Invalid usage!" >> usage >> exitFailure +flagName' = unFlagName' . flagName +unFlagName' (FlagName n) = n getLibrary :: PackageDescription -> Library getLibrary pd = unsafePerformIO $ do @@ -397,3 +441,12 @@ renderGhcOptions' lbi v opts = do #else return $ renderGhcOptions (compiler lbi) opts #endif + +isCabalFile :: FilePath -> Bool +isCabalFile f = takeExtension' f == ".cabal" + +takeExtension' :: FilePath -> String +takeExtension' p = + if takeFileName p == takeExtension p + then "" -- just ".cabal" is not a valid cabal file + else takeExtension p diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs index c5282d7..6b2ac70 100644 --- a/CabalHelper/Types.hs +++ b/CabalHelper/Types.hs @@ -35,9 +35,10 @@ data ChResponse | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)] | ChResponseList [String] | ChResponsePkgDbs [ChPkgDb] - | ChResponseLbi String - | ChResponseVersion String Version + | ChResponseLbi String + | ChResponseVersion String Version | ChResponseLicenses [(String, [(String, Version)])] + | ChResponseFlags [(String, Bool)] deriving (Eq, Ord, Read, Show, Generic) data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but |