git.iko.soy/typeable/cabal2nix
on d19558d help sign in
typeable/cabal2nix/hackage2nix/src/Stackage.hs
100 lines 3.4 kB history raw
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE StandaloneDeriving #-}
3{-# OPTIONS_GHC -fno-warn-orphans #-}
5module Stackage where
7import Control.DeepSeq.Generics
8import Control.Monad
9import Control.Monad.Par.Combinator
10import Control.Monad.Par.IO
11import Control.Monad.Trans
12import Data.List
13import Data.List.Split
14import Data.Map as Map
15import Data.Maybe
16import Data.Time.Calendar
17import Data.Yaml
18import Distribution.Compiler
19import Distribution.Nixpkgs.Haskell.OrphanInstances ( )
20import Distribution.Package
21import Distribution.PackageDescription
22import Distribution.Version
23import GHC.Generics ( Generic )
24import Stackage.Types hiding ( display )
25import System.Directory
26import System.FilePath
27import Text.PrettyPrint.HughesPJClass
29data Spec = Spec
30 { version :: Version
31 , flagOverrides :: Map FlagName Bool
32 , runTests :: Bool
33 , runHaddock :: Bool
34 , runLinuxBuilds :: Bool
35 }
36 deriving (Show, Generic)
38instance Eq Spec where
39 a == b = version a == version b
41instance Ord Spec where
42 compare a b = compare (version a) (version b)
44data Snapshot = Snapshot
45 { snapshot :: SnapshotType
46 , compiler :: CompilerId
47 , corePackages :: Map PackageName Version
48 , packages :: Map PackageName Spec
49 }
50 deriving (Show, Generic)
52deriving instance Generic SnapshotType
53instance NFData Spec where
54instance NFData Snapshot where
55instance NFData SnapshotType where
57instance Pretty SnapshotType where
58 pPrint STNightly = text "stackage-nightly"
59 pPrint (STNightly2 _) = text "stackage-nightly"
60 pPrint (STLTS m n) = text "lts-" <> int m <> char '.' <> int n
62readStackage :: FilePath -> ParIO [Snapshot]
63readStackage dirPath = do
64 filePaths <- liftIO (listFiles dirPath)
65 parMapM (liftIO . readSnapshot) [ dirPath </> p | p <- filePaths, takeExtension p == ".yaml" ]
67readSnapshot :: FilePath -> IO Snapshot
68readSnapshot p = fmap (fromBuildPlan (parseSnapshotType (takeFileName p))) (readBuildPlan p)
70parseSnapshotType :: FilePath -> SnapshotType
71parseSnapshotType p
72 | "lts-" `isPrefixOf` p
73 , [major,minor] <- splitOn "." (drop 4 (dropExtension p))
74 = STLTS (read major) (read minor)
75 | "nightly-" `isPrefixOf` p
76 , [year,month,day] <- splitOn "-" (drop 8 (dropExtension p))
77 = STNightly2 (fromGregorian (read year) (read month) (read day))
78 | otherwise = error ("parseSnapshotType: invalid file name " ++ p)
80readBuildPlan :: FilePath -> IO BuildPlan
81readBuildPlan = fmap fromJust . decodeFile
83fromBuildPlan :: SnapshotType -> BuildPlan -> Snapshot
84fromBuildPlan snt bp = Snapshot snt
85 (CompilerId GHC (siGhcVersion (bpSystemInfo bp)))
86 (siCorePackages (bpSystemInfo bp))
87 (Map.map fromPackagePlan (bpPackages bp))
89fromPackagePlan :: PackagePlan -> Spec
90fromPackagePlan pp = Spec (ppVersion pp)
91 (pcFlagOverrides ppc)
92 (pcTests ppc == ExpectSuccess)
93 (pcHaddocks ppc == ExpectSuccess)
94 (not (pcSkipBuild ppc))
95 where ppc = ppConstraints pp
97listFiles :: FilePath -> IO [FilePath]
98listFiles path = do
99 let isFile p = doesFileExist (path </> p)
100 getDirectoryContents path >>= filterM isFile . Prelude.filter (\x -> head x /= '.')