-- | conversion of 'Language.Haskell.Exts.Simple.Syntax.Type' to
-- 'Language.Haskell.Syntax.Type'
module Data.Serde.Internal.Type (ToTH (..), cvtnam, cvtder) where

import Data.List (foldl')
import Data.Serde.Internal.ISyn (Derive (..))
import Language.Haskell.Exts.Simple.Pretty as Exts
import Language.Haskell.Exts.Simple.Syntax as Exts
import Language.Haskell.TH as TH

-- | convert a 'Type' to a 'TH.Type'
class ToTH a where
  -- | convert a 'Type' to a 'TH.Type'
  toth :: a -> TH.Type

instance ToTH Exts.Type where
  toth :: Type -> Type
toth = \case
    -- basic mappings
    TyVar Name
n -> Name -> Type
VarT (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Pretty a => a -> String
prettyPrint Name
n)
    TyCon QName
n -> Name -> Type
ConT (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ QName -> String
forall a. Pretty a => a -> String
prettyPrint QName
n)
    TyApp Type
f Type
x -> Type -> Type -> Type
AppT (Type -> Type
forall a. ToTH a => a -> Type
toth Type
f) (Type -> Type
forall a. ToTH a => a -> Type
toth Type
x)
    TyList Type
t -> Type -> Type -> Type
AppT Type
ListT (Type -> Type
forall a. ToTH a => a -> Type
toth Type
t)
    TyParen Type
t -> Type -> Type
ParensT (Type -> Type
forall a. ToTH a => a -> Type
toth Type
t)
    -- tuples need special handling
    TyTuple Boxed
_ [Type]
ts ->
      let n :: Int
n = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
          apps :: [Type]
apps = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
forall a. ToTH a => a -> Type
toth [Type]
ts
       in (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT Int
n) [Type]
apps
    -- functions
    TyFun Type
a Type
b -> Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT (Type -> Type
forall a. ToTH a => a -> Type
toth Type
a)) (Type -> Type
forall a. ToTH a => a -> Type
toth Type
b)
    -- complex cases
    TyForall Maybe [TyVarBind]
tvs Maybe Context
ctx Type
t ->
      let tvs' :: [TyVarBndr Specificity]
tvs' = [TyVarBndr Specificity]
-> ([TyVarBind] -> [TyVarBndr Specificity])
-> Maybe [TyVarBind]
-> [TyVarBndr Specificity]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((TyVarBind -> TyVarBndr Specificity)
-> [TyVarBind] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind -> TyVarBndr Specificity
tothtyvarbndr) Maybe [TyVarBind]
tvs
          ctx_ :: [Asst]
ctx_ = case Maybe Context
ctx of
            Just (CxSingle Asst
a) -> [Asst
a]
            Just (CxTuple [Asst]
as) -> [Asst]
as
            Just Context
CxEmpty -> []
            Maybe Context
_ -> []
          ctx' :: [Type]
ctx' = (Asst -> Type) -> [Asst] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Asst -> Type
tothpred [Asst]
ctx_
       in [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
tvs' [Type]
ctx' (Type -> Type
forall a. ToTH a => a -> Type
toth Type
t)
    TyPromoted Promoted
prom -> case Promoted
prom of
      PromotedInteger Integer
n String
_ ->
        TyLit -> Type
LitT (Integer -> TyLit
NumTyLit Integer
n)
      PromotedString String
s String
_ ->
        TyLit -> Type
LitT (String -> TyLit
StrTyLit String
s)
      PromotedCon Bool
_ QName
n ->
        Name -> Type
PromotedT (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ QName -> String
forall a. Pretty a => a -> String
prettyPrint QName
n)
      PromotedList Bool
_ [Type]
ts ->
        (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
          ((\Type
x Type
acc -> Type
PromotedConsT Type -> Type -> Type
`AppT` Type
x Type -> Type -> Type
`AppT` Type
acc) (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
forall a. ToTH a => a -> Type
toth)
          Type
PromotedNilT
          [Type]
ts
      PromotedTuple [Type]
ts ->
        (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
PromotedTupleT ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts)) ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
forall a. ToTH a => a -> Type
toth [Type]
ts)
      Promoted
PromotedUnit ->
        Int -> Type
PromotedTupleT Int
0
    -- other cases need implementation
    Type
TyStar -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TyStar"
    TyUnboxedSum {} -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TyUnboxedSum"
    TyParArray {} -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TyParArray"
    TyInfix {} -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TyInfix"
    TyKind {} -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TyKind"
    TyEquals {} -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TyEquals"
    TySplice {} -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TySplice"
    TyBang {} -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TyBang"
    TyWildCard {} -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TyWildCard"
    TyQuasiQuote {} -> String -> Type
forall a. HasCallStack => String -> a
error String
"toth: unsupported TyQuasiQuote"

tothtyvarbndr :: TyVarBind -> TyVarBndr Specificity
tothtyvarbndr :: TyVarBind -> TyVarBndr Specificity
tothtyvarbndr = \case
  KindedVar Name
n Type
k ->
    let k' :: Type
k' = Type -> Type
forall a. ToTH a => a -> Type
toth Type
k
     in Name -> Specificity -> Type -> TyVarBndr Specificity
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Pretty a => a -> String
prettyPrint Name
n) Specificity
SpecifiedSpec Type
k'
  UnkindedVar Name
n ->
    Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Pretty a => a -> String
prettyPrint Name
n) Specificity
SpecifiedSpec

tothpred :: Asst -> TH.Type
tothpred :: Asst -> Type
tothpred = \case
  TypeA Type
n -> Type -> Type
forall a. ToTH a => a -> Type
toth Type
n
  IParam IPName
n Type
t ->
    let t' :: Type
t' = Type -> Type
forall a. ToTH a => a -> Type
toth Type
t
     in String -> Type -> Type
ImplicitParamT (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ IPName -> String
forall a. Pretty a => a -> String
prettyPrint IPName
n) Type
t' -- drop '?'
  ParenA Asst
a -> Asst -> Type
tothpred Asst
a

-- | convert a Exts.'Exts.Name' to a TH.'TH.Name'
--
-- qualification gets handled syntactically
cvtnam :: Exts.Name -> TH.Name
cvtnam :: Name -> Name
cvtnam = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Pretty a => a -> String
prettyPrint

-- | convert a 'Derive' to a list of TH.'TH.Type's
cvtder :: Derive -> [TH.Type]
cvtder :: Derive -> [Type]
cvtder = (String -> Type) -> [String] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
ConT (Name -> Type) -> (String -> Name) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) ([String] -> [Type]) -> (Derive -> [String]) -> Derive -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Derive -> [String]
getderive

-- | used for testing
--
-- >>> :t $(_dbgasexp (pure $ toth mytype))
_dbgasexp :: TH.Type -> Q TH.Exp
_dbgasexp :: Type -> Q Exp
_dbgasexp Type
t = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
SigE (Name -> Exp
VarE 'undefined) Type
t