diff options
| -rw-r--r-- | cabal-helper.cabal | 2 | ||||
| -rw-r--r-- | lib/Distribution/Helper.hs | 200 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Program/Stack.hs | 86 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 180 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types/RelativePath.hs | 39 |
5 files changed, 352 insertions, 155 deletions
diff --git a/cabal-helper.cabal b/cabal-helper.cabal index 3115522..324fd26 100644 --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -93,7 +93,9 @@ library CabalHelper.Compiletime.Compat.Version CabalHelper.Compiletime.Compile CabalHelper.Compiletime.Data + CabalHelper.Compiletime.Program.Stack CabalHelper.Compiletime.Types + CabalHelper.Compiletime.Types.RelativePath CabalHelper.Shared.Common CabalHelper.Shared.InterfaceTypes CabalHelper.Shared.Sandbox diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index edf71f7..ad77eb3 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -119,7 +119,9 @@ import Text.Show.Pretty import Prelude import CabalHelper.Compiletime.Compile +import qualified CabalHelper.Compiletime.Program.Stack as Stack import CabalHelper.Compiletime.Types +import CabalHelper.Compiletime.Types.RelativePath import CabalHelper.Shared.InterfaceTypes import CabalHelper.Shared.Sandbox import CabalHelper.Shared.Common @@ -127,6 +129,7 @@ import CabalHelper.Shared.Common import CabalHelper.Compiletime.Compat.Version import qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb ( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram) +import CabalHelper.Shared.Common import Distribution.System (buildPlatform) import Distribution.Text (display) @@ -139,160 +142,6 @@ import qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb import CabalHelper.Compiletime.Compat.Version import CabalHelper.Shared.Common - --- | The kind of project being managed by a 'QueryEnv' (pun intended). -data ProjType - = V1 -- ^ @cabal v1-build@ project, see 'DistDirV1' - | V2 -- ^ @cabal v2-build@ project, see 'DistDirV2' - --- | A project directory. The project type of a given directory can be --- determined by trying to access a set of marker files. See below. -data ProjDir (pt :: ProjType) where - -- | A @cabal v1-build@ project directory can be identified by one file - -- ending in @.cabal@ existing in the directory. More than one such files - -- existing is a user error. Note: For this project type the concepts of - -- project and package coincide. - ProjDirV1 :: FilePath -> ProjDir 'V1 - - -- | A @cabal v2-build@ project\'s marker file is called - -- @cabal.project@. This configuration file points to the packages that make - -- up this project. - ProjDirV2 :: FilePath -> ProjDir 'V2 - -data DistDir (pt :: ProjType) where - -- | Build directory for cabal /old-build/ aka. /v1-build/ aka. just - -- /build/. Planned to be superceeded by /v2-build/, see 'DistDirV2' for - -- that. - -- - -- You can tell a builddir is a /v1/ builddir by looking for a file - -- called @setup-config@ directly underneath it. - DistDirV1 :: FilePath -> DistDir 'V1 - - -- | Build directory for cabal /new-build/ aka. /v2-build/, as of the time - -- of this writing it is usually called @dist-newstyle/@ but this will - -- presumably change once it becomes the default /build/ command. - -- - -- You can tell a builddir is a /v2/ builddir by trying to access the path - -- @cache/plan.json@ directly underneath it. - DistDirV2 :: FilePath -> DistDir 'V2 - --- | Environment for running a 'Query' value. The real constructor is --- not exposed, use the 'mkQueryEnv' smart constructor instead. The field --- accessors are exported and may be used to override the defaults, see below. -type QueryEnv (proj_type :: ProjType) - = QueryEnvI (QueryCache proj_type) proj_type - -data QueryEnvI cache (proj_type :: ProjType) = QueryEnv - { qeReadProcess - :: Maybe FilePath -> FilePath -> [String] -> String -> IO String - -- ^ Field accessor for 'QueryEnv'. Function used to to start - -- processes. Useful if you need to, for example, redirect standard error - -- output away from the user\'s terminal. - - , qePrograms :: Programs - -- ^ Field accessor for 'QueryEnv'. - - , qeProjectDir :: ProjDir proj_type - -- ^ Field accessor for 'QueryEnv'. Defines path to the project directory, - -- i.e. a directory containing a @cabal.project@ file - - , qeDistDir :: DistDir proj_type - -- ^ Field accessor for 'QueryEnv'. Defines path to the @dist/@ or - -- @dist-newstyle/@ directory, aka. /builddir/ in Cabal terminology. - - , qeCacheRef :: IORef cache - -- ^ Cache for query results, only accessible when type parameter @cache@ is - -- instantiated and not forall quantified. - } - -data QueryCache pt = QueryCache - { qcProjInfo :: !(Maybe (ProjInfo pt)) - , qcUnitInfos :: !(Map DistDirLib UnitInfo) - } - -newtype DistDirLib = DistDirLib FilePath - deriving (Eq, Ord, Read, Show) - --- | Abstractly speaking a Unit consists of a set of components (exes, libs, --- tests etc.) which are managed by an instance of the Cabal build system. The --- distinction between a Unit and a set of components is somewhat hard to --- explain if you're not already familliar with the concept from --- cabal-install. Luckily for most purposes the details may be ignored. --- --- We merely use the concept of a Unit for caching purposes. It is necessary to --- extract the information on all components in a Unit at the same time as we --- must load all of it into memory before extracting any of it. --- --- As opposed to components, different 'Unit's can be queried independently --- since their on-disk information is stored separately. -data Unit = Unit - { uUnitId :: !UnitId - , uPackageDir :: !FilePath - , uDistDir :: !DistDirLib - } - -newtype UnitId = UnitId String - deriving (Eq, Ord, Read, Show) - --- | The information extracted from a 'Unit's on-disk configuration. -data UnitInfo = UnitInfo - { uiUnitId :: !UnitId - -- ^ A unique identifier of this init within the project. - - , uiComponents :: !(Map ChComponentName ChComponentInfo) - -- ^ The components of the unit: libraries, executables, test-suites, - -- benchmarks and so on. - - , uiCompilerVersion :: !(String, Version) - -- ^ The version of GHC the unit is configured to use - - , uiPackageDbStack :: !([ChPkgDb]) - -- ^ List of package databases to use. - - , uiPackageFlags :: !([(String, Bool)]) - -- ^ Flag definitions from cabal file - - , uiConfigFlags :: ![(String, Bool)] - -- ^ Flag assignments from active configuration - - , uiNonDefaultConfigFlags :: ![(String, Bool)] - -- ^ Flag assignments from setup-config which differ from the default - -- setting. This can also include flags which cabal decided to modify, - -- i.e. don't rely on these being the flags set by the user directly. - - , uiModTimes :: !UnitModTimes - } deriving (Eq, Ord, Read, Show) - -data ProjInfo pt where - ProjInfoV1 :: - { piV1ProjConfModTimes :: !(ProjConfModTimes 'V1) - } -> ProjInfo 'V1 - - ProjInfoV2 :: - { piV2ProjConfModTimes :: !(ProjConfModTimes 'V2) - , piV2Plan :: !PlanJson - , piV2PlanModTime :: !EpochTime - } -> ProjInfo 'V2 - -data ProjConfModTimes pt where - ProjConfModTimesV1 - :: !(FilePath, EpochTime) -> ProjConfModTimes 'V1 - ProjConfModTimesV2 - :: !([(FilePath, EpochTime)]) -> ProjConfModTimes 'V2 - -deriving instance Eq (ProjConfModTimes pt) - -piProjConfModTimes :: ProjInfo pt -> ProjConfModTimes pt -piProjConfModTimes ProjInfoV1 {piV1ProjConfModTimes} = - piV1ProjConfModTimes -piProjConfModTimes ProjInfoV2 {piV2ProjConfModTimes} = - piV2ProjConfModTimes - -data UnitModTimes = UnitModTimes - { umtCabalFile :: !(FilePath, EpochTime) - , umtSetupConfig :: !(FilePath, EpochTime) - } deriving (Eq, Ord, Read, Show) - -- | A lazy, cached, query against a package's Cabal configuration. Use -- 'runQuery' to execute it. newtype Query pt a = Query @@ -332,6 +181,14 @@ mkQueryEnv projdir distdir = do , qeCacheRef = cr } +piProjConfModTimes :: ProjInfo pt -> ProjConfModTimes pt +piProjConfModTimes ProjInfoV1 {piV1ProjConfModTimes} = + piV1ProjConfModTimes +piProjConfModTimes ProjInfoV2 {piV2ProjConfModTimes} = + piV2ProjConfModTimes +piProjConfModTimes ProjInfoStack {piStackProjConfModTimes} = + piStackProjConfModTimes + piUnits :: DistDir pt -> ProjInfo pt -> [Unit] piUnits (DistDirV1 distdir) (ProjInfoV1 (ProjConfModTimesV1 (cabal_file, _))) = (:[]) $ Unit @@ -361,6 +218,7 @@ piUnits _ ProjInfoV2{..} = Just $ Left u takeunit _ = Nothing +piUnits DistDirStack{} ProjInfoStack{..} = piStackUnits -- | Find files relevant to the project-scope configuration. Depending on the @@ -380,6 +238,8 @@ projConfModTimes (ProjDirV2 projdir) = do [ "cabal.project.local" , "cabal.project.freeze" ] +projConfModTimes (ProjDirStack projdir) = do + ProjConfModTimesStack <$> getFileModTime (projdir </> "stack.yml") getUnitModTimes :: Unit -> IO UnitModTimes getUnitModTimes Unit { uDistDir=DistDirLib distdirv1, uPackageDir=pkgdir } = do @@ -518,12 +378,21 @@ shallowReconfigureProject QueryEnv _ <- liftIO $ qeReadProcess (Just projdir) (cabalProgram qePrograms) ["v2-build", "--dry-run", "all"] "" return () +shallowReconfigureProject QueryEnv + { qeProjectDir = ProjDirStack _projdir, .. } = + -- TODO: do we need to do anything here? Maybe package.yaml support needs to + -- do stuff here? + return () reconfigureUnit :: QueryEnvI c pt -> Unit -> IO () reconfigureUnit QueryEnv{qeDistDir=DistDirV1{}, ..} Unit{uPackageDir=_} = do return () reconfigureUnit QueryEnv{qeDistDir=DistDirV2{}, ..} Unit{uPackageDir=_} = do return () +reconfigureUnit QueryEnv{qeDistDir=DistDirStack{}, ..} Unit{uPackageDir} = do + _ <- liftIO $ qeReadProcess (Just uPackageDir) (stackProgram qePrograms) + ["stack", "build", "--only-configure", "."] "" + return () findCabalFile :: ProjDir 'V1 -> IO FilePath findCabalFile (ProjDirV1 pkgdir) = do @@ -549,6 +418,15 @@ readProjInfo qe conf_files = do , piV2Plan = plan , piV2PlanModTime = plan_mtime } + (ProjDirStack{} , DistDirStack{}) -> do + cabal_files <- Stack.listPackageCabalFiles qe + units <- mapM (Stack.getUnit qe) cabal_files + proj_paths <- Stack.projPaths qe + return $ ProjInfoStack + { piStackProjConfModTimes = conf_files + , piStackUnits = units + , piStackProjPaths = proj_paths + } readUnitInfo :: QueryEnvI c pt -> FilePath -> Unit -> IO UnitInfo readUnitInfo @@ -720,6 +598,20 @@ wrapper' projdir (Just (plan, distdir)) (distdir </> "cache") +wrapper' + (ProjDirStack projdir) + (DistDirStack mworkdir) + ProjInfoStack{piStackProjPaths=StackProjPaths{sppGlobalPkgDb}} + = do + -- Stack also just picks whatever version ghc-pkg spits out, see + -- Stack.GhcPkg.getCabalPkgVer. + Just (cabalVer:_) <- runMaybeT $ listCabalVersions' (Just sppGlobalPkgDb) + let workdir = fromMaybe ".stack-work" $ unRelativePath <$> mworkdir + compileHelper' cabalVer + (Just sppGlobalPkgDb) + projdir + Nothing + (projdir </> workdir) compileHelper' :: Env diff --git a/src/CabalHelper/Compiletime/Program/Stack.hs b/src/CabalHelper/Compiletime/Program/Stack.hs new file mode 100644 index 0000000..4751f0a --- /dev/null +++ b/src/CabalHelper/Compiletime/Program/Stack.hs @@ -0,0 +1,86 @@ +-- cabal-helper: Simple interface to Cabal's configuration state +-- Copyright (C) 2018 Daniel Gröber <cabal-helper@dxld.at> +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see <http://www.gnu.org/licenses/>. + +{-| +Module : CabalHelper.Compiletime.Program.Stack +Description : Stack program interface +License : GPL-3 +-} + +{-# LANGUAGE GADTs, DataKinds #-} + +module CabalHelper.Compiletime.Program.Stack where + +import Control.Monad +import Data.Char +import Data.List hiding (filter) +import Data.String +import Data.Maybe +import Data.Function +import System.FilePath hiding ((<.>)) +import Prelude + +import CabalHelper.Compiletime.Types +import CabalHelper.Compiletime.Types.RelativePath + +getUnit :: QueryEnvI c 'Stack -> CabalFile -> IO Unit +getUnit qe (CabalFile cabal_file) = do + let pkgdir = takeDirectory cabal_file + let pkg_name = dropExtension $ takeFileName cabal_file + look <- paths qe pkgdir + let distdirv1 = look "dist-dir:" + return $ Unit + { uUnitId = UnitId pkg_name + , uPackageDir = pkgdir + , uDistDir = DistDirLib distdirv1 + } + +-- TODO: patch ghc/ghc-pkg program paths like in ghc-mod when using stack so +-- compilation logic works even if no system compiler is installed + +packageDistDir :: QueryEnvI c 'Stack -> FilePath -> IO FilePath +packageDistDir qe pkgdir = do + look <- paths qe pkgdir + return $ look "dist-dir:" + +projPaths :: QueryEnvI c 'Stack -> IO StackProjPaths +projPaths qe@QueryEnv {qeProjectDir=ProjDirStack projdir} = do + look <- paths qe projdir + return StackProjPaths + { sppGlobalPkgDb = PackageDbDir $ look "global-pkg-db:" + , sppSnapPkgDb = PackageDbDir $ look "snapshot-pkg-db:" + , sppLocalPkgDb = PackageDbDir $ look "local-pkg-db:" + } + +paths :: QueryEnvI c 'Stack + -> FilePath + -> IO (String -> FilePath) +paths qe dir = do + out <- qeReadProcess qe (Just dir) (stackProgram $ qePrograms qe) + (workdirArg qe ++ [ "path" ]) "" + return $ \k -> let Just x = lookup k $ map split $ lines out in x + where + split l = let (key, ' ' : val) = span (not . isSpace) l in (key, val) + +listPackageCabalFiles :: QueryEnvI c 'Stack -> IO [CabalFile] +listPackageCabalFiles qe@QueryEnv{qeProjectDir=ProjDirStack projdir} = do + out <- qeReadProcess qe (Just projdir) (stackProgram $ qePrograms qe) + [ "ide", "packages", "--cabal-files" ] "" + return $ map CabalFile $ lines out + +workdirArg :: QueryEnvI c 'Stack -> [String] +workdirArg QueryEnv{qeDistDir=DistDirStack mworkdir} = + maybeToList $ ("--work-dir="++) . unRelativePath <$> mworkdir diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 843a886..58e90b1 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -34,8 +34,182 @@ import Data.Typeable import Data.Map.Strict (Map) import GHC.Generics import System.Posix.Types +import CabalHelper.Compiletime.Types.RelativePath import CabalHelper.Shared.InterfaceTypes + +-- | The kind of project being managed by a 'QueryEnv' (pun intended). +data ProjType + = V1 -- ^ @cabal v1-build@ project, see 'DistDirV1' + | V2 -- ^ @cabal v2-build@ project, see 'DistDirV2' + | Stack -- ^ @stack@ project. + +-- | A project directory. The project type of a given directory can be +-- determined by trying to access a set of marker files. See below. +data ProjDir (pt :: ProjType) where + -- | A @cabal v1-build@ project directory can be identified by one file + -- ending in @.cabal@ existing in the directory. More than one such files + -- existing is a user error. Note: For this project type the concepts of + -- project and package coincide. + ProjDirV1 :: FilePath -> ProjDir 'V1 + + -- | A @cabal v2-build@ project\'s marker file is called + -- @cabal.project@. This configuration file points to the packages that make + -- up this project. + ProjDirV2 :: FilePath -> ProjDir 'V2 + + -- | A @stack@ project\'s marker file is called @stack.yaml@. This + -- configuration file points to the packages that make up this project. + ProjDirStack :: FilePath -> ProjDir 'Stack + +data DistDir (pt :: ProjType) where + -- | Build directory for cabal /old-build/ aka. /v1-build/ aka. just + -- /build/. Planned to be superceeded by /v2-build/, see 'DistDirV2' for + -- that. + -- + -- You can tell a builddir is a /v1/ builddir by looking for a file + -- called @setup-config@ directly underneath it. + DistDirV1 :: FilePath -> DistDir 'V1 + + -- | Build directory for cabal /new-build/ aka. /v2-build/, as of the time + -- of this writing it is usually called @dist-newstyle/@ but this will + -- presumably change once it becomes the default /build/ command. + -- + -- You can tell a builddir is a /v2/ builddir by trying to access the path + -- @cache/plan.json@ directly underneath it. + DistDirV2 :: FilePath -> DistDir 'V2 + + -- | Build directory for stack, aka. /work-dir/. Optionally override Stack's + -- /work-dir/. If you just want to use Stack's default set to @Nothing@ + DistDirStack :: Maybe RelativePath -> DistDir 'Stack + +-- | Environment for running a 'Query' value. The real constructor is +-- not exposed, use the 'mkQueryEnv' smart constructor instead. The field +-- accessors are exported and may be used to override the defaults, see below. +type QueryEnv (proj_type :: ProjType) + = QueryEnvI (QueryCache proj_type) proj_type + +data QueryEnvI cache (proj_type :: ProjType) = QueryEnv + { qeReadProcess + :: Maybe FilePath -> FilePath -> [String] -> String -> IO String + -- ^ Field accessor for 'QueryEnv'. Function used to to start + -- processes. Useful if you need to, for example, redirect standard error + -- output away from the user\'s terminal. + + , qePrograms :: Programs + -- ^ Field accessor for 'QueryEnv'. + + , qeProjectDir :: ProjDir proj_type + -- ^ Field accessor for 'QueryEnv'. Defines path to the project directory, + -- i.e. a directory containing a @cabal.project@ file + + , qeDistDir :: DistDir proj_type + -- ^ Field accessor for 'QueryEnv'. Defines path to the @dist/@ or + -- @dist-newstyle/@ directory, aka. /builddir/ in Cabal terminology. + + , qeCacheRef :: IORef cache + -- ^ Cache for query results, only accessible when type parameter @cache@ is + -- instantiated and not forall quantified. + } + +data QueryCache pt = QueryCache + { qcProjInfo :: !(Maybe (ProjInfo pt)) + , qcUnitInfos :: !(Map DistDirLib UnitInfo) + } + +newtype DistDirLib = DistDirLib FilePath + deriving (Eq, Ord, Read, Show) + +-- | Abstractly speaking a Unit consists of a set of components (exes, libs, +-- tests etc.) which are managed by an instance of the Cabal build system. The +-- distinction between a Unit and a set of components is somewhat hard to +-- explain if you're not already familliar with the concept from +-- cabal-install. Luckily for most purposes the details may be ignored. +-- +-- We merely use the concept of a Unit for caching purposes. It is necessary to +-- extract the information on all components in a Unit at the same time as we +-- must load all of it into memory before extracting any of it. +-- +-- As opposed to components, different 'Unit's can be queried independently +-- since their on-disk information is stored separately. +data Unit = Unit + { uUnitId :: !UnitId + , uPackageDir :: !FilePath + , uDistDir :: !DistDirLib + } + +newtype UnitId = UnitId String + deriving (Eq, Ord, Read, Show) + +-- | The information extracted from a 'Unit's on-disk configuration. +data UnitInfo = UnitInfo + { uiUnitId :: !UnitId + -- ^ A unique identifier of this init within the project. + + , uiComponents :: !(Map ChComponentName ChComponentInfo) + -- ^ The components of the unit: libraries, executables, test-suites, + -- benchmarks and so on. + + , uiCompilerVersion :: !(String, Version) + -- ^ The version of GHC the unit is configured to use + + , uiPackageDbStack :: !([ChPkgDb]) + -- ^ List of package databases to use. + + , uiPackageFlags :: !([(String, Bool)]) + -- ^ Flag definitions from cabal file + + , uiConfigFlags :: ![(String, Bool)] + -- ^ Flag assignments from active configuration + + , uiNonDefaultConfigFlags :: ![(String, Bool)] + -- ^ Flag assignments from setup-config which differ from the default + -- setting. This can also include flags which cabal decided to modify, + -- i.e. don't rely on these being the flags set by the user directly. + + , uiModTimes :: !UnitModTimes + } deriving (Eq, Ord, Read, Show) + +data ProjInfo pt where + ProjInfoV1 :: + { piV1ProjConfModTimes :: !(ProjConfModTimes 'V1) + } -> ProjInfo 'V1 + + ProjInfoV2 :: + { piV2ProjConfModTimes :: !(ProjConfModTimes 'V2) + , piV2Plan :: !PlanJson + , piV2PlanModTime :: !EpochTime + } -> ProjInfo 'V2 + + ProjInfoStack :: + { piStackProjConfModTimes :: !(ProjConfModTimes 'Stack) + , piStackUnits :: ![Unit] + , piStackProjPaths :: !StackProjPaths + } -> ProjInfo 'Stack + +data ProjConfModTimes pt where + ProjConfModTimesV1 + :: !(FilePath, EpochTime) -> ProjConfModTimes 'V1 + ProjConfModTimesV2 + :: !([(FilePath, EpochTime)]) -> ProjConfModTimes 'V2 + ProjConfModTimesStack + :: !(FilePath, EpochTime) -> ProjConfModTimes 'Stack + +deriving instance Eq (ProjConfModTimes pt) + +data UnitModTimes = UnitModTimes + { umtCabalFile :: !(FilePath, EpochTime) + , umtSetupConfig :: !(FilePath, EpochTime) + } deriving (Eq, Ord, Read, Show) + +newtype CabalFile = CabalFile FilePath + +data StackProjPaths = StackProjPaths + { sppGlobalPkgDb :: !PackageDbDir + , sppSnapPkgDb :: !PackageDbDir + , sppLocalPkgDb :: !PackageDbDir + } + type Verbose = (?verbose :: Bool) type Progs = (?progs :: Programs) -- TODO: rname to `CompEnv` or something @@ -49,6 +223,9 @@ data Programs = Programs { -- | The path to the @cabal@ program. cabalProgram :: FilePath, + -- | The path to the @stack@ program. + stackProgram :: FilePath, + -- | The path to the @ghc@ program. ghcProgram :: FilePath, @@ -60,7 +237,8 @@ data Programs = Programs { -- | By default all programs use their unqualified names, i.e. they will be -- searched for on @PATH@. defaultPrograms :: Programs -defaultPrograms = Programs "cabal" "ghc" "ghc-pkg" +defaultPrograms = Programs "cabal" "stack" "ghc" "ghc-pkg" + data CompileOptions = CompileOptions { oVerbose :: Bool diff --git a/src/CabalHelper/Compiletime/Types/RelativePath.hs b/src/CabalHelper/Compiletime/Types/RelativePath.hs new file mode 100644 index 0000000..bfc29bf --- /dev/null +++ b/src/CabalHelper/Compiletime/Types/RelativePath.hs @@ -0,0 +1,39 @@ +-- cabal-helper: Simple interface to Cabal's configuration state +-- Copyright (C) 2018 Daniel Gröber <cabal-helper@dxld.at> +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see <http://www.gnu.org/licenses/>. + +{-| +Module : CabalHelper.Compiletime.Types.RelativePath +License : GPL-3 +-} + +module CabalHelper.Compiletime.Types.RelativePath + ( RelativePath + , mkRelativePath + , unRelativePath + ) where + +import System.FilePath + +-- | A path guaranteed to be relative. The constructor is not exposed, use the +-- 'mkRelativePath' smart constructor. +newtype RelativePath = RelativePath { unRelativePath :: FilePath } + +-- | Smart constructor for 'RelativePath'. Checks if the given path is absolute +-- and throws 'UserError' if not. +mkRelativePath :: FilePath -> RelativePath +mkRelativePath dir + | isAbsolute dir = RelativePath dir + | otherwise = error "mkRelativePath: the path given was absolute!" |