{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Simple.Compiler
import Distribution.Simple.GHC.Internal
  ( GhcEnvironmentFileEntry (..)
  )
import Distribution.Types.UnitId
  ( mkUnitId
  )

import qualified Text.Parsec as P
import Text.Parsec.String
  ( Parser
  , parseFromFile
  )

parseEnvironmentFileLine :: Parser (GhcEnvironmentFileEntry FilePath)
parseEnvironmentFileLine :: Parser (GhcEnvironmentFileEntry String)
parseEnvironmentFileLine =
  String -> GhcEnvironmentFileEntry String
forall fp. String -> GhcEnvironmentFileEntry fp
GhcEnvFileComment (String -> GhcEnvironmentFileEntry String)
-> ParsecT String () Identity String
-> Parser (GhcEnvironmentFileEntry String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
forall {u}. ParsecT String u Identity String
comment
    Parser (GhcEnvironmentFileEntry String)
-> Parser (GhcEnvironmentFileEntry String)
-> Parser (GhcEnvironmentFileEntry String)
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UnitId -> GhcEnvironmentFileEntry String
forall fp. UnitId -> GhcEnvironmentFileEntry fp
GhcEnvFilePackageId (UnitId -> GhcEnvironmentFileEntry String)
-> ParsecT String () Identity UnitId
-> Parser (GhcEnvironmentFileEntry String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity UnitId
forall {u}. ParsecT String u Identity UnitId
unitId
    Parser (GhcEnvironmentFileEntry String)
-> Parser (GhcEnvironmentFileEntry String)
-> Parser (GhcEnvironmentFileEntry String)
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PackageDBX String -> GhcEnvironmentFileEntry String
forall fp. PackageDBX fp -> GhcEnvironmentFileEntry fp
GhcEnvFilePackageDb (PackageDBX String -> GhcEnvironmentFileEntry String)
-> ParsecT String () Identity (PackageDBX String)
-> Parser (GhcEnvironmentFileEntry String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity (PackageDBX String)
forall {u}. ParsecT String u Identity (PackageDBX String)
packageDb
    Parser (GhcEnvironmentFileEntry String)
-> Parser (GhcEnvironmentFileEntry String)
-> Parser (GhcEnvironmentFileEntry String)
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GhcEnvironmentFileEntry String
-> Parser (GhcEnvironmentFileEntry String)
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhcEnvironmentFileEntry String
forall fp. GhcEnvironmentFileEntry fp
GhcEnvFileClearPackageDbStack Parser (GhcEnvironmentFileEntry String)
-> ParsecT String () Identity String
-> Parser (GhcEnvironmentFileEntry String)
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity String
forall {u}. ParsecT String u Identity String
clearDb
  where
    comment :: ParsecT String u Identity String
comment = String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
"--" ParsecT String u Identity String
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many (String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
P.noneOf String
"\r\n")
    unitId :: ParsecT String u Identity UnitId
unitId =
      ParsecT String u Identity UnitId
-> ParsecT String u Identity UnitId
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT String u Identity UnitId
 -> ParsecT String u Identity UnitId)
-> ParsecT String u Identity UnitId
-> ParsecT String u Identity UnitId
forall a b. (a -> b) -> a -> b
$
        String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
"package-id"
          ParsecT String u Identity String
-> ParsecT String u Identity () -> ParsecT String u Identity ()
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces
          ParsecT String u Identity ()
-> ParsecT String u Identity UnitId
-> ParsecT String u Identity UnitId
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> UnitId
mkUnitId (String -> UnitId)
-> ParsecT String u Identity String
-> ParsecT String u Identity UnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many1 ((Char -> Bool) -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy ((Char -> Bool) -> ParsecT String u Identity Char)
-> (Char -> Bool) -> ParsecT String u Identity Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"-_.+"))
    packageDb :: ParsecT String u Identity (PackageDBX String)
packageDb =
      (String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
"global-package-db" ParsecT String u Identity String
-> ParsecT String u Identity (PackageDBX String)
-> ParsecT String u Identity (PackageDBX String)
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> PackageDBX String -> ParsecT String u Identity (PackageDBX String)
forall a. a -> ParsecT String u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDBX String
forall fp. PackageDBX fp
GlobalPackageDB)
        ParsecT String u Identity (PackageDBX String)
-> ParsecT String u Identity (PackageDBX String)
-> ParsecT String u Identity (PackageDBX String)
forall a.
ParsecT String u Identity a
-> ParsecT String u Identity a -> ParsecT String u Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
"user-package-db" ParsecT String u Identity String
-> ParsecT String u Identity (PackageDBX String)
-> ParsecT String u Identity (PackageDBX String)
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> PackageDBX String -> ParsecT String u Identity (PackageDBX String)
forall a. a -> ParsecT String u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDBX String
forall fp. PackageDBX fp
UserPackageDB)
        ParsecT String u Identity (PackageDBX String)
-> ParsecT String u Identity (PackageDBX String)
-> ParsecT String u Identity (PackageDBX String)
forall a.
ParsecT String u Identity a
-> ParsecT String u Identity a -> ParsecT String u Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
"package-db" ParsecT String u Identity String
-> ParsecT String u Identity () -> ParsecT String u Identity ()
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces ParsecT String u Identity ()
-> ParsecT String u Identity (PackageDBX String)
-> ParsecT String u Identity (PackageDBX String)
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> PackageDBX String
forall fp. fp -> PackageDBX fp
SpecificPackageDB (String -> PackageDBX String)
-> ParsecT String u Identity String
-> ParsecT String u Identity (PackageDBX String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many1 (String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
P.noneOf String
"\r\n") ParsecT String u Identity (PackageDBX String)
-> ParsecT String u Identity Char
-> ParsecT String u Identity (PackageDBX String)
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
P.lookAhead ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.endOfLine))
    clearDb :: ParsecT String u Identity String
