-- |
-- License: GPL-3.0-or-later
-- Copyright: Oleg Grenrus
{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE UndecidableInstances      #-}
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 :: forall (m :: * -> *) s a r.
CabalParsing m =>
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' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall f. m f -> (f -> Doc) -> r
kont forall (m :: * -> *). CabalParsing m => m f
b f -> Doc
a

-- | A collection field parsers and pretty-printers.
newtype FieldDescrs s a = F { forall s a. FieldDescrs s a -> Map FieldName SP
runF :: Map.Map C.FieldName SP }
  deriving (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
<$ :: forall a b. a -> FieldDescrs s b -> FieldDescrs s a
$c<$ :: forall s a b. a -> FieldDescrs s b -> FieldDescrs s a
fmap :: forall a b. (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 :: forall s a. FieldDescrs s a -> FieldDescrs () ()
coerceFieldDescrs (F Map FieldName SP
a) = 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 = forall s a. Map FieldName SP -> FieldDescrs s a
F (Map FieldName SP
a forall a. Semigroup a => a -> a -> a
<> Map FieldName SP
b)

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

instance Applicative (FieldDescrs s) where
    pure :: forall a. a -> FieldDescrs s a
pure a
_  = forall s a. Map FieldName SP -> FieldDescrs s a
F forall a. Monoid a => a
mempty
    FieldDescrs s (a -> b)
f <*> :: forall a b.
FieldDescrs s (a -> b) -> FieldDescrs s a -> FieldDescrs s b
<*> FieldDescrs s a
x = forall s a. Map FieldName SP -> FieldDescrs s a
F (forall a. Monoid a => a -> a -> a
mappend (forall s a. FieldDescrs s a -> Map FieldName SP
runF FieldDescrs s (a -> b)
f) (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 :: forall f s a.
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 = forall s a. Map FieldName SP -> FieldDescrs s a
F forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton FieldName
fn (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 PrettyParsec FieldDescrs where
    blurFieldGrammar :: forall a b d. ALens' a b -> FieldDescrs b d -> FieldDescrs a d
blurFieldGrammar ALens' a b
_ (F Map FieldName SP
m) = forall s a. Map FieldName SP -> FieldDescrs s a
F Map FieldName SP
m

    booleanFieldDef :: forall s. FieldName -> ALens' s Bool -> Bool -> FieldDescrs s Bool
booleanFieldDef FieldName
fn ALens' s Bool
_ Bool
_def = 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
C.parsec where
        f :: Bool -> PP.Doc
        f :: Bool -> Doc
f Bool
s = String -> Doc
PP.text (forall a. Show a => a -> String
show Bool
s)

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

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

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

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

    freeTextField :: forall s.
FieldName
-> ALens' s (Maybe String) -> FieldDescrs s (Maybe String)
freeTextField FieldName
fn ALens' 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
        (forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
C.munch forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
True)

    freeTextFieldDef :: forall s. FieldName -> ALens' s String -> FieldDescrs s String
freeTextFieldDef FieldName
fn ALens' 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
        (forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
C.munch forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
True)

    freeTextFieldDefST :: forall s.
FieldName -> ALens' s ShortText -> FieldDescrs s ShortText
freeTextFieldDefST FieldName
fn ALens' 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
        (forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
C.munch forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
True)

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

class (C.Pretty a, C.Parsec a) => PrettyParsec a
instance (C.Pretty a, C.Parsec a) => PrettyParsec a