{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

{-|
Module      :  Data.Aeson.Schema.TH.Getter
Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>
Stability   :  experimental
Portability :  portable

Template Haskell functions for getter functions.
-}
module Data.Aeson.Schema.TH.Getter where

import Control.Monad (unless)
import Data.Aeson.Schema.Internal (Object)
import Data.Maybe (isNothing)
import Language.Haskell.TH

import Data.Aeson.Schema.TH.Get (generateGetterExp)
import Data.Aeson.Schema.TH.Parse (GetterExp (..), parseGetterExp)
import Data.Aeson.Schema.TH.Unwrap (
  FunctorHandler (..),
  unwrapSchema,
  unwrapSchemaUsing,
 )
import Data.Aeson.Schema.TH.Utils (loadSchema, lookupSchema, schemaVToTypeQ)
import Data.Aeson.Schema.Utils.NameLike (NameLike (..))

-- | A helper that generates a 'Data.Aeson.Schema.TH.get' expression and a type alias for the result
--  of the expression.
--
--  > mkGetter "Node" "getNodes" ''MySchema ".nodes[]"
--  >
--  > {\- is equivalent to -\}
--  >
--  > -- | Node ~ { b: Maybe Bool }
--  > type Node = [unwrap| MySchema.nodes[] |]
--  >
--  > getNodes :: Object MySchema -> [Node]
--  > getNodes = [get| .nodes[] |]
--
--  'mkGetter' takes four arguments:
--
--    [@unwrapName@] The name of the type synonym to store the unwrapped schema as
--
--    [@funcName@] The name of the getter function
--
--    [@startSchema@] The schema to extract/unwrap from
--
--    [@ops@] The operation to pass to the 'Data.Aeson.Schema.TH.get' and
--            'Data.Aeson.Schema.TH.unwrap' quasiquoters
--
--  There is one subtlety that occurs from the use of the same @ops@ string for both the
--  'Data.Aeson.Schema.TH.unwrap' and 'Data.Aeson.Schema.TH.get' quasiquoters:
--  'Data.Aeson.Schema.TH.unwrap' strips out intermediate functors, while 'Data.Aeson.Schema.TH.get'
--  applies within the functor. So in the above example, @".nodes[]"@ strips out the list when
--  saving the schema to @Node@, while in the below example, @".nodes"@ doesn't strip out the list
--  when saving the schema to @Nodes@.
--
--  > mkGetter "Nodes" "getNodes" ''MySchema ".nodes"
--  >
--  > {\- is equivalent to -\}
--  >
--  > -- | Nodes ~ List { b: Maybe Bool }
--  > type Nodes = [unwrap| MySchema.nodes |]
--  >
--  > getNodes :: Object MySchema -> Nodes
--  > getNodes = [get| .nodes |]
--
--  As another example,
--
--  > mkGetter "MyName" "getMyName" ''MySchema ".f?[].name"
--  >
--  > {\- is equivalent to -\}
--  >
--  > -- | MyName ~ Text
--  > type MyName = [unwrap| MySchema.f?[].name |]
--  >
--  > getMyBool :: Object MySchema -> Maybe [MyName]
--  > getMyBool = [get| .f?[].name |]
mkGetter :: String -> String -> Name -> String -> DecsQ
mkGetter :: String -> String -> Name -> String -> DecsQ
mkGetter String
unwrapName String
funcName Name
startSchemaName String
ops = do
  getterExp :: GetterExp
getterExp@GetterExp{Maybe String
GetterOps
start :: Maybe String
getterOps :: GetterOps
$sel:start:GetterExp :: GetterExp -> Maybe String
$sel:getterOps:GetterExp :: GetterExp -> GetterOps
..} <- String -> Q GetterExp
forall (m :: * -> *). MonadFail m => String -> m GetterExp
parseGetterExp String
ops
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
start) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
    String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
      String
"Getter expression should start with '.': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ops

  SchemaV
startSchema <- NameLike -> Q ReifiedSchema
lookupSchema (Name -> NameLike
NameTH Name
startSchemaName) Q ReifiedSchema -> (ReifiedSchema -> Q SchemaV) -> Q SchemaV
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReifiedSchema -> Q SchemaV
loadSchema

  let unwrapResult :: TypeQ
unwrapResult = GetterOps -> SchemaV -> TypeQ
unwrapSchema GetterOps
getterOps SchemaV
startSchema
      funcResult :: TypeQ
funcResult = FunctorHandler -> GetterOps -> SchemaV -> TypeQ
unwrapSchemaUsing FunctorHandler
ApplyFunctors GetterOps
getterOps SchemaV
startSchema
      getterFunc :: ExpQ
getterFunc = GetterExp -> ExpQ
generateGetterExp GetterExp
getterExp
      unwrapName' :: Name
unwrapName' = String -> Name
mkName String
unwrapName
      funcName' :: Name
funcName' = String -> Name
mkName String
funcName

  [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ Name -> [TyVarBndr ()] -> TypeQ -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndr ()] -> m Type -> m Dec
tySynD Name
unwrapName' [] TypeQ
unwrapResult
    , Name -> TypeQ -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
funcName' [t|Object $(SchemaV -> TypeQ
schemaVToTypeQ SchemaV
startSchema) -> $TypeQ
funcResult|]
    , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
funcName' [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
getterFunc) []]
    ]