{-# LANGUAGE CPP                  #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE UndecidableInstances #-}

module GHCup.CabalConfig (getStoreDir) where

import Data.ByteString          (ByteString)
import Data.List.NonEmpty       (NonEmpty)
import Data.Map                 (Map)
import System.Directory         (getAppUserDataDirectory, doesDirectoryExist, getXdgDirectory, XdgDirectory(XdgConfig))
import System.Environment       (lookupEnv)
import System.FilePath          ((</>))

import qualified Data.ByteString               as BS
import qualified Data.Map.Strict               as M
import qualified Distribution.CabalSpecVersion as C
import qualified Distribution.FieldGrammar     as C
import qualified Distribution.FieldGrammar.Parsec     as C
import qualified Distribution.Fields           as C
import qualified Distribution.Fields.LexerMonad as C
import qualified Distribution.Parsec           as C
import qualified Distribution.Utils.Generic    as C
import qualified Text.Parsec                    as P

import Data.Foldable              (for_)
import Distribution.Parsec.Error




getStoreDir :: IO FilePath
getStoreDir :: IO FilePath
getStoreDir = do
    FilePath
fp <- IO FilePath
findConfig
    FieldName
bs <- FilePath -> IO FieldName
BS.readFile FilePath
fp
    (NonEmpty PError -> IO FilePath)
-> (Maybe FilePath -> IO FilePath)
-> Either (NonEmpty PError) (Maybe FilePath)
-> IO FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> IO FilePath
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO FilePath)
-> (NonEmpty PError -> FilePath) -> NonEmpty PError -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty FilePath -> FilePath
forall a. Show a => a -> FilePath
show (NonEmpty FilePath -> FilePath)
-> (NonEmpty PError -> NonEmpty FilePath)
-> NonEmpty PError
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PError -> FilePath) -> NonEmpty PError -> NonEmpty FilePath
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> PError -> FilePath
showPError FilePath
fp)) Maybe FilePath -> IO FilePath
resolveConfig (FieldName -> Either (NonEmpty PError) (Maybe FilePath)
parseConfig FieldName
bs)

-------------------------------------------------------------------------------
-- Find config
-------------------------------------------------------------------------------

-- | Find the @~\/.cabal\/config@ file.
findConfig :: IO FilePath
findConfig :: IO FilePath
findConfig = do
    Maybe FilePath
env <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CABAL_CONFIG"
    case Maybe FilePath
env of
        Just FilePath
p -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
p
        Maybe FilePath
Nothing -> do
            FilePath
cabalDir <- IO FilePath
findCabalDir
            FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
cabalDir FilePath -> FilePath -> FilePath
</> FilePath
"config")

-- | Find the @~\/.cabal@ dir.
findCabalDir :: IO FilePath
findCabalDir :: IO FilePath
findCabalDir = do
    Maybe FilePath
cabalDirVar <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"CABAL_DIR"
    FilePath
appDir <- FilePath -> IO FilePath
getAppUserDataDirectory FilePath
"cabal"
    Bool
isXdg <- Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesDirectoryExist FilePath
appDir
    if | Just FilePath
dir <- Maybe FilePath
cabalDirVar -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
dir
       | Bool
isXdg -> XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgConfig FilePath
"cabal"
       | Bool
otherwise -> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
appDir


-------------------------------------------------------------------------------
-- Parsing
-------------------------------------------------------------------------------

-- | Parse @~\/.cabal\/config@ file.
parseConfig :: ByteString -> Either (NonEmpty PError) (Maybe FilePath)
parseConfig :: FieldName -> Either (NonEmpty PError) (Maybe FilePath)
parseConfig = ([Field Position] -> ParseResult (Maybe FilePath))
-> FieldName -> Either (NonEmpty PError) (Maybe FilePath)
forall a.
([Field Position] -> ParseResult a)
-> FieldName -> Either (NonEmpty PError) a
parseWith (([Field Position] -> ParseResult (Maybe FilePath))
 -> FieldName -> Either (NonEmpty PError) (Maybe FilePath))
-> ([Field Position] -> ParseResult (Maybe FilePath))
-> FieldName
-> Either (NonEmpty PError) (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ \[Field Position]
fields0 -> do
    let (Fields Position
fields1, [[Section Position]]
_) = [Field Position] -> (Fields Position, [[Section Position]])
forall ann. [Field ann] -> (Fields ann, [[Section ann]])
C.partitionFields [Field Position]
fields0
    let fields2 :: Fields Position
fields2 = (FieldName -> [NamelessField Position] -> Bool)
-> Fields Position -> Fields Position
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\FieldName
k [NamelessField Position]
_ -> FieldName
k FieldName -> [FieldName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldName]
knownFields) Fields Position
fields1
    Fields Position -> ParseResult (Maybe FilePath)
