{-# 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 Parsec String () (Text, Maybe Text)
-> String -> String -> Either ParseError (Text, Maybe Text)
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               -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> (ParseError -> String) -> ParseError -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show (ParseError -> Q Exp) -> ParseError -> Q Exp
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
_ = String -> Q Pat
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
  ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  (Text, Maybe Text)
res <- Parsec String () (Text, Maybe Text)
-> Parsec String () (Text, Maybe Text)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parsec String () (Text, Maybe Text)
withType Parsec String () (Text, Maybe Text)
-> Parsec String () (Text, Maybe Text)
-> Parsec String () (Text, Maybe Text)
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
  ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  (Text, Maybe Text) -> Parsec String () (Text, Maybe Text)
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 <- ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
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 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String () Identity Char -> ParsecT String () Identity Char
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space)
      case String
name of
        [] -> String -> Parsec String () (Text, Maybe Text)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot have an empty field name."
        String
_ -> do
          ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
          String
_ <- String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"::"
          ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
          String
typ <- ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
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 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String () Identity Char -> ParsecT String () Identity Char
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space)
          case String
typ of
            [] -> String -> Parsec String () (Text, Maybe Text)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot have an empty type."
            String
_  -> (Text, Maybe Text) -> Parsec String () (Text, Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
pack String
name, Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (String -> Text) -> String -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Maybe Text) -> String -> Maybe Text
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 <- ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
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 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String () Identity Char -> ParsecT String () Identity Char
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space)
      case String
name of
        [] -> String -> Parsec String () (Text, Maybe Text)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot have an empty field name."
        String
_  -> (Text, Maybe Text) -> Parsec String () (Text, Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
pack String
name, Maybe Text
forall a. Maybe a
Nothing)

errorFieldType :: String -> Q Type
errorFieldType :: String -> Q Type
errorFieldType String
_ = String -> Q Type
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
_ = String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot use 'field' in a declaration context."