-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes                #-}
module CabalFmt.Fields (
    FieldDescrs,
    fieldDescrLookup,
    coerceFieldDescrs,
    singletonF,
    ) where

import qualified Data.Map.Strict                 as Map
import qualified Distribution.Compat.CharParsing as C
import qualified Distribution.FieldGrammar       as C
import qualified Distribution.Fields.Field       as C
import qualified Distribution.Parsec             as C
import qualified Distribution.Pretty             as C
import qualified Text.PrettyPrint                as PP

import CabalFmt.Prelude

-------------------------------------------------------------------------------
-- FieldDescr variant
-------------------------------------------------------------------------------

-- strict pair
data SP = forall f. SP
    { ()
_pPretty :: !(f -> PP.Doc)
    , ()
_pParse  :: !(forall m. C.CabalParsing m => m f)
    }

-- | Lookup both pretty-printer and value parser.
--
-- As the value of the field is unknown, we have to work with it universally.
--
fieldDescrLookup
    :: C.CabalParsing m
    => FieldDescrs s a
    -> C.FieldName
    -> (forall f. m f -> (f -> PP.Doc) -> r)
    -> Maybe r
fieldDescrLookup :: FieldDescrs s a
-> FieldName -> (forall f. m f -> (f -> Doc) -> r) -> Maybe r
fieldDescrLookup (F Map FieldName SP
m) FieldName
fn forall f. m f -> (f -> Doc) -> r
kont = SP -> r
kont' (SP -> r) -> Maybe SP -> Maybe r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName -> Map FieldName SP -> Maybe SP
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Map FieldName SP
m where
    kont' :: SP -> r
kont' (SP f -> Doc
a forall (m :: * -> *). CabalParsing m => m f
b) = m f -> (f -> Doc) -> r
forall f. m f -> (f -> Doc) -> r
kont m f
forall (m :: * -> *). CabalParsing m => m f
b f -> Doc
a

-- | A collection field parsers and pretty-printers.
newtype FieldDescrs s a = F { FieldDescrs s a -> Map FieldName SP
runF :: Map.Map C.FieldName SP }
  deriving ((a -> b) -> FieldDescrs s a -> FieldDescrs s b
(forall a b. (a -> b) -> FieldDescrs s a -> FieldDescrs s b)
-> (forall a b. a -> FieldDescrs s b -> FieldDescrs s a)
-> Functor (FieldDescrs s)
forall a b. a -> FieldDescrs s b -> FieldDescrs s a
forall a b. (a -> b) -> FieldDescrs s a -> FieldDescrs s b
forall s a b. a -> FieldDescrs s b -> FieldDescrs s a
forall s a b. (a -> b) -> FieldDescrs s a -> FieldDescrs s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FieldDescrs s b -> FieldDescrs s a
$c<$ :: forall s a b. a -> FieldDescrs s b -> FieldDescrs s a
fmap :: (a -> b) -> FieldDescrs s a -> FieldDescrs s b
$cfmap :: forall s a b. (a -> b) -> FieldDescrs s a -> FieldDescrs s b
Functor)

coerceFieldDescrs :: FieldDescrs s a -> FieldDescrs () ()
coerceFieldDescrs :: FieldDescrs s a -> FieldDescrs () ()
coerceFieldDescrs (F Map FieldName SP
a) = Map FieldName SP -> FieldDescrs () ()
forall s a. Map FieldName SP -> FieldDescrs s a
F Map FieldName SP
a

instance Semigroup (FieldDescrs s a) where
    F Map FieldName SP
a <> :: FieldDescrs s a -> FieldDescrs s a -> FieldDescrs s a
<> F Map FieldName SP
b = Map FieldName SP -> FieldDescrs s a
forall s a. Map FieldName SP -> FieldDescrs s a
F (Map FieldName SP
a Map FieldName SP -> Map FieldName SP -> Map FieldName SP
forall a. Semigroup a => a -> a -> a
<> Map FieldName SP
b)

instance Monoid (FieldDescrs s a) where
    mempty :: FieldDescrs s a
mempty  = Map FieldName SP -> FieldDescrs s a
forall s a. Map FieldName SP -> FieldDescrs s a
F Map FieldName SP
forall k a. Map k a
Map.empty
    mappend :: FieldDescrs s a -> FieldDescrs s a -> FieldDescrs s a
mappend = FieldDescrs s a -> FieldDescrs s a -> FieldDescrs s a
forall a. Semigroup a => a -> a -> a
(<>)

