{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}

{-
  TemplateHaskell utility functions to create encoders and decoders
-}

module Data.Registry.Aeson.TH.TH where

import Control.Monad.Fail
import Data.List (elemIndex)
import qualified Data.Text as T
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude hiding (Type)

indexConstructorTypes :: [Type] -> [Type] -> Q [(Type, Int)]
indexConstructorTypes :: [Type] -> [Type] -> Q [(Type, Int)]
indexConstructorTypes [Type]
allTypes [Type]
constructorTypes =
  [Type] -> (Type -> Q (Type, Int)) -> Q [(Type, Int)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Type]
constructorTypes ((Type -> Q (Type, Int)) -> Q [(Type, Int)])
-> (Type -> Q (Type, Int)) -> Q [(Type, Int)]
forall a b. (a -> b) -> a -> b
$ \Type
t ->
    case Type -> [Type] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Type
t [Type]
allTypes of
      Just Int
n -> (Type, Int) -> Q (Type, Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
t, Int
n)
      Maybe Int
Nothing -> String -> Q (Type, Int)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Int)) -> String -> Q (Type, Int)
forall a b. (a -> b) -> a -> b
$ String
"the type " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a b. (Show a, StringConv String b) => a -> b
show Type
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" cannot be found in the list of all types " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Type] -> String
forall a b. (Show a, StringConv String b) => a -> b
show [Type]
allTypes

-- | Get the types of all the fields of a constructor
typesOf :: Con -> Q [Type]
typesOf :: Con -> Q [Type]
typesOf (NormalC Name
_ [BangType]
types) = [Type] -> Q [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BangType -> Type
forall a b. (a, b) -> b
snd (BangType -> Type) -> [BangType] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BangType]
types)
typesOf (RecC Name
_ [VarBangType]
types) = [Type] -> Q [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (\(Name
_, Bang
_, Type
t) -> Type
t) (VarBangType -> Type) -> [VarBangType] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
types
typesOf Con
other = do
  Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create encoders / decoders for normal constructors and records, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
  String -> Q [Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"encoders / decoders creation failed"

-- | Get the name of a constructor
nameOf :: Con -> Q Name
nameOf :: Con -> Q Name
nameOf (NormalC Name
n [BangType]
_) = Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
nameOf (RecC Name
n [VarBangType]
_) = Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
nameOf Con
other = do
  Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create encoders / decoders for normal constructors and records, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
  String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"encoders / decoders creation failed"

-- | Get the list of names of a constructor
fieldsOf :: Con -> Q [Name]
fieldsOf :: Con -> Q [Name]
fieldsOf (NormalC Name
_ [BangType]
_) = [Name] -> Q [Name]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
fieldsOf (RecC Name
_ [VarBangType]
types) = [Name] -> Q [Name]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ (\(Name
f, Bang
_, Type
_) -> Name
f) (VarBangType -> Name) -> [VarBangType] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
types
fieldsOf Con
other = do
  Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create encoders / decoders for normal constructors and records, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
  String -> Q [Name]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"encoders / decoders creation failed"

-- | Remove the module name from a qualified name
dropQualified :: Name -> Name
dropQualified :: Name -> Name
dropQualified Name
name = Name -> (Text -> Name) -> Maybe Text -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
name (String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertText a b => a -> b
toS) ([Text] -> Maybe Text
forall a. [a] -> Maybe a
lastMay (Text -> Text -> [Text]
T.splitOn Text
"." (Name -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Name
name)))

-- | Return the name of a given type
getSimpleTypeName :: Type -> Name
getSimpleTypeName :: Type -> Name
getSimpleTypeName (ForallT [TyVarBndr]
_ [Type]
_ Type
ty) = Type -> Name
getSimpleTypeName Type
ty
getSimpleTypeName (VarT Name
name) = Name -> Name
dropQualified Name
name
getSimpleTypeName (ConT Name
name) = Name -> Name
dropQualified Name
name
getSimpleTypeName (TupleT Int
n) = Name -> Name
dropQualified (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleTypeName Int
n
getSimpleTypeName Type
ArrowT = Name -> Name
dropQualified ''(->)
getSimpleTypeName Type
ListT = Name -> Name
dropQualified ''[]
getSimpleTypeName (AppT Type
t1 Type
t2) = String -> Name
mkName (Name -> String
forall a b. (Show a, StringConv String b) => a -> b
show (Type -> Name
getSimpleTypeName Type
t1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a b. (Show a, StringConv String b) => a -> b
show (Type -> Name
getSimpleTypeName Type
t2))
getSimpleTypeName (SigT Type
t Type
_) = Type -> Name
getSimpleTypeName Type
t
getSimpleTypeName (UnboxedTupleT Int
n) = Name -> Name
dropQualified (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Int -> Name
unboxedTupleTypeName Int
n
getSimpleTypeName Type
t = Text -> Name
forall a. HasCallStack => Text -> a
panic (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Text
"getSimpleTypeName: Unknown type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Type
t