{-# 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
    { pPretty :: !(s -> Disp.Doc)
    , pParse  :: !(forall m. P.CabalParsing m => s -> m s)
    }

-- | A collection field parsers and pretty-printers.
newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) }
  deriving (Functor)

instance Applicative (FieldDescrs s) where
    pure _  = F mempty
    f <*> x = F (mappend (runF f) (runF x))

singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a
singletonF fn f g = F $ Map.singleton fn (SP f g)

-- | Lookup a field value pretty-printer.
fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc)
fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m

-- | Lookup a field value parser.
fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s)
fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m

fieldDescrsToList
    :: P.CabalParsing m
    => FieldDescrs s a
    -> [(P.FieldName, s -> Disp.Doc, s -> m s)]
fieldDescrsToList = map mk . Map.toList . runF where
    mk (name, SP ppr parse) = (name, ppr, parse)

-- | /Note:/ default values are printed.
instance FieldGrammar ParsecPretty FieldDescrs where
    blurFieldGrammar l (F m) = F (fmap blur m) where
        blur (SP f g) = SP (f . aview l) (cloneLens l g)

    booleanFieldDef fn l _def = singletonF fn f g where
        f s = Disp.text (show (aview l s))
        g s = cloneLens l (const P.parsec) s
      -- Note: eta expansion is needed for RankNTypes type-checking to work.

    uniqueFieldAla fn _pack l = singletonF fn f g where
        f s = pretty (pack' _pack (aview l s))
        g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s

    optionalFieldAla fn _pack l = singletonF fn f g where
        f s = maybe mempty (pretty . pack' _pack) (aview l s)
        g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s

    optionalFieldDefAla fn _pack l _def = singletonF fn f g where
        f s = pretty (pack' _pack (aview l s))
        g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s

    freeTextField fn l = singletonF fn f g where
        f s = maybe mempty showFreeText (aview l s)
        g s = cloneLens l (const (Just <$> parsecFreeText)) s

    freeTextFieldDef fn l = singletonF fn f g where
        f s = showFreeText (aview l s)
        g s = cloneLens l (const parsecFreeText) s

    freeTextFieldDefST = defaultFreeTextFieldDefST

    monoidalFieldAla fn _pack l = singletonF fn f g where
        f s = pretty (pack' _pack (aview l s))
        g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s

    prefixedFields _fnPfx _l = F mempty
    knownField _           = pure ()
    deprecatedSince _  _ x = x
    removedIn _ _ x        = x
    availableSince _ _     = id
    hiddenField _          = F mempty

parsecFreeText :: P.CabalParsing m => m String
parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar
  where
    -- Example package with dot lines
    -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal
    dropDotLines "." = "."
    dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x

    dotToEmpty x | trim' x == "." = ""
    dotToEmpty x                  = trim x

    trim' :: String -> String
    trim' = dropWhileEnd (`elem` (" \t" :: String))

    trim :: String -> String
    trim = dropWhile isSpace . dropWhileEnd isSpace

class    (P.Parsec a, Pretty a) => ParsecPretty a
instance (P.Parsec a, Pretty a) => ParsecPretty a