{-# 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

-- strict pair
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)
    }

-- | A collection of field parsers and pretty-printers.
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)

-- | Lookup a field value pretty-printer.
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

-- | Lookup a field value parser.
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)

-- | /Note:/ default values are printed.
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
      -- Note: eta expansion is needed for RankNTypes type-checking to work.

    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
    -- Example package with dot lines
    -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal
    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