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