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

import qualified Data.Map.Strict                 as Map
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 where
    FreeText :: SP
    SP :: !(f -> PP.Doc)
       -> !(forall m. C.CabalParsing m => m f)
       -> SP

-- | 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
    -> r -- field is freetext
    -> (forall f. m f -> (f -> PP.Doc) -> r)
    -> Maybe r
fieldDescrLookup :: forall (m :: * -> *) s a r.
CabalParsing m =>
FieldDescrs s a
-> FieldName -> r -> (forall f. m f -> (f -> Doc) -> r) -> Maybe r
fieldDescrLookup (F Map FieldName SP
m) FieldName
fn r
ft 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
    kont' SP
FreeText = r
ft

-- | 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 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
$cfmap :: forall s a b. (a -> b) -> FieldDescrs s a -> FieldDescrs s b
fmap :: forall a b. (a -> b) -> FieldDescrs s a -> FieldDescrs s b
$c<$ :: forall s a b. a -> FieldDescrs s b -> FieldDescrs s a
<$ :: forall a b. a -> FieldDescrs s b -> FieldDescrs s a
Functor)

coerceFieldDescrs :: FieldDescrs s a -> FieldDescrs () ()
coerceFieldDescrs :: forall s a. 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 :: forall a. 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 <*> :: forall a b.
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 :: 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 = 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 m 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) = Map FieldName SP -> FieldDescrs a d
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 = 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 m Bool
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 :: 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
_ =
        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
forall (m :: * -> *). CabalParsing m => m b
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)
_ =
        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
forall (m :: * -> *). CabalParsing m => m b
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 =
        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
forall (m :: * -> *). CabalParsing m => m b
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 :: 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
_ =
        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
forall (m :: * -> *). CabalParsing m => m b
C.parsec)

    freeTextField :: forall s.
FieldName
-> ALens' s (Maybe String) -> FieldDescrs s (Maybe String)
freeTextField      FieldName
fn ALens' s (Maybe String)
_ = Map FieldName SP -> FieldDescrs s (Maybe String)
forall s a. Map FieldName SP -> FieldDescrs s a
F (Map FieldName SP -> FieldDescrs s (Maybe String))
-> Map FieldName SP -> FieldDescrs s (Maybe String)
forall a b. (a -> b) -> a -> b
$ FieldName -> SP -> Map FieldName SP
forall k a. k -> a -> Map k a
Map.singleton FieldName
fn SP
FreeText
    freeTextFieldDef :: forall s. FieldName -> ALens' s String -> FieldDescrs s String
freeTextFieldDef   FieldName
fn ALens' s String
_ = Map FieldName SP -> FieldDescrs s String
forall s a. Map FieldName SP -> FieldDescrs s a
F (Map FieldName SP -> FieldDescrs s String)
-> Map FieldName SP -> FieldDescrs s String
forall a b. (a -> b) -> a -> b
$ FieldName -> SP -> Map FieldName SP
forall k a. k -> a -> Map k a
Map.singleton FieldName
fn SP
FreeText
    freeTextFieldDefST :: forall s.
FieldName -> ALens' s ShortText -> FieldDescrs s ShortText
freeTextFieldDefST FieldName
fn ALens' s ShortText
_ = Map FieldName SP -> FieldDescrs s ShortText
forall s a. Map FieldName SP -> FieldDescrs s a
F (Map FieldName SP -> FieldDescrs s ShortText)
-> Map FieldName SP -> FieldDescrs s ShortText
forall a b. (a -> b) -> a -> b
$ FieldName -> SP -> Map FieldName SP
forall k a. k -> a -> Map k a
Map.singleton FieldName
fn SP
FreeText

    prefixedFields :: forall s.
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 :: forall s. FieldName -> FieldDescrs s ()
knownField FieldName
_           = () -> FieldDescrs s ()
forall a. a -> FieldDescrs s a
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
_     = FieldDescrs s a -> FieldDescrs s a
forall a. a -> a
id
    hiddenField :: forall s a. 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

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