{-# 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
get =
QuasiQuoter
{ quoteExp :: [Char] -> Q Exp
quoteExp = [Char] -> Q GetterExp
forall (m :: * -> *). MonadFail m => [Char] -> m GetterExp
parseGetterExp ([Char] -> Q GetterExp) -> (GetterExp -> Q Exp) -> [Char] -> Q Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GetterExp -> Q Exp
generateGetterExp
, quoteDec :: [Char] -> Q [Dec]
quoteDec = [Char] -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use `get` for Dec"
, quoteType :: [Char] -> Q Type
quoteType = [Char] -> [Char] -> Q Type
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use `get` for Type"
, quotePat :: [Char] -> Q Pat
quotePat = [Char] -> [Char] -> Q Pat
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use `get` for Pat"
}
generateGetterExp :: GetterExp -> ExpQ
generateGetterExp :: GetterExp -> Q Exp
generateGetterExp GetterExp{Maybe [Char]
GetterOps
start :: Maybe [Char]
getterOps :: GetterOps
$sel:start:GetterExp :: GetterExp -> Maybe [Char]
$sel:getterOps:GetterExp :: GetterExp -> GetterOps
..} = Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp
applyStart (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ GetterOpExps -> Q Exp
resolveGetterOpExps (GetterOpExps -> Q Exp) -> GetterOpExps -> Q Exp
forall a b. (a -> b) -> a -> b
$ [GetterOperation] -> GetterOps -> GetterOpExps
mkGetterOpExps [] GetterOps
getterOps
where
applyStart :: m Exp -> m Exp
applyStart m Exp
expr = m Exp -> ([Char] -> m Exp) -> Maybe [Char] -> m Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Exp
expr (m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
expr (m Exp -> m Exp) -> ([Char] -> m Exp) -> [Char] -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> ([Char] -> Name) -> [Char] -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName) Maybe [Char]
start
startDisplay :: [Char]
startDisplay = case Maybe [Char]
start of
Maybe [Char]
Nothing -> [Char]
""
Just [Char]
s -> if Char
'.' Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
s then [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" else [Char]
s
mkGetterOpExps :: [GetterOperation] -> GetterOps -> GetterOpExps
mkGetterOpExps :: [GetterOperation] -> GetterOps -> GetterOpExps
mkGetterOpExps [GetterOperation]
historyPrefix = ([GetterOperation] -> GetterOperation -> GetterOpExp)
-> GetterOps -> GetterOpExps
forall a b. ([a] -> a -> b) -> NonEmpty a -> NonEmpty b
mapWithHistory ([GetterOperation] -> GetterOperation -> GetterOpExp
mkGetterOpExp ([GetterOperation] -> GetterOperation -> GetterOpExp)
-> ([GetterOperation] -> [GetterOperation])
-> [GetterOperation]
-> GetterOperation
-> GetterOpExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([GetterOperation]
historyPrefix [GetterOperation] -> [GetterOperation] -> [GetterOperation]
forall a. [a] -> [a] -> [a]
++))
mkGetterOpExp :: [GetterOperation] -> GetterOperation -> GetterOpExp
mkGetterOpExp :: [GetterOperation] -> GetterOperation -> GetterOpExp
mkGetterOpExp [GetterOperation]
history = \case
GetterKey [Char]
key ->
let keyType :: Q Type
keyType = Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
forall a b. (a -> b) -> a -> b
$ [Char] -> Q TyLit
forall (m :: * -> *). Quote m => [Char] -> m TyLit
strTyLit [Char]
key
in Q Exp -> GetterOpExp
ApplyOp [|getKey (Proxy :: Proxy $Q Type
keyType)|]
GetterOperation
GetterBang ->
let expr :: [Char]
expr = [Char]
startDisplay [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [GetterOperation] -> [Char]
forall (t :: * -> *). Foldable t => t GetterOperation -> [Char]
showGetterOps [GetterOperation]
history
in Q Exp -> GetterOpExp
ApplyOp [|fromJust expr|]
GetterOperation
GetterMapMaybe ->
Q Exp -> GetterOpExp
ApplyOpInfix [|(<$?>)|]
GetterOperation
GetterMapList ->
Q Exp -> GetterOpExp
ApplyOpInfix [|(<$:>)|]
GetterBranch Int
branch ->
let branchType :: Q Type
branchType = Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
forall a b. (a -> b) -> a -> b
$ Integer -> Q TyLit
forall (m :: * -> *). Quote m => Integer -> m TyLit
numTyLit (Integer -> Q TyLit) -> Integer -> Q TyLit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
branch
in Q Exp -> GetterOpExp
ApplyOp [|fromSumType (Proxy :: Proxy $Q Type
branchType)|]
GetterList NonEmpty GetterOps
elemOps ->
NonEmpty GetterOpExps -> GetterOpExp
ApplyOpsIntoList (NonEmpty GetterOpExps -> GetterOpExp)
-> NonEmpty GetterOpExps -> GetterOpExp
forall a b. (a -> b) -> a -> b
$ [GetterOperation] -> GetterOps -> GetterOpExps
mkGetterOpExps [GetterOperation]
history (GetterOps -> GetterOpExps)
-> NonEmpty GetterOps -> NonEmpty GetterOpExps
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty GetterOps
elemOps
GetterTuple NonEmpty GetterOps
elemOps ->
NonEmpty GetterOpExps -> GetterOpExp
ApplyOpsIntoTuple (NonEmpty GetterOpExps -> GetterOpExp)
-> NonEmpty GetterOpExps -> GetterOpExp
forall a b. (a -> b) -> a -> b
$ [GetterOperation] -> GetterOps -> GetterOpExps
mkGetterOpExps [GetterOperation]
history (GetterOps -> GetterOpExps)
-> NonEmpty GetterOps -> NonEmpty GetterOpExps
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty GetterOps
elemOps
fromJust :: (HasCallStack) => String -> Maybe a -> a
fromJust :: forall a. HasCallStack => [Char] -> Maybe a -> a
fromJust [Char]
expr = a -> Maybe a -> a
forall a. a -> Maybe a -> a
Maybe.fromMaybe ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
errMsg)
where
errMsg :: [Char]
errMsg = [Char]
"Called 'fromJust' on null expression" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
expr then [Char]
"" else [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
expr
(<$?>) :: (a -> b) -> Maybe a -> Maybe b
<$?> :: forall a b. (a -> b) -> Maybe a -> Maybe b
(<$?>) = (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>)
(<$:>) :: (a -> b) -> [a] -> [b]
<$:> :: forall a b. (a -> b) -> [a] -> [b]
(<$:>) = (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>)
data GetterOpExp
=
ApplyOp ExpQ
|
ApplyOpInfix ExpQ
|
ApplyOpsIntoList (NonEmpty GetterOpExps)
|
ApplyOpsIntoTuple (NonEmpty GetterOpExps)
type GetterOpExps = NonEmpty GetterOpExp
resolveGetterOpExps :: GetterOpExps -> ExpQ
resolveGetterOpExps :: GetterOpExps -> Q Exp
resolveGetterOpExps (GetterOpExp
op NonEmpty.:| [GetterOpExp]
ops) =
case GetterOpExp
op of
ApplyOp Q Exp
f -> [|$Q Exp
next . $Q Exp
f|]
ApplyOpInfix Q Exp
f -> Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
next) Q Exp
f Maybe (Q Exp)
forall a. Maybe a
Nothing
ApplyOpsIntoList NonEmpty GetterOpExps
elemOps -> ([Q Exp] -> Q Exp) -> NonEmpty GetterOpExps -> Q Exp
forall {m :: * -> *}.
Quote m =>
([Q Exp] -> m Exp) -> NonEmpty GetterOpExps -> m Exp
resolveEach [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE NonEmpty GetterOpExps
elemOps
ApplyOpsIntoTuple NonEmpty GetterOpExps
elemOps -> ([Q Exp] -> Q Exp) -> NonEmpty GetterOpExps -> Q Exp
forall {m :: * -> *}.
Quote m =>
([Q Exp] -> m Exp) -> NonEmpty GetterOpExps -> m Exp
resolveEach [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE NonEmpty GetterOpExps
elemOps
where
next :: Q Exp
next = Q Exp -> (GetterOpExps -> Q Exp) -> Maybe GetterOpExps -> Q Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [|id|] GetterOpExps -> Q Exp
resolveGetterOpExps (Maybe GetterOpExps -> Q Exp) -> Maybe GetterOpExps -> Q Exp
forall a b. (a -> b) -> a -> b
$ [GetterOpExp] -> Maybe GetterOpExps
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [GetterOpExp]
ops
resolveEach :: ([Q Exp] -> m Exp) -> NonEmpty GetterOpExps -> m Exp
resolveEach [Q Exp] -> m Exp
fromElems NonEmpty GetterOpExps
elemOps = do
Name
val <- [Char] -> m Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"v"
let applyVal :: m Exp -> m Exp
applyVal m Exp
expr = m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
expr (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
val)
[m Pat] -> m Exp -> m Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
val] (m Exp -> m Exp) -> m Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> m Exp
fromElems ([Q Exp] -> m Exp) -> [Q Exp] -> m Exp
forall a b. (a -> b) -> a -> b
$ (GetterOpExps -> Q Exp) -> [GetterOpExps] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp
applyVal (Q Exp -> Q Exp)
-> (GetterOpExps -> Q Exp) -> GetterOpExps -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetterOpExps -> Q Exp
resolveGetterOpExps) ([GetterOpExps] -> [Q Exp]) -> [GetterOpExps] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$ NonEmpty GetterOpExps -> [GetterOpExps]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty GetterOpExps
elemOps
showGetterOps :: (Foldable t) => t GetterOperation -> String
showGetterOps :: forall (t :: * -> *). Foldable t => t GetterOperation -> [Char]
showGetterOps = (GetterOperation -> [Char]) -> t GetterOperation -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GetterOperation -> [Char]
showGetterOp
where
showGetterOp :: GetterOperation -> [Char]
showGetterOp = \case
GetterKey [Char]
key -> Char
'.' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
key
GetterOperation
GetterBang -> [Char]
"!"
GetterOperation
GetterMapList -> [Char]
"[]"
GetterOperation
GetterMapMaybe -> [Char]
"?"
GetterBranch Int
x -> Char
'@' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x
GetterList NonEmpty GetterOps
elemOps -> [Char]
".[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty GetterOps -> [Char]
showGetterOpsList NonEmpty GetterOps
elemOps [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
GetterTuple NonEmpty GetterOps
elemOps -> [Char]
".(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NonEmpty GetterOps -> [Char]
showGetterOpsList NonEmpty GetterOps
elemOps [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
showGetterOpsList :: NonEmpty GetterOps -> [Char]
showGetterOpsList = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ([[Char]] -> [Char])
-> (NonEmpty GetterOps -> [[Char]]) -> NonEmpty GetterOps -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty [Char] -> [[Char]])
-> (NonEmpty GetterOps -> NonEmpty [Char])
-> NonEmpty GetterOps
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GetterOps -> [Char]) -> NonEmpty GetterOps -> NonEmpty [Char]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GetterOps -> [Char]
forall (t :: * -> *). Foldable t => t GetterOperation -> [Char]
showGetterOps
mapWithHistory :: ([a] -> a -> b) -> NonEmpty a -> NonEmpty b
mapWithHistory :: forall a b. ([a] -> a -> b) -> NonEmpty a -> NonEmpty b
mapWithHistory [a] -> a -> b
f NonEmpty a
xs = ([a] -> a -> b) -> NonEmpty [a] -> NonEmpty a -> NonEmpty b
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NonEmpty.zipWith [a] -> a -> b
f (NonEmpty a -> NonEmpty [a]
forall (f :: * -> *) a. Foldable f => f a -> NonEmpty [a]
NonEmpty.inits NonEmpty a
xs) NonEmpty a
xs