{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Distribution.FieldGrammar.FieldDescrs (
FieldDescrs,
fieldDescrPretty,
fieldDescrParse,
fieldDescrsToList,
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.Lens (aview, cloneLens)
import Distribution.Utils.String (trim)
import Distribution.Compat.Newtype
import Distribution.FieldGrammar
import Distribution.Pretty (Pretty (..), showFreeText)
import qualified Data.Map as Map
import qualified Distribution.Compat.CharParsing as C
import qualified Distribution.Fields as P
import qualified Distribution.Parsec as P
import qualified Text.PrettyPrint as Disp
data SP s = SP
{ SP s -> s -> Doc
pPretty :: !(s -> Disp.Doc)
, SP s -> forall (m :: * -> *). CabalParsing m => s -> m s
pParse :: !(forall m. P.CabalParsing m => s -> m s)
}
newtype FieldDescrs s a = F { FieldDescrs s a -> Map FieldName (SP s)
runF :: Map P.FieldName (SP s) }
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)
instance Applicative (FieldDescrs s) where
pure :: a -> FieldDescrs s a
pure a
_ = Map FieldName (SP s) -> FieldDescrs s a
forall s a. Map FieldName (SP s) -> FieldDescrs s a
F Map FieldName (SP s)
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 s) -> FieldDescrs s b
forall s a. Map FieldName (SP s) -> FieldDescrs s a
F (Map FieldName (SP s)
-> Map FieldName (SP s) -> Map FieldName (SP s)
forall a. Monoid a => a -> a -> a
mappend (FieldDescrs s (a -> b) -> Map FieldName (SP s)
forall s a. FieldDescrs s a -> Map FieldName (SP s)
runF FieldDescrs s (a -> b)
f) (FieldDescrs s a -> Map FieldName (SP s)
forall s a. FieldDescrs s a -> Map FieldName (SP s)
runF FieldDescrs s a
x))
singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a
singletonF :: FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
singletonF FieldName
fn s -> Doc
f forall (m :: * -> *). CabalParsing m => s -> m s
g = Map FieldName (SP s) -> FieldDescrs s a
forall s a. Map FieldName (SP s) -> FieldDescrs s a
F (Map FieldName (SP s) -> FieldDescrs s a)
-> Map FieldName (SP s) -> FieldDescrs s a
forall a b. (a -> b) -> a -> b
$ FieldName -> SP s -> Map FieldName (SP s)
forall k a. k -> a -> Map k a
Map.singleton FieldName
fn ((s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s) -> SP s
forall s.
(s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s) -> SP s
SP s -> Doc
f forall (m :: * -> *). CabalParsing m => s -> m s
g)
fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc)
fieldDescrPretty :: FieldDescrs s a -> FieldName -> Maybe (s -> Doc)
fieldDescrPretty (F Map FieldName (SP s)
m) FieldName
fn = SP s -> s -> Doc
forall s. SP s -> s -> Doc
pPretty (SP s -> s -> Doc) -> Maybe (SP s) -> Maybe (s -> Doc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName -> Map FieldName (SP s) -> Maybe (SP s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Map FieldName (SP s)
m
fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s)
fieldDescrParse :: FieldDescrs s a -> FieldName -> Maybe (s -> m s)
fieldDescrParse (F Map FieldName (SP s)
m) FieldName
fn = (\SP s
f -> SP s -> forall (m :: * -> *). CabalParsing m => s -> m s
forall s. SP s -> forall (m :: * -> *). CabalParsing m => s -> m s
pParse SP s
f) (SP s -> s -> m s) -> Maybe (SP s) -> Maybe (s -> m s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName -> Map FieldName (SP s) -> Maybe (SP s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Map FieldName (SP s)
m
fieldDescrsToList
:: P.CabalParsing m
=> FieldDescrs s a
-> [(P.FieldName, s -> Disp.Doc, s -> m s)]
fieldDescrsToList :: FieldDescrs s a -> [(FieldName, s -> Doc, s -> m s)]
fieldDescrsToList = ((FieldName, SP s) -> (FieldName, s -> Doc, s -> m s))
-> [(FieldName, SP s)] -> [(FieldName, s -> Doc, s -> m s)]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, SP s) -> (FieldName, s -> Doc, s -> m s)
forall (m :: * -> *) a s.
CabalParsing m =>
(a, SP s) -> (a, s -> Doc, s -> m s)
mk ([(FieldName, SP s)] -> [(FieldName, s -> Doc, s -> m s)])
-> (FieldDescrs s a -> [(FieldName, SP s)])
-> FieldDescrs s a
-> [(FieldName, s -> Doc, s -> m s)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FieldName (SP s) -> [(FieldName, SP s)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map FieldName (SP s) -> [(FieldName, SP s)])
-> (FieldDescrs s a -> Map FieldName (SP s))
-> FieldDescrs s a
-> [(FieldName, SP s)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDescrs s a -> Map FieldName (SP s)
forall s a. FieldDescrs s a -> Map FieldName (SP s)
runF where
mk :: (a, SP s) -> (a, s -> Doc, s -> m s)
mk (a
name, SP s -> Doc
ppr forall (m :: * -> *). CabalParsing m => s -> m s
parse) = (a
name, s -> Doc
ppr, s -> m s
forall (m :: * -> *). CabalParsing m => s -> m s
parse)
instance FieldGrammar ParsecPretty FieldDescrs where
blurFieldGrammar :: ALens' a b -> FieldDescrs b d -> FieldDescrs a d
blurFieldGrammar ALens' a b
l (F Map FieldName (SP b)
m) = Map FieldName (SP a) -> FieldDescrs a d
forall s a. Map FieldName (SP s) -> FieldDescrs s a
F ((SP b -> SP a) -> Map FieldName (SP b) -> Map FieldName (SP a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SP b -> SP a
blur Map FieldName (SP b)
m) where
blur :: SP b -> SP a
blur (SP b -> Doc
f forall (m :: * -> *). CabalParsing m => b -> m b
g) = (a -> Doc)
-> (forall (m :: * -> *). CabalParsing m => a -> m a) -> SP a
forall s.
(s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s) -> SP s
SP (b -> Doc
f (b -> Doc) -> (a -> b) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ALens' a b -> a -> b
forall s t a b. ALens s t a b -> s -> a
aview ALens' a b
l) (ALens' a b -> LensLike m a a b b
forall (f :: * -> *) s t a b.
Functor f =>
ALens s t a b -> LensLike f s t a b
cloneLens ALens' a b
l b -> m b
forall (m :: * -> *). CabalParsing m => b -> m b
g)
booleanFieldDef :: FieldName -> ALens' s Bool -> Bool -> FieldDescrs s Bool
booleanFieldDef FieldName
fn ALens' s Bool
l Bool
_def = FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s Bool
forall s a.
FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
singletonF FieldName
fn s -> Doc
f forall (m :: * -> *). CabalParsing m => s -> m s
g where
f :: s -> Doc
f s
s = String -> Doc
Disp.text (Bool -> String
forall a. Show a => a -> String
show (ALens' s Bool -> s -> Bool
forall s t a b. ALens s t a b -> s -> a
aview ALens' s Bool
l s
s))
g :: s -> f s
g s
s = ALens' s Bool -> LensLike f s s Bool Bool
forall (f :: * -> *) s t a b.
Functor f =>
ALens s t a b -> LensLike f s t a b
cloneLens ALens' s Bool
l (f Bool -> Bool -> f Bool
forall a b. a -> b -> a
const f Bool
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
P.parsec) s
s
uniqueFieldAla :: FieldName -> (a -> b) -> ALens' s a -> FieldDescrs s a
uniqueFieldAla FieldName
fn a -> b
_pack ALens' s a
l = FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
forall s a.
FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
singletonF FieldName
fn s -> Doc
f forall (m :: * -> *). CabalParsing m => s -> m s
g where
f :: s -> Doc
f s
s = b -> Doc
forall a. Pretty a => a -> Doc
pretty ((a -> b) -> a -> b
forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack (ALens' s a -> s -> a
forall s t a b. ALens s t a b -> s -> a
aview ALens' s a
l s
s))
g :: s -> f s
g s
s = ALens' s a -> LensLike f s s a a
forall (f :: * -> *) s t a b.
Functor f =>
ALens s t a b -> LensLike f s t a b
cloneLens ALens' s a
l (f a -> a -> f a
forall a b. a -> b -> a
const ((a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> a) -> f b -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
P.parsec)) s
s
optionalFieldAla :: FieldName
-> (a -> b) -> ALens' s (Maybe a) -> FieldDescrs s (Maybe a)
optionalFieldAla FieldName
fn a -> b
_pack ALens' s (Maybe a)
l = FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s (Maybe a)
forall s a.
FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
singletonF FieldName
fn s -> Doc
f forall (m :: * -> *). CabalParsing m => s -> m s
g where
f :: s -> Doc
f s
s = Doc -> (a -> Doc) -> Maybe a -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty (b -> Doc
forall a. Pretty a => a -> Doc
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) (ALens' s (Maybe a) -> s -> Maybe a
forall s t a b. ALens s t a b -> s -> a
aview ALens' s (Maybe a)
l s
s)
g :: s -> f s
g s
s = ALens' s (Maybe a) -> LensLike f s s (Maybe a) (Maybe a)
forall (f :: * -> *) s t a b.
Functor f =>
ALens s t a b -> LensLike f s t a b
cloneLens ALens' s (Maybe a)
l (f (Maybe a) -> Maybe a -> f (Maybe a)
forall a b. a -> b -> a
const (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (b -> a) -> b -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> Maybe a) -> f b -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
P.parsec)) s
s
optionalFieldDefAla :: FieldName -> (a -> b) -> ALens' s a -> a -> FieldDescrs s a
optionalFieldDefAla FieldName
fn a -> b
_pack ALens' s a
l a
_def = FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
forall s a.
FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
singletonF FieldName
fn s -> Doc
f forall (m :: * -> *). CabalParsing m => s -> m s
g where
f :: s -> Doc
f s
s = b -> Doc
forall a. Pretty a => a -> Doc
pretty ((a -> b) -> a -> b
forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack (ALens' s a -> s -> a
forall s t a b. ALens s t a b -> s -> a
aview ALens' s a
l s
s))
g :: s -> f s
g s
s = ALens' s a -> LensLike f s s a a
forall (f :: * -> *) s t a b.
Functor f =>
ALens s t a b -> LensLike f s t a b
cloneLens ALens' s a
l (f a -> a -> f a
forall a b. a -> b -> a
const ((a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> a) -> f b -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
P.parsec)) s
s
freeTextField :: FieldName
-> ALens' s (Maybe String) -> FieldDescrs s (Maybe String)
freeTextField FieldName
fn ALens' s (Maybe String)
l = FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s (Maybe String)
forall s a.
FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
singletonF FieldName
fn s -> Doc
f forall (m :: * -> *). CabalParsing m => s -> m s
g where
f :: s -> Doc
f s
s = Doc -> (String -> Doc) -> Maybe String -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty String -> Doc
showFreeText (ALens' s (Maybe String) -> s -> Maybe String
forall s t a b. ALens s t a b -> s -> a
aview ALens' s (Maybe String)
l s
s)
g :: s -> f s
g s
s = ALens' s (Maybe String)
-> LensLike f s s (Maybe String) (Maybe String)
forall (f :: * -> *) s t a b.
Functor f =>
ALens s t a b -> LensLike f s t a b
cloneLens ALens' s (Maybe String)
l (f (Maybe String) -> Maybe String -> f (Maybe String)
forall a b. a -> b -> a
const (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> f String -> f (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f String
forall (m :: * -> *). CabalParsing m => m String
parsecFreeText)) s
s
freeTextFieldDef :: FieldName -> ALens' s String -> FieldDescrs s String
freeTextFieldDef FieldName
fn ALens' s String
l = FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s String
forall s a.
FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
singletonF FieldName
fn s -> Doc
f forall (m :: * -> *). CabalParsing m => s -> m s
g where
f :: s -> Doc
f s
s = String -> Doc
showFreeText (ALens' s String -> s -> String
forall s t a b. ALens s t a b -> s -> a
aview ALens' s String
l s
s)
g :: s -> f s
g s
s = ALens' s String -> LensLike f s s String String
forall (f :: * -> *) s t a b.
Functor f =>
ALens s t a b -> LensLike f s t a b
cloneLens ALens' s String
l (f String -> String -> f String
forall a b. a -> b -> a
const f String
forall (m :: * -> *). CabalParsing m => m String
parsecFreeText) s
s
freeTextFieldDefST :: FieldName -> ALens' s ShortText -> FieldDescrs s ShortText
freeTextFieldDefST = FieldName -> ALens' s ShortText -> FieldDescrs s ShortText
forall (g :: * -> * -> *) s (c :: * -> Constraint).
(Functor (g s), FieldGrammar c g) =>
FieldName -> ALens' s ShortText -> g s ShortText
defaultFreeTextFieldDefST
monoidalFieldAla :: FieldName -> (a -> b) -> ALens' s a -> FieldDescrs s a
monoidalFieldAla FieldName
fn a -> b
_pack ALens' s a
l = FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
forall s a.
FieldName
-> (s -> Doc)
-> (forall (m :: * -> *). CabalParsing m => s -> m s)
-> FieldDescrs s a
singletonF FieldName
fn s -> Doc
f forall (m :: * -> *). CabalParsing m => s -> m s
g where
f :: s -> Doc
f s
s = b -> Doc
forall a. Pretty a => a -> Doc
pretty ((a -> b) -> a -> b
forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack (ALens' s a -> s -> a
forall s t a b. ALens s t a b -> s -> a
aview ALens' s a
l s
s))
g :: s -> f s
g s
s = ALens' s a -> LensLike f s s a a
forall (f :: * -> *) s t a b.
Functor f =>
ALens s t a b -> LensLike f s t a b
cloneLens ALens' s a
l (\a
x -> a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
x (a -> a) -> (b -> a) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> a) -> f b -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
P.parsec) s
s
prefixedFields :: FieldName
-> ALens' s [(String, String)] -> FieldDescrs s [(String, String)]
prefixedFields FieldName
_fnPfx ALens' s [(String, String)]
_l = Map FieldName (SP s) -> FieldDescrs s [(String, String)]
forall s a. Map FieldName (SP s) -> FieldDescrs s a
F Map FieldName (SP s)
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 s) -> FieldDescrs s a
forall s a. Map FieldName (SP s) -> FieldDescrs s a
F Map FieldName (SP s)
forall a. Monoid a => a
mempty
parsecFreeText :: P.CabalParsing m => m String
parsecFreeText :: m String
parsecFreeText = String -> String
dropDotLines (String -> String) -> m () -> m (String -> String)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m ()
forall (m :: * -> *). CharParsing m => m ()
C.spaces m (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many m Char
forall (m :: * -> *). CharParsing m => m Char
C.anyChar
where
dropDotLines :: String -> String
dropDotLines String
"." = String
"."
dropDotLines String
x = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
dotToEmpty ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
x
dotToEmpty :: String -> String
dotToEmpty String
x | String -> String
trim' String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." = String
""
dotToEmpty String
x = String -> String
trim String
x
trim' :: String -> String
trim' :: String -> String
trim' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
" \t" :: String))
class (P.Parsec a, Pretty a) => ParsecPretty a
instance (P.Parsec a, Pretty a) => ParsecPretty a