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