    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE OverloadedStrings #-}

    module Database.Persist.Quasi.Internal.TypeParser
        ( TypeExpr (..)
        , TypeConstructor (..)
        , typeExpr
        , innerTypeExpr
        , typeExprContent
        ) where

    import Data.Text (Text)
    import qualified Data.Text as T
    import Text.Megaparsec
    import Text.Megaparsec.Char
    import qualified Text.Megaparsec.Char.Lexer as L

    -- | A parsed type expression.
    --
    -- @since 2.17.1.0
    data TypeExpr
        = TypeApplication TypeExpr [TypeExpr]
        | TypeConstructorExpr TypeConstructor
        | TypeLitString String
        | TypeLitInt String
        | TypeLitPromotedConstructor TypeConstructor
        deriving (Int -> TypeExpr -> ShowS
    [TypeExpr] -> ShowS
    TypeExpr -> String
    (Int -> TypeExpr -> ShowS)
    -> (TypeExpr -> String) -> ([TypeExpr] -> ShowS) -> Show TypeExpr
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> TypeExpr -> ShowS
    showsPrec :: Int -> TypeExpr -> ShowS
    $cshow :: TypeExpr -> String
    show :: TypeExpr -> String
    $cshowList :: [TypeExpr] -> ShowS
    showList :: [TypeExpr] -> ShowS
    Show, TypeExpr -> TypeExpr -> Bool
    (TypeExpr -> TypeExpr -> Bool)
    -> (TypeExpr -> TypeExpr -> Bool) -> Eq TypeExpr
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: TypeExpr -> TypeExpr -> Bool
    == :: TypeExpr -> TypeExpr -> Bool
    $c/= :: TypeExpr -> TypeExpr -> Bool
    /= :: TypeExpr -> TypeExpr -> Bool
    Eq)

    -- | A parsed type constructor.
    --
    -- @since 2.17.1.0
    data TypeConstructor
        = ListConstructor
        | TypeConstructor String
        deriving (Int -> TypeConstructor -> ShowS
    [TypeConstructor] -> ShowS
    TypeConstructor -> String
    (Int -> TypeConstructor -> ShowS)
    -> (TypeConstructor -> String)
    -> ([TypeConstructor] -> ShowS)
    -> Show TypeConstructor
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> TypeConstructor -> ShowS
    showsPrec :: Int -> TypeConstructor -> ShowS
    $cshow :: TypeConstructor -> String
    show :: TypeConstructor -> String
    $cshowList :: [TypeConstructor] -> ShowS
    showList :: [TypeConstructor] -> ShowS
    Show, TypeConstructor -> TypeConstructor -> Bool
    (TypeConstructor -> TypeConstructor -> Bool)
    -> (TypeConstructor -> TypeConstructor -> Bool)
    -> Eq TypeConstructor
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: TypeConstructor -> TypeConstructor -> Bool
    == :: TypeConstructor -> TypeConstructor -> Bool
    $c/= :: TypeConstructor -> TypeConstructor -> Bool
    /= :: TypeConstructor -> TypeConstructor -> Bool
    Eq)

    -- | Parses a Persistent-style type expression.
    -- Persistent's type expressions are largely similar to Haskell's, but with a few differences:
    --
    -- 1. Syntactic sugar is not currently supported for constructing types other than List.
    -- 2. Only certain typelevel literals are supported: Strings, Ints, and promoted type constructors.
    -- 3. Because they must be parsed as part of an entity field definition, top-level applications
    --    of non-nullary type constructors (except for the sugary List constructor) must
    --    be parenthesized.
    --
    --    VALID:    Int
    --    VALID:    [Maybe Int]
    --    VALID:    (Maybe Int)
    --    INVALID:  Maybe Int
    --
    -- @since 2.17.1.0
    typeExpr :: ((MonadParsec e String) m) => m TypeExpr
    typeExpr :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    typeExpr = IsInner -> m TypeExpr
    forall e (m :: * -> *).
    MonadParsec e String m =>
    IsInner -> m TypeExpr
    typeExpr' IsInner
    Outer

    -- | Parses a type expression in non-top-level contexts, where an unparenthesized type constructor
    -- application is acceptable.
    --
    -- @since 2.17.1.0
    innerTypeExpr :: ((MonadParsec e String) m) => m TypeExpr
    innerTypeExpr :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    innerTypeExpr = IsInner -> m TypeExpr
    forall e (m :: * -> *).
    MonadParsec e String m =>
    IsInner -> m TypeExpr
    typeExpr' IsInner
    Inner

    data IsInner = Inner | Outer

    typeExpr' :: ((MonadParsec e String) m) => IsInner -> m TypeExpr
    typeExpr' :: forall e (m :: * -> *).
    MonadParsec e String m =>
    IsInner -> m TypeExpr
    typeExpr' IsInner
    isInner = String -> m TypeExpr -> m TypeExpr
    forall a. String -> m a -> m a
    forall e s (m :: * -> *) a.
    MonadParsec e s m =>
    String -> m a -> m a
    label String
    "type expression" (m TypeExpr -> m TypeExpr) -> m TypeExpr -> m TypeExpr
    forall a b. (a -> b) -> a -> b
    $ do
        let
            validEmbeddedApplications :: [m TypeExpr]
    validEmbeddedApplications = case IsInner
    isInner of
                IsInner
    Inner ->
                    [ m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    simpleTypeApplication
                    , m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    complexTypeApplication
                    ]
                IsInner
    Outer -> [m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    nullaryTypeApplication]
        [m TypeExpr] -> m TypeExpr
    forall (f :: * -> *) (m :: * -> *) a.
    (Foldable f, Alternative m) =>
    f (m a) -> m a
    choice ([m TypeExpr] -> m TypeExpr) -> [m TypeExpr] -> m TypeExpr
    forall a b. (a -> b) -> a -> b
    $
            [m TypeExpr]
    validEmbeddedApplications
                [m TypeExpr] -> [m TypeExpr] -> [m TypeExpr]
    forall a. [a] -> [a] -> [a]
    ++ [ Char -> Char -> m TypeExpr -> m TypeExpr
    forall e (m :: * -> *) a.
    MonadParsec e String m =>
    Char -> Char -> m a -> m a
    whitespaceBetween Char
    '(' Char
    ')' m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    innerTypeExpr
                   , m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    listType
                   , m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    typeLitPromotedConstructor
                   , m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    typeLitString
                   , m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    typeLitInt
                   ]
      where
        -- This is a proper subset of `simpleTypeApplication`.
        nullaryTypeApplication :: ((MonadParsec e String) m) => m TypeExpr
        nullaryTypeApplication :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    nullaryTypeApplication = do
            tc <- m TypeConstructor
    forall e (m :: * -> *). MonadParsec e String m => m TypeConstructor
    typeConstructor m TypeConstructor -> m (Maybe ()) -> m TypeConstructor
    forall a b. m a -> m b -> m a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* m () -> m (Maybe ())
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
    optional m ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace
            pure $ TypeApplication (TypeConstructorExpr tc) []

    -- This does not parse sugary constructors such as the List constructor `[]`.
    typeConstructor :: ((MonadParsec e String) m) => m TypeConstructor
    typeConstructor :: forall e (m :: * -> *). MonadParsec e String m => m TypeConstructor
    typeConstructor = do
        first <- m Char
    m (Token String)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m (Token s)
    upperChar
        rest <- many $ choice [alphaNumChar, char '.', char '\'']
        pure $ TypeConstructor (first : rest)

    whitespaceBetween :: ((MonadParsec e String) m) => Char -> Char -> m a -> m a
    whitespaceBetween :: forall e (m :: * -> *) a.
    MonadParsec e String m =>
    Char -> Char -> m a -> m a
    whitespaceBetween Char
    ldelim Char
    rdelim =
        m (Maybe ()) -> m Char -> m a -> m a
    forall (m :: * -> *) open close a.
    Applicative m =>
    m open -> m close -> m a -> m a
    between (Token String -> m (Token String)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    Token s -> m (Token s)
    char Char
    Token String
    ldelim m Char -> m (Maybe ()) -> m (Maybe ())
    forall a b. m a -> m b -> m b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> m () -> m (Maybe ())
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
    optional m ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace) (m () -> m (Maybe ())
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
    optional m ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace m (Maybe ()) -> m Char -> m Char
    forall a b. m a -> m b -> m b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Token String -> m (Token String)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    Token s -> m (Token s)
    char Char
    Token String
    rdelim)

    complexTypeApplication :: ((MonadParsec e String) m) => m TypeExpr
    complexTypeApplication :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    complexTypeApplication = do
        t <- Char -> Char -> m TypeExpr -> m TypeExpr
    forall e (m :: * -> *) a.
    MonadParsec e String m =>
    Char -> Char -> m a -> m a
    whitespaceBetween Char
    '(' Char
    ')' m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    innerTypeExpr m TypeExpr -> m () -> m TypeExpr
    forall a b. m a -> m b -> m a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* m ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace
        args <- some (typeExpr <* optional hspace)
        pure $ TypeApplication t args

    simpleTypeApplication :: ((MonadParsec e String) m) => m TypeExpr
    simpleTypeApplication :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    simpleTypeApplication = do
        tc <- m TypeConstructor
    forall e (m :: * -> *). MonadParsec e String m => m TypeConstructor
    typeConstructor m TypeConstructor -> m (Maybe ()) -> m TypeConstructor
    forall a b. m a -> m b -> m a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* m () -> m (Maybe ())
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
    optional m ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace
        args <- many (typeExpr <* optional hspace)
        pure $ TypeApplication (TypeConstructorExpr tc) args

    typeLitString :: ((MonadParsec e String) m) => m TypeExpr
    typeLitString :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    typeLitString = do
        s <- Token String -> m (Token String)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    Token s -> m (Token s)
    char Char
    Token String
    '"' m Char -> m String -> m String
    forall a b. m a -> m b -> m b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> m Char -> m Char -> m String
    forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
    manyTill m Char
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m Char
    L.charLiteral (Token String -> m (Token String)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    Token s -> m (Token s)
    char Char
    Token String
    '"')
        pure $ TypeLitString s

    typeLitInt :: ((MonadParsec e String) m) => m TypeExpr
    typeLitInt :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    typeLitInt = String -> TypeExpr
    TypeLitInt (String -> TypeExpr) -> m String -> m TypeExpr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> m Char -> m String
    forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
    some m Char
    m (Token String)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m (Token s)
    digitChar

    typeLitPromotedConstructor :: ((MonadParsec e String) m) => m TypeExpr
    typeLitPromotedConstructor :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    typeLitPromotedConstructor = do
        _ <- Token String -> m (Token String)
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    Token s -> m (Token s)
    char Char
    Token String
    '\'' m Char -> m (Maybe ()) -> m Char
    forall a b. m a -> m b -> m a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* m () -> m (Maybe ())
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
    optional m ()
    forall e s (m :: * -> *).
    (MonadParsec e s m, Token s ~ Char) =>
    m ()
    hspace
        TypeLitPromotedConstructor <$> typeConstructor

    listType :: ((MonadParsec e String) m) => m TypeExpr
    listType :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    listType = do
        t <- Char -> Char -> m TypeExpr -> m TypeExpr
    forall e (m :: * -> *) a.
    MonadParsec e String m =>
    Char -> Char -> m a -> m a
    whitespaceBetween Char
    '[' Char
    ']' m TypeExpr
    forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
    innerTypeExpr
        pure $ TypeApplication (TypeConstructorExpr ListConstructor) [t]

    -- | Given a TypeExpr, renders it back to a String in a canonical form that looks
    -- normal to humans and is re-parseable when making an UnboundEntityDef that uses it.
    --
    -- @since 2.17.1.0
    typeExprContent :: TypeExpr -> Text
    typeExprContent :: TypeExpr -> Text
    typeExprContent = IsInner -> TypeExpr -> Text
    typeExprContent' IsInner
    Outer

    -- This is a little gnarly-looking. That's mostly due to attempting to avoid inserting
    -- superfluous parentheses.
    typeExprContent' :: IsInner -> TypeExpr -> Text
    typeExprContent' :: IsInner -> TypeExpr -> Text
    typeExprContent' IsInner
    isInner = \case
        TypeLitString String
    s ->
            [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat
                [ Text
    "\""
                , String -> Text
    T.pack String
    s
                , Text
    "\""
                ]
        TypeLitInt String
    s -> String -> Text
    T.pack String
    s
        TypeLitPromotedConstructor TypeConstructor
    tc -> Text
    "'" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> IsInner -> TypeExpr -> Text
    typeExprContent' IsInner
    isInner (TypeConstructor -> TypeExpr
    TypeConstructorExpr TypeConstructor
    tc)
        TypeConstructorExpr (TypeConstructor String
    s) -> String -> Text
    T.pack String
    s
        TypeConstructorExpr TypeConstructor
    ListConstructor -> Text
    "List"
        TypeApplication (TypeConstructorExpr TypeConstructor
    tc) [TypeExpr]
    args -> TypeConstructor -> [TypeExpr] -> IsInner -> Text
    simpleTypeApplicationContent TypeConstructor
    tc [TypeExpr]
    args IsInner
    isInner
        TypeApplication TypeExpr
    t [TypeExpr]
    exps ->
            [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat
                [ IsInner -> TypeExpr -> Text
    typeExprContent' IsInner
    Inner TypeExpr
    t
                , Text
    " "
                , Text -> [Text] -> Text
    T.intercalate Text
    " " ([Text] -> Text) -> [Text] -> Text
    forall a b. (a -> b) -> a -> b
    $ (TypeExpr -> Text) -> [TypeExpr] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap TypeExpr -> Text
    typeExprContent [TypeExpr]
    exps
                ]
      where
        typeArgsListContent :: IsInner -> [TypeExpr] -> Text
        typeArgsListContent :: IsInner -> [TypeExpr] -> Text
    typeArgsListContent IsInner
    i [TypeExpr]
    exps = Text -> [Text] -> Text
    T.intercalate Text
    " " ([Text] -> Text) -> [Text] -> Text
    forall a b. (a -> b) -> a -> b
    $ (TypeExpr -> Text) -> [TypeExpr] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (IsInner -> TypeExpr -> Text
    typeExprContent' IsInner
    i) [TypeExpr]
    exps

        simpleTypeApplicationContent :: TypeConstructor -> [TypeExpr] -> IsInner -> Text
        simpleTypeApplicationContent :: TypeConstructor -> [TypeExpr] -> IsInner -> Text
    simpleTypeApplicationContent TypeConstructor
    ListConstructor [TypeExpr]
    args IsInner
    _ =
            [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat
                [ Text
    "["
                , IsInner -> [TypeExpr] -> Text
    typeArgsListContent IsInner
    Outer [TypeExpr]
    args
                , Text
    "]"
                ]
        simpleTypeApplicationContent (TypeConstructor String
    s) [] IsInner
    _ = String -> Text
    T.pack String
    s
        simpleTypeApplicationContent (TypeConstructor String
    s) [TypeExpr]
    exps IsInner
    Inner =
            [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat
                [ Text
    "("
                , TypeConstructor -> [TypeExpr] -> IsInner -> Text
    simpleTypeApplicationContent (String -> TypeConstructor
    TypeConstructor String
    s) [TypeExpr]
    exps IsInner
    Outer
                , Text
    ")"
                ]
        simpleTypeApplicationContent (TypeConstructor String
    s) [TypeExpr]
    exps IsInner
    Outer =
            [Text] -> Text
    forall a. Monoid a => [a] -> a
    mconcat
                [ String -> Text
    T.pack String
    s
                , Text
    " "
                , IsInner -> [TypeExpr] -> Text
    typeArgsListContent IsInner
    Inner [TypeExpr]
    exps
                ]