instance Applicative (FieldDescrs s) where
    pure :: a -> FieldDescrs s a
pure a
_  = Map FieldName SP -> FieldDescrs s a
forall s a. Map FieldName SP -> FieldDescrs s a
F Map FieldName SP
forall a. Monoid a => a
mempty
    FieldDescrs s (a -> b)
f <*> :: FieldDescrs s (a -> b) -> FieldDescrs s a -> FieldDescrs s b
<*> FieldDescrs s a
x = Map FieldName SP -> FieldDescrs s b
forall s a. Map FieldName SP -> FieldDescrs s a
F (Map FieldName SP -> Map FieldName SP -> Map FieldName SP
forall a. Monoid a => a -> a -> a
mappend (FieldDescrs s (a -> b) -> Map FieldName SP
forall s a. FieldDescrs s a -> Map FieldName SP
runF FieldDescrs s (a -> b)
f) (FieldDescrs s a -> Map FieldName SP
forall s a. FieldDescrs s a -> Map FieldName SP
runF FieldDescrs s a
x))

singletonF
    :: C.FieldName
    -> (f -> PP.Doc)
    -> (forall m. C.CabalParsing m => m f)
    -> FieldDescrs s a
singletonF :: FieldName
-> (f -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m f)
-> FieldDescrs s a
singletonF FieldName
fn f -> Doc
f forall (m :: * -> *). CabalParsing m => m f
g = Map FieldName SP -> FieldDescrs s a
forall s a. Map FieldName SP -> FieldDescrs s a
F (Map FieldName SP -> FieldDescrs s a)
-> Map FieldName SP -> FieldDescrs s a
forall a b. (a -> b) -> a -> b
$ FieldName -> SP -> Map FieldName SP
forall k a. k -> a -> Map k a
Map.singleton FieldName
fn ((f -> Doc) -> (forall (m :: * -> *). CabalParsing m => m f) -> SP
forall f.
(f -> Doc) -> (forall (m :: * -> *). CabalParsing m => m f) -> SP
SP f -> Doc
f forall (m :: * -> *). CabalParsing m => m f
g)

instance C.FieldGrammar FieldDescrs where
    blurFieldGrammar :: ALens' a b -> FieldDescrs b c -> FieldDescrs a c
blurFieldGrammar ALens' a b
_ (F Map FieldName SP
m) = Map FieldName SP -> FieldDescrs a c
forall s a. Map FieldName SP -> FieldDescrs s a
F Map FieldName SP
m

    booleanFieldDef :: FieldName -> ALens' s Bool -> Bool -> FieldDescrs s Bool
booleanFieldDef FieldName
fn ALens' s Bool
_ Bool
_def = FieldName
-> (Bool -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m Bool)
-> FieldDescrs s Bool
forall f s a.
FieldName
-> (f -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m f)
-> FieldDescrs s a
singletonF FieldName
fn Bool -> Doc
f forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m Bool
C.parsec where
        f :: Bool -> PP.Doc
        f :: Bool -> Doc
f Bool
s = String -> Doc
PP.text (Bool -> String
forall a. Show a => a -> String
show Bool
s)

    uniqueFieldAla :: FieldName -> (a -> b) -> ALens' s a -> FieldDescrs s a
uniqueFieldAla FieldName
fn a -> b
_pack ALens' s a
_ =
        FieldName
-> (a -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m a)
-> FieldDescrs s a
forall f s a.
FieldName
-> (f -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m f)
-> FieldDescrs s a
singletonF FieldName
fn (b -> Doc
forall a. Pretty a => a -> Doc
C.pretty (b -> Doc) -> (a -> b) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> a -> b
forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack) ((a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> a) -> m b -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
C.parsec)

    optionalFieldAla :: FieldName
-> (a -> b) -> ALens' s (Maybe a) -> FieldDescrs s (Maybe a)
optionalFieldAla FieldName
fn a -> b
_pack ALens' s (Maybe a)
_ =
        FieldName
-> (a -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m a)
-> FieldDescrs s (Maybe a)
forall f s a.
FieldName
-> (f -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m f)
-> FieldDescrs s a
singletonF FieldName
fn (b -> Doc
forall a. Pretty a => a -> Doc
C.pretty (b -> Doc) -> (a -> b) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> a -> b
forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack) ((a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> a) -> m b -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
C.parsec)

    optionalFieldDefAla :: FieldName -> (a -> b) -> ALens' s a -> a -> FieldDescrs s a
optionalFieldDefAla FieldName
fn a -> b
_pack ALens' s a
_ a
def =
        FieldName
-> (a -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m a)
-> FieldDescrs s a
forall f s a.
FieldName
-> (f -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m f)
-> FieldDescrs s a
singletonF FieldName
fn a -> Doc
f ((a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> a) -> m b -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
C.parsec)
      where
        f :: a -> Doc
f a
s | a
s a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
def  = Doc
PP.empty
            | Bool
otherwise = b -> Doc
forall a. Pretty a => a -> Doc
C.pretty ((a -> b) -> a -> b
forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack a
s)

    monoidalFieldAla :: FieldName -> (a -> b) -> ALens' s a -> FieldDescrs s a
monoidalFieldAla FieldName
fn a -> b
_pack ALens' s a
_ =
        FieldName
-> (a -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m a)
-> FieldDescrs s a
forall f s a.
FieldName
-> (f -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m f)
-> FieldDescrs s a
singletonF FieldName
fn (b -> Doc
forall a. Pretty a => a -> Doc
C.pretty (b -> Doc) -> (a -> b) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> a -> b
forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack) ((a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> a) -> m b -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
C.parsec)

    freeTextField :: FieldName
-> ALens' s (Maybe String) -> FieldDescrs s (Maybe String)
freeTextField FieldName
fn ALens' s (Maybe String)
_ = FieldName
-> (String -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m String)
-> FieldDescrs s (Maybe String)
forall f s a.
FieldName
-> (f -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m f)
-> FieldDescrs s a
singletonF FieldName
fn
        String -> Doc
PP.text
        ((Char -> Bool) -> m String
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
C.munch ((Char -> Bool) -> m String) -> (Char -> Bool) -> m String
forall a b. (a -> b) -> a -> b
$ Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

    freeTextFieldDef :: FieldName -> ALens' s String -> FieldDescrs s String
freeTextFieldDef FieldName
fn ALens' s String
_ = FieldName
-> (String -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m String)
-> FieldDescrs s String
forall f s a.
FieldName
-> (f -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m f)
-> FieldDescrs s a
singletonF FieldName
fn
        String -> Doc
PP.text
        ((Char -> Bool) -> m String
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
C.munch ((Char -> Bool) -> m String) -> (Char -> Bool) -> m String
forall a b. (a -> b) -> a -> b
$ Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

    freeTextFieldDefST :: FieldName -> ALens' s ShortText -> FieldDescrs s ShortText
freeTextFieldDefST FieldName
fn ALens' s ShortText
_ = FieldName
-> (String -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m String)
-> FieldDescrs s ShortText
forall f s a.
FieldName
-> (f -> Doc)
-> (forall (m :: * -> *). CabalParsing m => m f)
-> FieldDescrs s a
singletonF FieldName
fn
        String -> Doc
PP.text
        ((Char -> Bool) -> m String
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
C.munch ((Char -> Bool) -> m String) -> (Char -> Bool) -> m String
forall a b. (a -> b) -> a -> b
$ Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)

    prefixedFields :: FieldName
-> ALens' s [(String, String)] -> FieldDescrs s [(String, String)]
prefixedFields FieldName
_fnPfx ALens' s [(String, String)]
_l = Map FieldName SP -> FieldDescrs s [(String, String)]
forall s a. Map FieldName SP -> FieldDescrs s a
F Map FieldName SP
forall a. Monoid a => a
mempty
    knownField :: FieldName -> FieldDescrs s ()
knownField FieldName
_           = () -> FieldDescrs s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    deprecatedSince :: CabalSpecVersion -> String -> FieldDescrs s a -> FieldDescrs s a
deprecatedSince CabalSpecVersion
_  String
_ FieldDescrs s a
x = FieldDescrs s a
x
    removedIn :: CabalSpecVersion -> String -> FieldDescrs s a -> FieldDescrs s a
removedIn CabalSpecVersion
_ String
_ FieldDescrs s a
x        = FieldDescrs s a
x
    availableSince :: CabalSpecVersion -> a -> FieldDescrs s a -> FieldDescrs s a
availableSince CabalSpecVersion
_ a
_     = FieldDescrs s a -> FieldDescrs s a
forall a. a -> a
id
    hiddenField :: FieldDescrs s a -> FieldDescrs s a
hiddenField FieldDescrs s a
_          = Map FieldName SP -> FieldDescrs s a
forall s a. Map FieldName SP -> FieldDescrs s a
F Map FieldName SP
forall a. Monoid a => a
mempty