{-# 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 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)
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 [| (<$:>) |]
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]
(<$:>) = (<$>)