mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-12 07:18:31 +01:00
54 lines
2.0 KiB
Haskell
54 lines
2.0 KiB
Haskell
module Stackage.HaskellPlatform
|
|
( loadHaskellPlatform
|
|
) where
|
|
|
|
import Control.Monad (guard)
|
|
import Data.Char (isSpace)
|
|
import Data.List (foldl', isInfixOf, isPrefixOf, stripPrefix)
|
|
import Data.Maybe (mapMaybe)
|
|
import Data.Monoid (Monoid (..))
|
|
import Data.Set (singleton)
|
|
import Distribution.Text (simpleParse)
|
|
import Stackage.Types
|
|
|
|
loadHaskellPlatform :: SelectSettings -> IO HaskellPlatform
|
|
loadHaskellPlatform = fmap parseHP . readFile . haskellPlatformCabal
|
|
|
|
data HPLine = HPLPackage PackageIdentifier
|
|
| HPLBeginCore
|
|
| HPLEndCore
|
|
| HPLBeginPlatform
|
|
| HPLEndPlatform
|
|
deriving Show
|
|
|
|
toHPLine :: String -> Maybe HPLine
|
|
toHPLine s
|
|
| "begin core packages" `isInfixOf` s = Just HPLBeginCore
|
|
| "end core packages" `isInfixOf` s = Just HPLEndCore
|
|
| "begin platform packages" `isInfixOf` s = Just HPLBeginPlatform
|
|
| "end platform packages" `isInfixOf` s = Just HPLEndPlatform
|
|
| otherwise = do
|
|
let s1 = dropWhile isSpace s
|
|
guard $ not $ "--" `isPrefixOf` s1
|
|
guard $ not $ null s1
|
|
guard $ "==" `isInfixOf` s1
|
|
let (package', s2) = break (== '=') s1
|
|
package = takeWhile (not . isSpace) package'
|
|
s3 <- stripPrefix "==" s2
|
|
version <- simpleParse $ takeWhile (/= ',') s3
|
|
Just $ HPLPackage $ PackageIdentifier (PackageName package) version
|
|
|
|
parseHP :: String -> HaskellPlatform
|
|
parseHP =
|
|
snd . foldl' addLine (notInBlock, mempty) . mapMaybe toHPLine . lines
|
|
where
|
|
notInBlock _ = mempty
|
|
inCore x = HaskellPlatform (singleton x) mempty
|
|
inPlatform x = HaskellPlatform mempty (singleton x)
|
|
|
|
addLine (fromPackage, hp) (HPLPackage vp) = (fromPackage, fromPackage vp `mappend` hp)
|
|
addLine (_, hp) HPLBeginCore = (inCore, hp)
|
|
addLine (_, hp) HPLEndCore = (notInBlock, hp)
|
|
addLine (_, hp) HPLBeginPlatform = (inPlatform, hp)
|
|
addLine (_, hp) HPLEndPlatform = (notInBlock, hp)
|