{-# 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
data SP where
FreeText :: SP
SP :: !(f -> PP.Doc)
-> !(forall m. C.CabalParsing m => m f)
-> SP
fieldDescrLookup
:: C.CabalParsing m
=> FieldDescrs s a
-> C.FieldName
-> r
-> (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
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