{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
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
{ 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 -> s -> m s
forall s. SP s -> forall (m :: * -> *). CabalParsing m => s -> m s
pParse (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 FieldDescrs where
blurFieldGrammar :: ALens' a b -> FieldDescrs b c -> FieldDescrs a c
blurFieldGrammar ALens' a b
l (F Map FieldName (SP b)
m) = Map FieldName (SP a) -> FieldDescrs a c
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
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))
trim :: String -> String
trim :: String -> String
trim = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace