{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Aeson.Schema.TH.Get where
import Control.Monad (unless, (>=>))
import qualified Data.Maybe as Maybe
import Data.Proxy (Proxy(..))
import GHC.Stack (HasCallStack)
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (lift)
import Data.Aeson.Schema.Internal (getKey)
import Data.Aeson.Schema.TH.Parse (GetterExp(..), getterExp, parse)
import Data.Aeson.Schema.TH.Utils (GetterOperation(..), showGetterOps)
import Data.Aeson.Schema.Utils.Sum (fromSumType)
get :: QuasiQuoter
get = QuasiQuoter
{ quoteExp = parse getterExp >=> generateGetterExp
, quoteDec = error "Cannot use `get` for Dec"
, quoteType = error "Cannot use `get` for Type"
, quotePat = error "Cannot use `get` for Pat"
}
generateGetterExp :: GetterExp -> ExpQ
generateGetterExp GetterExp{..} = maybe expr (appE expr . varE . mkName) start
where
startDisplay = case start of
Nothing -> ""
Just s -> if '.' `elem` s then "(" ++ s ++ ")" else s
expr = mkGetterExp [] getterOps
applyToNext next = \case
Right f -> [| $next . $f |]
Left f -> infixE (Just next) f Nothing
applyToEach history fromElems elems = do
val <- newName "v"
let mkElem ops = appE (mkGetterExp history ops) (varE val)
lamE [varP val] $ fromElems $ map mkElem elems
mkGetterExp history = \case
[] -> [| id |]
op:ops ->
let applyToNext' = applyToNext $ mkGetterExp (op:history) ops
applyToEach' = applyToEach history
checkLast label = unless (null ops) $ fail $ label ++ " operation MUST be last."
fromJustMsg = startDisplay ++ showGetterOps (reverse history)
in case op of
GetterKey key -> applyToNext' $ Right $ appTypeE [| getKey |] (litT $ strTyLit key)
GetterList elems -> checkLast ".[*]" >> applyToEach' listE elems
GetterTuple elems -> checkLast ".(*)" >> applyToEach' tupE elems
GetterBang -> applyToNext' $ Right [| fromJust $(lift fromJustMsg) |]
GetterMapMaybe -> applyToNext' $ Left [| (<$?>) |]
GetterMapList -> applyToNext' $ Left [| (<$:>) |]
GetterBranch branch ->
let branchTyLit = litT $ numTyLit $ fromIntegral branch
in applyToNext' $ Right [| fromSumType (Proxy :: Proxy $branchTyLit) |]
fromJust :: HasCallStack => String -> Maybe a -> a
fromJust msg = Maybe.fromMaybe (error errMsg)
where
errMsg = "Called 'fromJust' on null expression" ++ if null msg then "" else ": " ++ msg
(<$?>) :: (a -> b) -> Maybe a -> Maybe b
(<$?>) = (<$>)
(<$:>) :: (a -> b) -> [a] -> [b]
(<$:>) = (<$>)