{-# LANGUAGE TypeApplications #-}
module BuildEnv.File
( parseCabalDotConfigPkgs, parseSeedFile )
where
import Data.Char
( isSpace )
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Text
( Text )
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import BuildEnv.CabalPlan
parseCabalDotConfigPkgs :: FilePath -> IO PkgSpecs
parseCabalDotConfigPkgs :: [Char] -> IO PkgSpecs
parseCabalDotConfigPkgs [Char]
fp = do
[Text]
ls <- forall a. (a -> Bool) -> [a] -> [a]
filter ( Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isCommentLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip )
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
Text.readFile [Char]
fp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PkgSpecs -> [Text] -> PkgSpecs
outsideStanza forall k a. Map k a
Map.empty [Text]
ls
where
outsideStanza :: PkgSpecs -> [Text] -> PkgSpecs
outsideStanza :: PkgSpecs -> [Text] -> PkgSpecs
outsideStanza PkgSpecs
pkgs []
= PkgSpecs
pkgs
outsideStanza PkgSpecs
pkgs (Text
l:[Text]
ls)
| Just Text
rest <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"constraints:" Text
l
= PkgSpecs -> [Text] -> PkgSpecs
inConstraintsStanza (PkgSpecs
pkgs PkgSpecs -> Text -> PkgSpecs
`addPkgFromLine` Text
rest) [Text]
ls
| Bool
otherwise
= PkgSpecs -> [Text] -> PkgSpecs
outsideStanza PkgSpecs
pkgs [Text]
ls
inConstraintsStanza :: PkgSpecs -> [Text] -> PkgSpecs
inConstraintsStanza :: PkgSpecs -> [Text] -> PkgSpecs
inConstraintsStanza PkgSpecs
pkgs []
= PkgSpecs
pkgs
inConstraintsStanza PkgSpecs
pkgs (Text
l:[Text]
ls)
| let (Text
ws, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
Text.span Char -> Bool
isSpace Text
l
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
Text.null Text
ws
= PkgSpecs -> [Text] -> PkgSpecs
inConstraintsStanza (PkgSpecs
pkgs PkgSpecs -> Text -> PkgSpecs
`addPkgFromLine` Text
rest) [Text]
ls
| Bool
otherwise
= PkgSpecs -> [Text] -> PkgSpecs
outsideStanza PkgSpecs
pkgs (Text
lforall a. a -> [a] -> [a]
:[Text]
ls)
addPkgFromLine :: PkgSpecs -> Text -> PkgSpecs
addPkgFromLine :: PkgSpecs -> Text -> PkgSpecs
addPkgFromLine PkgSpecs
pkgs Text
l =
let (PkgName
pkgName, PkgSpec
pkgSpec) = Text -> (PkgName, PkgSpec)
parseCabalDotConfigLine Text
l
in forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PkgName
pkgName PkgSpec
pkgSpec PkgSpecs
pkgs
parseCabalDotConfigLine :: Text -> (PkgName, PkgSpec)
parseCabalDotConfigLine :: Text -> (PkgName, PkgSpec)
parseCabalDotConfigLine Text
txt
| let (Text
pkg, Text
rest)
= (Char -> Bool) -> Text -> (Text, Text)
Text.break Char -> Bool
isSpace
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
Text.dropAround (Char
',' forall a. Eq a => a -> a -> Bool
==)
forall a b. (a -> b) -> a -> b
$ Text
txt
, Text -> Bool
validPackageName Text
pkg
= ( Text -> PkgName
PkgName Text
pkg, Text -> PkgSpec
parsePkgSpec Text
rest )
| Bool
otherwise
= forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid package in cabal.config file : " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
txt
where
parseSeedFile :: FilePath -> IO (UnitSpecs, AllowNewer)
parseSeedFile :: [Char] -> IO (UnitSpecs, AllowNewer)
parseSeedFile [Char]
fp = do
[Text]
ls <- forall a. (a -> Bool) -> [a] -> [a]
filter ( Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isCommentLine )
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Text.strip
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
Text.readFile [Char]
fp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UnitSpecs -> AllowNewer -> [Text] -> (UnitSpecs, AllowNewer)
go forall k a. Map k a
Map.empty forall a. Monoid a => a
mempty [Text]
ls
where
go :: UnitSpecs -> AllowNewer -> [Text] -> (UnitSpecs, AllowNewer)
go :: UnitSpecs -> AllowNewer -> [Text] -> (UnitSpecs, AllowNewer)
go UnitSpecs
units AllowNewer
ans [] = (UnitSpecs
units, AllowNewer
ans)
go UnitSpecs
units AllowNewer
ans (Text
l:[Text]
ls)
| Just Text
an <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"allow-newer:" Text
l
= UnitSpecs -> AllowNewer -> [Text] -> (UnitSpecs, AllowNewer)
go UnitSpecs
units (AllowNewer
ans forall a. Semigroup a => a -> a -> a
<> Text -> AllowNewer
parseAllowNewer Text
an) [Text]
ls
| let (Text
pkgTyComp, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
Text.break Char -> Bool
isSpace Text
l
, Just (PkgName
pkgName, ComponentName
comp) <- Text -> Maybe (PkgName, ComponentName)
parsePkgComponent Text
pkgTyComp
, let spec :: PkgSpec
spec = Text -> PkgSpec
parsePkgSpec Text
rest
thisUnit :: UnitSpecs
thisUnit = forall k a. k -> a -> Map k a
Map.singleton PkgName
pkgName
(PkgSrc
Remote, PkgSpec
spec, forall a. a -> Set a
Set.singleton ComponentName
comp)
= UnitSpecs -> AllowNewer -> [Text] -> (UnitSpecs, AllowNewer)
go (UnitSpecs
units UnitSpecs -> UnitSpecs -> UnitSpecs
`unionUnitSpecsCombining` UnitSpecs
thisUnit) AllowNewer
ans [Text]
ls
| Bool
otherwise
= forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid package in seed file : " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
l
isCommentLine :: Text -> Bool
Text
l
= Text -> Bool
Text.null Text
l
Bool -> Bool -> Bool
|| Text -> Text -> Bool
Text.isPrefixOf Text
"--" Text
l
parseAllowNewer :: Text -> AllowNewer
parseAllowNewer :: Text -> AllowNewer
parseAllowNewer Text
l =
Set (Text, Text) -> AllowNewer
AllowNewer forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> (Text, Text)
parseOneAllowNewer (Text -> Text -> [Text]
Text.splitOn Text
"," Text
l)
where
parseOneAllowNewer :: Text -> (Text, Text)
parseOneAllowNewer Text
t
| (Text -> Text
Text.strip -> Text
a, Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.drop Int
1 -> Text
b) <- Text -> Text -> (Text, Text)
Text.breakOn Text
":" Text
t
, Text
a forall a. Eq a => a -> a -> Bool
== Text
"*" Bool -> Bool -> Bool
|| Text -> Bool
validPackageName Text
a
, Text
b forall a. Eq a => a -> a -> Bool
== Text
"*" Bool -> Bool -> Bool
|| Text -> Bool
validPackageName Text
b
= (Text
a,Text
b)
| Bool
otherwise
= forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid allow-newer syntax in seed file: " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
t