{-# LANGUAGE TemplateHaskell #-}

{-|
 Module     : Database.PostgreSQL.Entity.Internal.QQ
 Copyright  : © Koz Ross, 2021
 License    : MIT
 Maintainer : koz.ross@retro-freedom.nz
 Stability  : Experimental

 A quasi-quoter for 'Field's, supporting optional types.

 There is little reason to import this module directly; instead, import
 'Database.PostgreSQL.Entity', which re-exports the 'field' quasiquoter.
-}
module Database.PostgreSQL.Entity.Internal.QQ (field) where

import Data.Text (Text, pack)
import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field))
import Language.Haskell.TH (Dec, Exp, Pat, Q, Type)
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
import Language.Haskell.TH.Syntax (lift)
import Text.Parsec (Parsec, anyChar, manyTill, parse, space, spaces, string, try, (<|>))

{-| A quasi-quoter for safely constructing 'Field's.

 == Example:

 > instance Entity BlogPost where
 >   tableName  = "blogposts"
 >   primaryKey = [field| blogpost_id |]
 >   fields = [ [field| blogpost_id |]
 >            , [field| author_id |]
 >            , [field| uuid_list :: uuid[] |] -- ← This is where we specify an optional PostgreSQL type annotation
 >            , [field| title |]
 >            , [field| content |]
 >            , [field| created_at |]
 >            ]

 @since 0.1.0.0
-}
field :: QuasiQuoter
field :: QuasiQuoter
field = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter String -> Q Exp
fieldExp String -> Q Pat
errorFieldPat String -> Q Type
errorFieldType String -> Q [Dec]
errorFieldDec

-- Helpers

fieldExp :: String -> Q Exp
fieldExp :: String -> Q Exp
fieldExp String
input = case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () (Text, Maybe Text)
fieldParser String
"Expression" String
input of
  Left ParseError
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ ParseError
err
  Right (Text
name, Maybe Text
Nothing) -> [e|Field $(lift name) Nothing|]
  Right (Text
name, Just Text
typ) -> [e|Field $(lift name) (Just $(lift typ))|]

errorFieldPat :: String -> Q Pat
errorFieldPat :: String -> Q Pat
errorFieldPat String
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot use 'field' in a pattern context."

fieldParser :: Parsec String () (Text, Maybe Text)
fieldParser :: Parsec String () (Text, Maybe Text)
fieldParser = do
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  (Text, Maybe Text)
res <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec String () (Text, Maybe Text)
withType forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec String () (Text, Maybe Text)
noType
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text, Maybe Text)
res
  where
    withType :: Parsec String () (Text, Maybe Text)
    withType :: Parsec String () (Text, Maybe Text)
withType = do
      String
name <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space)
      case String
name of
        [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot have an empty field name."
        String
_ -> do
          forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
          String
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"::"
          forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
          String
typ <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space)
          case String
typ of
            [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot have an empty type."
            String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
pack String
name, forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall a b. (a -> b) -> a -> b
$ String
typ)
    noType :: Parsec String () (Text, Maybe Text)
    noType :: Parsec String () (Text, Maybe Text)
noType = do
      String
name <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space)
      case String
name of
        [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot have an empty field name."
        String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
pack String
name, forall a. Maybe a
Nothing)

errorFieldType :: String -> Q Type
errorFieldType :: String -> Q Type
errorFieldType String
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot use 'field' in a type context."

errorFieldDec :: String -> Q [Dec]
errorFieldDec :: String -> Q [Dec]
errorFieldDec String
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot use 'field' in a declaration context."