parse Fields Position
fields2
  where
    knownFields :: [FieldName]
knownFields = ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath) -> [FieldName]
forall s a. ParsecFieldGrammar s a -> [FieldName]
C.fieldGrammarKnownFieldList ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath)
grammar

    parse :: Map C.FieldName [C.NamelessField C.Position]
          -> C.ParseResult (Maybe FilePath)
    parse :: Fields Position -> ParseResult (Maybe FilePath)
parse Fields Position
fields = CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath)
-> ParseResult (Maybe FilePath)
forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
C.parseFieldGrammar CabalSpecVersion
C.cabalSpecLatest Fields Position
fields ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath)
grammar

grammar :: C.ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath)
grammar :: ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath)
grammar = Maybe FilePath -> Maybe FilePath
forall a. Monoid a => a
mempty
    (Maybe FilePath -> Maybe FilePath)
-> ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath)
-> ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName
-> (FilePath -> FilePathNT)
-> ALens' (Maybe FilePath) (Maybe FilePath)
-> ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath)
forall b a s.
(Parsec b, Newtype a b) =>
FieldName
-> (a -> b) -> ALens' s (Maybe a) -> ParsecFieldGrammar s (Maybe a)
forall (c :: * -> Constraint) (g :: * -> * -> *) b a s.
(FieldGrammar c g, c b, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s (Maybe a) -> g s (Maybe a)
C.optionalFieldAla FieldName
"store-dir" FilePath -> FilePathNT
C.FilePathNT ALens' (Maybe FilePath) (Maybe FilePath)
forall a. a -> a
id

parseWith
    :: ([C.Field C.Position] -> C.ParseResult a)  -- ^ parse
    -> ByteString                                 -- ^ contents
    -> Either (NonEmpty PError) a
parseWith :: forall a.
([Field Position] -> ParseResult a)
-> FieldName -> Either (NonEmpty PError) a
parseWith [Field Position] -> ParseResult a
parser FieldName
bs = case ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
C.runParseResult ParseResult a
result of
    ([PWarning]
_, Right a
x)      -> a -> Either (NonEmpty PError) a
forall a b. b -> Either a b
Right a
x
    ([PWarning]
_, Left (Maybe Version
_, NonEmpty PError
es)) -> NonEmpty PError -> Either (NonEmpty PError) a
forall a b. a -> Either a b
Left NonEmpty PError
es
  where
    result :: ParseResult a
result = case FieldName -> Either ParseError ([Field Position], [LexWarning])
C.readFields' FieldName
bs of
        Left ParseError
perr -> Position -> FilePath -> ParseResult a
forall a. Position -> FilePath -> ParseResult a
C.parseFatalFailure Position
pos (ParseError -> FilePath
forall a. Show a => a -> FilePath
show ParseError
perr) where
            ppos :: SourcePos
ppos = ParseError -> SourcePos
P.errorPos ParseError
perr
            pos :: Position
pos  = Int -> Int -> Position
C.Position (SourcePos -> Int
P.sourceLine SourcePos
ppos) (SourcePos -> Int
P.sourceColumn SourcePos
ppos)
        Right ([Field Position]
fields, [LexWarning]
lexWarnings) -> do
            [PWarning] -> ParseResult ()
C.parseWarnings ([LexWarning] -> [PWarning]
C.toPWarnings [LexWarning]
lexWarnings)
            Maybe Int -> (Int -> ParseResult ()) -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (FieldName -> Maybe Int
C.validateUTF8 FieldName
bs) ((Int -> ParseResult ()) -> ParseResult ())
-> (Int -> ParseResult ()) -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \Int
pos ->
                Position -> PWarnType -> FilePath -> ParseResult ()
C.parseWarning Position
C.zeroPos PWarnType
C.PWTUTF (FilePath -> ParseResult ()) -> FilePath -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ FilePath
"UTF8 encoding problem at byte offset " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
pos
            [Field Position] -> ParseResult a
parser [Field Position]
fields

-------------------------------------------------------------------------------
-- Resolving
-------------------------------------------------------------------------------

-- | Fill the default in @~\/.cabal\/config@  file.
resolveConfig :: Maybe FilePath -> IO FilePath
resolveConfig :: Maybe FilePath -> IO FilePath
resolveConfig (Just FilePath
fp) = FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
fp
resolveConfig Maybe FilePath
Nothing = do
    FilePath
c <- IO FilePath
findCabalDir
    FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
c FilePath -> FilePath -> FilePath
</> FilePath
"store")