{-# LANGUAGE TypeApplications #-}

-- |

-- Module      :  BuildEnv.File

-- Description :  Parse packages and units from files

--

-- This module implements the parsing of the two file formats supported

-- by @build-env@:

--

--  - SEED files, containing a list of seed units from which to compute

--    a build plan. See 'parseSeedFile'.

--

--  - @cabal.config@ files containing version constraints on packages.

--    See 'parseCabalDotConfigPkgs'.

module BuildEnv.File
  ( parseCabalDotConfigPkgs, parseSeedFile )
  where

-- base

import Data.Char
  ( isSpace )

-- containers

import qualified Data.Map.Strict as Map
import qualified Data.Set        as Set

-- text

import Data.Text
  ( Text )
import qualified Data.Text    as Text
import qualified Data.Text.IO as Text

-- build-env

import BuildEnv.CabalPlan

--------------------------------------------------------------------------------


-- | Parse constrained packages from the @constraints@ stanza

-- of the @cabal.config@ file at the given filepath:

--

-- > constraints: pkg1 ==ver1,

-- >              pkg2 ==ver2,

-- > ...

--

-- This function disregards all other contents of the @cabal.config@ package.

parseCabalDotConfigPkgs :: FilePath -> IO PkgSpecs
parseCabalDotConfigPkgs :: [Char] -> IO PkgSpecs
parseCabalDotConfigPkgs [Char]
fp = do
  [Text]
ls <-  (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter ( Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isCommentLine (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip )
      ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Text -> [Text]
Text.lines
     (Text -> [Text]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
Text.readFile [Char]
fp
  PkgSpecs -> IO PkgSpecs
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PkgSpecs -> IO PkgSpecs) -> PkgSpecs -> IO PkgSpecs
forall a b. (a -> b) -> a -> b
$ PkgSpecs -> [Text] -> PkgSpecs
outsideStanza PkgSpecs
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
Text.strip (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (Bool -> Bool) -> Bool -> Bool
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
lText -> [Text] -> [Text]
forall 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  PkgName -> PkgSpec -> PkgSpecs -> PkgSpecs
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PkgName
pkgName PkgSpec
pkgSpec PkgSpecs
pkgs

-- | Parse a 'PkgName' and 'PkgSpec' from a line in a @cabal.config@ file.

--

-- Assumes whitespace has already been stripped.

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
          (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
Text.dropAround (Char
',' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) -- drop commas

          (Text -> Text) -> Text -> Text
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
  = [Char] -> (PkgName, PkgSpec)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (PkgName, PkgSpec)) -> [Char] -> (PkgName, PkgSpec)
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid package in cabal.config file: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
txt

-- NB: update the readme after changing the documentation below.


-- | Parse a seed file. Each line must either be:

--

--  - A Cabal unit, in the format @unit +flag1 -flag2 >= 0.1 && < 0.3@.

--

--    A unit can be of the form @pkgName@, @lib:pkgName@, @exe:pkgName@,

--    @pkgName:lib:compName@, ... as per Cabal component syntax.

--

--    The unit name must be followed by a space.

--

--    Flags and constraints are optional.

--    When both are present, flags must precede constraints.

--    Constraints must use valid Cabal constraint syntax.

--

--  - An allow-newer specification, e.g. @allow-newer: pkg1:pkg2,*:base,...@.

--    This is not allowed to span multiple lines.

--

-- Returns @(units, allowNewer)@.

parseSeedFile :: FilePath -> IO (UnitSpecs, AllowNewer)
parseSeedFile :: [Char] -> IO (UnitSpecs, AllowNewer)
parseSeedFile [Char]
fp = do
  [Text]
ls <-  (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter ( Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isCommentLine )
      ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Text.strip
      ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Text -> [Text]
Text.lines
     (Text -> [Text]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
Text.readFile [Char]
fp
  (UnitSpecs, AllowNewer) -> IO (UnitSpecs, AllowNewer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitSpecs, AllowNewer) -> IO (UnitSpecs, AllowNewer))
-> (UnitSpecs, AllowNewer) -> IO (UnitSpecs, AllowNewer)
forall a b. (a -> b) -> a -> b
$ UnitSpecs -> AllowNewer -> [Text] -> (UnitSpecs, AllowNewer)
go UnitSpecs
forall k a. Map k a
Map.empty AllowNewer
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 AllowNewer -> AllowNewer -> AllowNewer
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 = PkgName -> (PkgSrc, PkgSpec, Set ComponentName) -> UnitSpecs
forall k a. k -> a -> Map k a
Map.singleton PkgName
pkgName
              (PkgSrc
Remote, PkgSpec
spec, ComponentName -> Set ComponentName
forall a. a -> Set a
Set.singleton ComponentName
comp)
                -- we assume units in a seed file

                -- don't refer to local packages

      = UnitSpecs -> AllowNewer -> [Text] -> (UnitSpecs, AllowNewer)
go (UnitSpecs
units UnitSpecs -> UnitSpecs -> UnitSpecs
`unionUnitSpecsCombining` UnitSpecs
thisUnit) AllowNewer
ans [Text]
ls
      | Bool
otherwise
      = [Char] -> (UnitSpecs, AllowNewer)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (UnitSpecs, AllowNewer))
-> [Char] -> (UnitSpecs, AllowNewer)
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid package in seed file : " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
l

isCommentLine :: Text -> Bool
isCommentLine :: Text -> Bool
isCommentLine 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 (Set (Text, Text) -> AllowNewer) -> Set (Text, Text) -> AllowNewer
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> Set (Text, Text)
forall a. Ord a => [a] -> Set a
Set.fromList ([(Text, Text)] -> Set (Text, Text))
-> [(Text, Text)] -> Set (Text, Text)
forall a b. (a -> b) -> a -> b
$ (Text -> (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map Text -> (Text, Text)
parseOneAllowNewer (HasCallStack => Text -> Text -> [Text]
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 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.drop Int
1 -> Text
b) <- HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
":" Text
t
      , Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"*" Bool -> Bool -> Bool
|| Text -> Bool
validPackageName Text
a
      , Text
b Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"*" Bool -> Bool -> Bool
|| Text -> Bool
validPackageName Text
b
      = (Text
a,Text
b)
      | Bool
otherwise
      = [Char] -> (Text, Text)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Text, Text)) -> [Char] -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid allow-newer syntax in seed file: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
t