clearDb = String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
P.string String
"clear-package-db"

newtype ParseErrorExc = ParseErrorExc P.ParseError
  deriving (Int -> ParseErrorExc -> ShowS
[ParseErrorExc] -> ShowS
ParseErrorExc -> String
(Int -> ParseErrorExc -> ShowS)
-> (ParseErrorExc -> String)
-> ([ParseErrorExc] -> ShowS)
-> Show ParseErrorExc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseErrorExc -> ShowS
showsPrec :: Int -> ParseErrorExc -> ShowS
$cshow :: ParseErrorExc -> String
show :: ParseErrorExc -> String
$cshowList :: [ParseErrorExc] -> ShowS
showList :: [ParseErrorExc] -> ShowS
Show, Typeable)

instance Exception ParseErrorExc

parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry FilePath]
parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry String]
parseGhcEnvironmentFile = Parser (GhcEnvironmentFileEntry String)
parseEnvironmentFileLine Parser (GhcEnvironmentFileEntry String)
-> ParsecT String () Identity Char
-> Parser [GhcEnvironmentFileEntry String]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`P.sepEndBy` ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.endOfLine Parser [GhcEnvironmentFileEntry String]
-> ParsecT String () Identity ()
-> Parser [GhcEnvironmentFileEntry String]
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof

readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry FilePath]
readGhcEnvironmentFile :: String -> IO [GhcEnvironmentFileEntry String]
readGhcEnvironmentFile String
path =
  (ParseError -> IO [GhcEnvironmentFileEntry String])
-> ([GhcEnvironmentFileEntry String]
    -> IO [GhcEnvironmentFileEntry String])
-> Either ParseError [GhcEnvironmentFileEntry String]
-> IO [GhcEnvironmentFileEntry String]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ParseErrorExc -> IO [GhcEnvironmentFileEntry String]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ParseErrorExc -> IO [GhcEnvironmentFileEntry String])
-> (ParseError -> ParseErrorExc)
-> ParseError
-> IO [GhcEnvironmentFileEntry String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseErrorExc
ParseErrorExc) [GhcEnvironmentFileEntry String]
-> IO [GhcEnvironmentFileEntry String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Either ParseError [GhcEnvironmentFileEntry String]
 -> IO [GhcEnvironmentFileEntry String])
-> IO (Either ParseError [GhcEnvironmentFileEntry String])
-> IO [GhcEnvironmentFileEntry String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser [GhcEnvironmentFileEntry String]
-> String
-> IO (Either ParseError [GhcEnvironmentFileEntry String])
forall a. Parser a -> String -> IO (Either ParseError a)
parseFromFile Parser [GhcEnvironmentFileEntry String]
parseGhcEnvironmentFile String
path