git.iko.soy/typeable/stackage2nix
on master help sign in
typeable/stackage2nix/src/Stack/Config.hs
193 lines 6.1 kB history raw
1{-# LANGUAGE ViewPatterns #-}
3module Stack.Config where
5import Control.Lens
6import Data.ByteString as BS
7import Data.Coerce
8import Data.List as L
9import Data.List.NonEmpty as NE
10import Data.Maybe
11import Data.Text as T
12import Data.Yaml
13import Network.URI
14import Stack.Config.Yaml as Yaml
15import Stack.Types
16import System.FilePath as FilePath
19newtype StackResolver = StackResolver { fromStackResolver :: Text }
20 deriving (Eq, Ord, Show)
22makePrisms ''StackResolver
24unStackResolver :: StackResolver -> String
25unStackResolver = T.unpack . fromStackResolver
27newtype Vcs = Vcs { fromVcs :: Text }
28 deriving (Eq, Ord, Show)
30data Repo = Repo
31 { _rVcs :: Vcs
32 , _rUri :: Text
33 , _rCommit :: Text
34 } deriving (Eq, Ord, Show)
36makeLenses ''Repo
38data PackageRevision
39 = PrSha256 Text
40 | PrRev Text
41 deriving (Eq, Ord, Show)
43makePrisms ''PackageRevision
45data PackageIndex = PackageIndex
46 { _piNameVersion :: Text
47 , _piRevision :: Maybe PackageRevision
48 } deriving (Eq, Ord, Show)
50makeLenses ''PackageIndex
52data PackageLocation
53 = PlIndex PackageIndex
54 | PlFilePath FilePath
55 | PlUri URI
56 | PlRepo Repo
57 deriving (Eq, Ord, Show)
59makePrisms ''PackageLocation
61data StackPackage = StackPackage
62 { _spLocation :: PackageLocation
63 , _spExtraDep :: Bool
64 -- | Subdirectory containing the cabal file if any specified.
65 , _spDir :: Maybe FilePath
66 } deriving (Eq, Ord, Show)
68makeLenses ''StackPackage
70data StackConfig = StackConfig
71 { _scResolver :: StackResolver
72 , _scPackages :: NonEmpty StackPackage
73 , _scExtraDeps :: [StackPackage]
74 } deriving (Eq, Ord, Show)
76makeLenses ''StackConfig
78scAllPackages :: Getter StackConfig (NonEmpty StackPackage)
79scAllPackages = to allPs
80 where
81 allPs sc = maybe ps ((<>) ps) (NE.nonEmpty ed)
82 where
83 ps = sc ^. scPackages
84 ed = sc ^. scExtraDeps
86fromYamlConfig :: Yaml.Config -> StackConfig
87fromYamlConfig c = StackConfig{..}
88 where
89 _scResolver = coerce $ c ^. cResolver
90 -- 'nub' replicates Stack behavior of having a Set of packages rather than list
91 _scPackages = NE.nub nePackages
92 _scExtraDeps = L.nub $ extraDeps ++ yamlExtraDeps
93 nePackages = fromMaybe (pure defaultPackage)
94 $ NE.nonEmpty packages
95 -- yaml packages section can contain extra-deps
96 (extraDeps, packages) = L.partition (view spExtraDep) yamlPackages
97 yamlPackages = L.concatMap NE.toList
98 $ fromYamlPackage packagesSimplePath False
99 <$> fromMaybe mempty (c ^. cPackages)
100 yamlExtraDeps = L.concatMap NE.toList
101 $ fromYamlPackage extraDepsSimplePath True
102 <$> fromMaybe mempty (c ^. cExtraDeps)
103 defaultPackage = StackPackage (PlFilePath ".") False Nothing
105-- | Simple string in a packages section can be an URI or FilePath location
106packagesSimplePath :: Text -> StackPackage
107packagesSimplePath t = StackPackage (parseSimplePath t) False Nothing
109-- | Parse location as URI or a FilePath
110parseSimplePath :: Text -> PackageLocation
111parseSimplePath (T.unpack -> p) = maybe (PlFilePath p) PlUri $ parseURI p
113-- | Simple string in an extra-deps section can be an URI or FilePath or PackageIndex name-version
114extraDepsSimplePath :: Text -> StackPackage
115extraDepsSimplePath t = StackPackage loc True Nothing
116 where
117 loc = maybe (parsePackageIndex t) PlUri $ parseURI (T.unpack t)
119-- TODO: support new package index format with hash and revision
120parsePackageIndex :: Text -> PackageLocation
121parsePackageIndex t = if isFilePath t
122 then PlFilePath (T.unpack t)
123 else PlIndex $ PackageIndex t Nothing
125-- Determine wether package is file path
126isFilePath :: Text -> Bool
127isFilePath = T.any (== FilePath.pathSeparator)
129-- | A single 'Yaml.Package' can result in multiple actual
130-- packages if it has multiple subdirs specified.
131fromYamlPackage
132 :: (Text -> StackPackage)
133 -> Bool
134 -> Yaml.Package
135 -> NonEmpty StackPackage
136fromYamlPackage fromSimple isExtraDep = \case
137 Yaml.PSimple p ->
138 pure (fromSimple p)
139 Yaml.PLocationSimple (Location p extraDep ms) ->
140 unroll ms $ StackPackage (parseSimplePath p) (fromMaybe False extraDep)
141 Yaml.PLocationGit loc ->
142 mkStackPackageRepo fromYamlGit loc
143 Yaml.PLocationHg loc ->
144 mkStackPackageRepo fromYamlHg loc
145 Yaml.PArchive a ->
146 unroll (a ^. aSubdirs) $ StackPackage (a ^. aArchive . to parseSimplePath) isExtraDep
147 Yaml.PNewGit ng -> unroll (ng ^. ngSubdirs)
148 $ StackPackage (PlRepo $ fromYamlNewGit ng) isExtraDep
149 Yaml.PNewHg nh -> unroll (nh ^. nhSubdirs)
150 $ StackPackage (PlRepo $ fromYamlNewHg nh) isExtraDep
151 where
152 mkStackPackageRepo f loc = unroll (loc ^. lSubdirs)
153 $ StackPackage (PlRepo (loc ^. lLocation . to f)) (fromMaybe isExtraDep $ loc ^. lExtraDep)
154 -- Each package gets a single directory with cabal file in it. If
155 -- it's not specified, path is empty.
156 unroll subs p = case subs of
157 Just (x : xs) -> NE.map (p . Just) (x :| xs)
158 _ -> p Nothing :| []
160fromYamlGit :: Yaml.Git -> Repo
161fromYamlGit yg = Repo
162 { _rVcs = Vcs "git"
163 , _rUri = yg ^. gGit
164 , _rCommit = yg ^. gCommit }
166fromYamlHg :: Yaml.Hg -> Repo
167fromYamlHg yh = Repo
168 { _rVcs = Vcs "hg"
169 , _rUri = yh ^. hHg
170 , _rCommit = yh ^. hCommit }
172fromYamlNewGit :: NewGit -> Repo
173fromYamlNewGit ng = Repo
174 { _rVcs = Vcs "git"
175 , _rUri = ng ^. ngGit
176 , _rCommit = ng ^. ngCommit }
178fromYamlNewHg :: NewHg -> Repo
179fromYamlNewHg nh = Repo
180 { _rVcs = Vcs "hg"
181 , _rUri = nh ^. nhHg
182 , _rCommit = nh ^. nhCommit }
184readStackConfig :: StackYaml -> IO (Either String StackConfig)
185readStackConfig stackYaml = do
186 let
187 relativeToStackYaml = \case
188 PlFilePath p -> PlFilePath $ stackYaml ^. syDirName </> p
189 packageLocation -> packageLocation
190 mkStackConfig = over (scPackages . traversed . spLocation) relativeToStackYaml
191 . over (scExtraDeps . traversed . spLocation) relativeToStackYaml
192 . fromYamlConfig
193 bimap show mkStackConfig . decodeEither' <$> BS.readFile (stackYaml ^. syFilePath)