{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Distribution.Simple.GHC.EnvironmentParser
    ( parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc(..) ) where

import Prelude ()
import Distribution.Compat.Prelude

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

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

parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry
parseEnvironmentFileLine =      GhcEnvFileComment             <$> comment
                       <|>      GhcEnvFilePackageId           <$> unitId
                       <|>      GhcEnvFilePackageDb           <$> packageDb
                       <|> pure GhcEnvFileClearPackageDbStack <*  clearDb
    where
        comment = P.string "--" *> P.many (P.noneOf "\r\n")
        unitId = P.try $ P.string "package-id" *> P.spaces *>
            (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+"))
        packageDb = (P.string "global-package-db"      *> pure GlobalPackageDB)
                <|> (P.string "user-package-db"        *> pure UserPackageDB)
                <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine))
        clearDb = P.string "clear-package-db"

newtype ParseErrorExc = ParseErrorExc P.ParseError
                      deriving (Show, Typeable)

instance Exception ParseErrorExc

parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry]
parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P.eof

readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry]
readGhcEnvironmentFile path =
    either (throwIO . ParseErrorExc) return =<<
        parseFromFile parseGhcEnvironmentFile path