git.iko.soy/stackage
on 58292ca help sign in
stackage/Stackage/HaskellPlatform.hs
71 lines 2.5 kB history raw
1module Stackage.HaskellPlatform
2 ( loadHaskellPlatform
3 ) where
5import Control.Monad (guard)
6import Data.Char (isSpace)
7import Data.List (foldl', isInfixOf, isPrefixOf, stripPrefix)
8import Data.Maybe (mapMaybe)
9import Data.Monoid (Monoid (..))
10import Data.Set (singleton)
11import Distribution.Text (simpleParse)
12import Stackage.Types
13import System.Directory (doesFileExist)
14import System.FilePath ((</>))
16loadHaskellPlatform :: SelectSettings -> IO (Maybe HaskellPlatform)
17loadHaskellPlatform ss = do
18 e <- doesFileExist fp
19 if e
20 then fmap (Just . parseHP) $ readFile fp
21 else do
22 putStrLn "Warning: No Haskell Platform found for current GHC version"
23 return Nothing
24 where
25 GhcMajorVersion x y = selectGhcVersion ss
27 fp = haskellPlatformDir ss </> (concat
28 [ "haskell-platform-"
29 , show x
30 , "."
31 , show y
32 , ".cabal"
33 ])
35data HPLine = HPLPackage PackageIdentifier
36 | HPLBeginCore
37 | HPLEndCore
38 | HPLBeginPlatform
39 | HPLEndPlatform
40 deriving Show
42toHPLine :: String -> Maybe HPLine
43toHPLine s
44 | "begin core packages" `isInfixOf` s = Just HPLBeginCore
45 | "end core packages" `isInfixOf` s = Just HPLEndCore
46 | "begin platform packages" `isInfixOf` s = Just HPLBeginPlatform
47 | "end platform packages" `isInfixOf` s = Just HPLEndPlatform
48 | otherwise = do
49 let s1 = dropWhile isSpace s
50 guard $ not $ "--" `isPrefixOf` s1
51 guard $ not $ null s1
52 guard $ "==" `isInfixOf` s1
53 let (package', s2) = break (== '=') s1
54 package = takeWhile (not . isSpace) package'
55 s3 <- stripPrefix "==" s2
56 version <- simpleParse $ takeWhile (/= ',') s3
57 Just $ HPLPackage $ PackageIdentifier (PackageName package) version
59parseHP :: String -> HaskellPlatform
60parseHP =
61 snd . foldl' addLine (notInBlock, mempty) . mapMaybe toHPLine . lines
62 where
63 notInBlock _ = mempty
64 inCore x = HaskellPlatform (singleton x) mempty
65 inPlatform x = HaskellPlatform mempty (singleton x)
67 addLine (fromPackage, hp) (HPLPackage vp) = (fromPackage, fromPackage vp `mappend` hp)
68 addLine (_, hp) HPLBeginCore = (inCore, hp)
69 addLine (_, hp) HPLEndCore = (notInBlock, hp)
70 addLine (_, hp) HPLBeginPlatform = (inPlatform, hp)
71 addLine (_, hp) HPLEndPlatform = (notInBlock, hp)