{-# 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
  ( PackageDB (..)
  )
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
parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry
parseEnvironmentFileLine =
  String -> GhcEnvironmentFileEntry
GhcEnvFileComment (String -> GhcEnvironmentFileEntry)
-> ParsecT String () Identity String
-> Parser GhcEnvironmentFileEntry
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
-> Parser GhcEnvironmentFileEntry -> Parser GhcEnvironmentFileEntry
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
GhcEnvFilePackageId (UnitId -> GhcEnvironmentFileEntry)
-> ParsecT String () Identity UnitId
-> Parser GhcEnvironmentFileEntry
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
-> Parser GhcEnvironmentFileEntry -> Parser GhcEnvironmentFileEntry
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
<|> PackageDB -> GhcEnvironmentFileEntry
GhcEnvFilePackageDb (PackageDB -> GhcEnvironmentFileEntry)
-> ParsecT String () Identity PackageDB
-> Parser GhcEnvironmentFileEntry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity PackageDB
forall {u}. ParsecT String u Identity PackageDB
packageDb
    Parser GhcEnvironmentFileEntry
-> Parser GhcEnvironmentFileEntry -> Parser GhcEnvironmentFileEntry
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 -> Parser GhcEnvironmentFileEntry
forall a. a -> ParsecT String () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhcEnvironmentFileEntry
GhcEnvFileClearPackageDbStack Parser GhcEnvironmentFileEntry
-> ParsecT String () Identity String
-> Parser GhcEnvironmentFileEntry
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 (m :: * -> *) t u a.
Stream s m t =>
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 PackageDB
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 PackageDB
-> ParsecT String u Identity PackageDB
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
*> PackageDB -> ParsecT String u Identity PackageDB
forall a. a -> ParsecT String u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDB
GlobalPackageDB)
        ParsecT String u Identity PackageDB
-> ParsecT String u Identity PackageDB
-> ParsecT String u Identity PackageDB
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 PackageDB
-> ParsecT String u Identity PackageDB
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
*> PackageDB -> ParsecT String u Identity PackageDB
forall a. a -> ParsecT String u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDB
UserPackageDB)
        ParsecT String u Identity PackageDB
-> ParsecT String u Identity PackageDB
-> ParsecT String u Identity PackageDB
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 PackageDB
-> ParsecT String u Identity PackageDB
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 -> PackageDB
SpecificPackageDB (String -> PackageDB)
-> ParsecT String u Identity String
-> ParsecT String u Identity PackageDB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
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 PackageDB
-> ParsecT String u Identity Char
-> ParsecT String u Identity PackageDB
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]
parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry]
parseGhcEnvironmentFile = Parser GhcEnvironmentFileEntry
parseEnvironmentFileLine Parser GhcEnvironmentFileEntry
-> ParsecT String () Identity Char
-> Parser [GhcEnvironmentFileEntry]
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]
-> ParsecT String () Identity ()
-> Parser [GhcEnvironmentFileEntry]
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]
readGhcEnvironmentFile :: String -> IO [GhcEnvironmentFileEntry]
readGhcEnvironmentFile String
path =
  (ParseError -> IO [GhcEnvironmentFileEntry])
-> ([GhcEnvironmentFileEntry] -> IO [GhcEnvironmentFileEntry])
-> Either ParseError [GhcEnvironmentFileEntry]
-> IO [GhcEnvironmentFileEntry]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ParseErrorExc -> IO [GhcEnvironmentFileEntry]
forall e a. Exception e => e -> IO a
throwIO (ParseErrorExc -> IO [GhcEnvironmentFileEntry])
-> (ParseError -> ParseErrorExc)
-> ParseError
-> IO [GhcEnvironmentFileEntry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseErrorExc
ParseErrorExc) [GhcEnvironmentFileEntry] -> IO [GhcEnvironmentFileEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Either ParseError [GhcEnvironmentFileEntry]
 -> IO [GhcEnvironmentFileEntry])
-> IO (Either ParseError [GhcEnvironmentFileEntry])
-> IO [GhcEnvironmentFileEntry]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser [GhcEnvironmentFileEntry]
-> String -> IO (Either ParseError [GhcEnvironmentFileEntry])
forall a. Parser a -> String -> IO (Either ParseError a)
parseFromFile Parser [GhcEnvironmentFileEntry]
parseGhcEnvironmentFile String
path