{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Aeson.Schema.TH.Get where
import Control.Monad ((>=>))
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
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 Data.Aeson.Schema.Internal (getKey)
import Data.Aeson.Schema.TH.Parse
(GetterExp(..), GetterOperation(..), GetterOps, parseGetterExp)
import Data.Aeson.Schema.Utils.Sum (fromSumType)
get :: QuasiQuoter
get = QuasiQuoter
{ quoteExp = parseGetterExp >=> 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{..} = applyStart $ resolveGetterOpExps $ mkGetterOpExps [] getterOps
where
applyStart expr = maybe expr (appE expr . varE . mkName) start
startDisplay = case start of
Nothing -> ""
Just s -> if '.' `elem` s then "(" ++ s ++ ")" else s
mkGetterOpExps :: [GetterOperation] -> GetterOps -> GetterOpExps
mkGetterOpExps historyPrefix = mapWithHistory (mkGetterOpExp . (historyPrefix ++))
mkGetterOpExp :: [GetterOperation] -> GetterOperation -> GetterOpExp
mkGetterOpExp history = \case
GetterKey key ->
let keyType = litT $ strTyLit key
in ApplyOp [| getKey (Proxy :: Proxy $keyType) |]
GetterBang ->
let expr = startDisplay ++ showGetterOps history
in ApplyOp [| fromJust expr |]
GetterMapMaybe ->
ApplyOpInfix [| (<$?>) |]
GetterMapList ->
ApplyOpInfix [| (<$:>) |]
GetterBranch branch ->
let branchType = litT $ numTyLit $ fromIntegral branch
in ApplyOp [| fromSumType (Proxy :: Proxy $branchType) |]
GetterList elemOps ->
ApplyOpsIntoList $ mkGetterOpExps history <$> elemOps
GetterTuple elemOps ->
ApplyOpsIntoTuple $ mkGetterOpExps history <$> elemOps
fromJust :: HasCallStack => String -> Maybe a -> a
fromJust expr = Maybe.fromMaybe (error errMsg)
where
errMsg = "Called 'fromJust' on null expression" ++ if null expr then "" else ": " ++ expr
(<$?>) :: (a -> b) -> Maybe a -> Maybe b
(<$?>) = (<$>)
(<$:>) :: (a -> b) -> [a] -> [b]
(<$:>) = (<$>)
data GetterOpExp
= ApplyOp ExpQ
| ApplyOpInfix ExpQ
| ApplyOpsIntoList (NonEmpty GetterOpExps)
| ApplyOpsIntoTuple (NonEmpty GetterOpExps)
type GetterOpExps = NonEmpty GetterOpExp
resolveGetterOpExps :: GetterOpExps -> ExpQ
resolveGetterOpExps (op NonEmpty.:| ops) =
case op of
ApplyOp f -> [| $next . $f |]
ApplyOpInfix f -> infixE (Just next) f Nothing
ApplyOpsIntoList elemOps -> resolveEach listE elemOps
ApplyOpsIntoTuple elemOps -> resolveEach tupE elemOps
where
next = maybe [| id |] resolveGetterOpExps $ NonEmpty.nonEmpty ops
resolveEach fromElems elemOps = do
val <- newName "v"
let applyVal expr = appE expr (varE val)
lamE [varP val] $ fromElems $ map (applyVal . resolveGetterOpExps) $ NonEmpty.toList elemOps
showGetterOps :: Foldable t => t GetterOperation -> String
showGetterOps = concatMap showGetterOp
where
showGetterOp = \case
GetterKey key -> '.':key
GetterBang -> "!"
GetterMapList -> "[]"
GetterMapMaybe -> "?"
GetterBranch x -> '@' : show x
GetterList elemOps -> ".[" ++ showGetterOpsList elemOps ++ "]"
GetterTuple elemOps -> ".(" ++ showGetterOpsList elemOps ++ ")"
showGetterOpsList = intercalate "," . NonEmpty.toList . fmap showGetterOps
mapWithHistory :: ([a] -> a -> b) -> NonEmpty a -> NonEmpty b
mapWithHistory f xs = NonEmpty.zipWith f (NonEmpty.inits xs) xs