{-# 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
        TypeConstructor
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
        TypeExpr -> m TypeExpr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeExpr -> m TypeExpr) -> TypeExpr -> m TypeExpr
forall a b. (a -> b) -> a -> b
$ TypeExpr -> [TypeExpr] -> TypeExpr
TypeApplication (TypeConstructor -> TypeExpr
TypeConstructorExpr TypeConstructor
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
    Char
first <- m Char
m (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
    String
rest <- m Char -> m String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m Char -> m String) -> m Char -> m String
forall a b. (a -> b) -> a -> b
$ [m Char] -> m Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [m Char
m (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar, 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
'.', 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
'\'']
    TypeConstructor -> m TypeConstructor
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeConstructor -> m TypeConstructor)
-> TypeConstructor -> m TypeConstructor
forall a b. (a -> b) -> a -> b
$ String -> TypeConstructor
TypeConstructor (Char
first Char -> ShowS
forall a. a -> [a] -> [a]
: String
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
    TypeExpr
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
    [TypeExpr]
args <- m TypeExpr -> m [TypeExpr]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (m TypeExpr
forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
typeExpr m TypeExpr -> m (Maybe ()) -> m TypeExpr
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)
    TypeExpr -> m TypeExpr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeExpr -> m TypeExpr) -> TypeExpr -> m TypeExpr
forall a b. (a -> b) -> a -> b
$ TypeExpr -> [TypeExpr] -> TypeExpr
TypeApplication TypeExpr
t [TypeExpr]
args

simpleTypeApplication :: ((MonadParsec e String) m) => m TypeExpr
simpleTypeApplication :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
simpleTypeApplication = do
    TypeConstructor
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
    [TypeExpr]
args <- m TypeExpr -> m [TypeExpr]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m TypeExpr
forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
typeExpr m TypeExpr -> m (Maybe ()) -> m TypeExpr
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)
    TypeExpr -> m TypeExpr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeExpr -> m TypeExpr) -> TypeExpr -> m TypeExpr
forall a b. (a -> b) -> a -> b
$ TypeExpr -> [TypeExpr] -> TypeExpr
TypeApplication (TypeConstructor -> TypeExpr
TypeConstructorExpr TypeConstructor
tc) [TypeExpr]
args

typeLitString :: ((MonadParsec e String) m) => m TypeExpr
typeLitString :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
typeLitString = do
    String
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
'"')
    TypeExpr -> m TypeExpr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeExpr -> m TypeExpr) -> TypeExpr -> m TypeExpr
forall a b. (a -> b) -> a -> b
$ String -> TypeExpr
TypeLitString String
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
    Char
_ <- 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
    TypeConstructor -> TypeExpr
TypeLitPromotedConstructor (TypeConstructor -> TypeExpr) -> m TypeConstructor -> m TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m TypeConstructor
forall e (m :: * -> *). MonadParsec e String m => m TypeConstructor
typeConstructor

listType :: ((MonadParsec e String) m) => m TypeExpr
listType :: forall e (m :: * -> *). MonadParsec e String m => m TypeExpr
listType = do
    TypeExpr
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
    TypeExpr -> m TypeExpr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeExpr -> m TypeExpr) -> TypeExpr -> m TypeExpr
forall a b. (a -> b) -> a -> b
$ TypeExpr -> [TypeExpr] -> TypeExpr
TypeApplication (TypeConstructor -> TypeExpr
TypeConstructorExpr TypeConstructor
ListConstructor) [TypeExpr
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
            ]