{-|
Module      :  Data.Aeson.Schema.TH.Getter
Maintainer  :  Brandon Chinn <brandon@leapyear.io>
Stability   :  experimental
Portability :  portable

Template Haskell functions for getter functions.
-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

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
$sel:getterOps:GetterExp :: GetterExp -> GetterOps
$sel:start:GetterExp :: GetterExp -> Maybe String
getterOps :: GetterOps
start :: Maybe String
..} <- 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 (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 (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)
sequence
    [ Name -> [TyVarBndr] -> TypeQ -> Q Dec
tySynD Name
unwrapName' [] TypeQ
unwrapResult
    , Name -> TypeQ -> Q Dec
sigD Name
funcName' [t| Object $(schemaVToTypeQ startSchema) -> $funcResult |]
    , Name -> [ClauseQ] -> Q Dec
funD Name
funcName' [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
getterFunc) []]
    ]