{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}

-- |
-- Module      : Data.Functor.ProductIsomorphic.TH.Internal
-- Copyright   : 2017-2018 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines templates to make product constructors.
module Data.Functor.ProductIsomorphic.TH.Internal (
  defineProductConstructor, defineTupleProductConstructor,

  reifyRecordType,
  ) where

import Control.Applicative ((<|>))
import Language.Haskell.TH
  (Q, Name, tupleTypeName, Info (..), reify,
   TypeQ, arrowT, appT, conT, varT,
   Dec, ExpQ, conE, Con (..), TyVarBndr (..), nameBase,)
import Language.Haskell.TH.Compat.Data (unDataD, unNewtypeD)
import Data.List (foldl')

import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..))


recordInfo' :: Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
recordInfo' :: Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
recordInfo' =  Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall (m :: * -> *).
Monad m =>
Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
d  where
  d :: Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
d (TyConI tcon :: Dec
tcon) = do
    (tcn :: Name
tcn, bs :: [TyVarBndr]
bs, r :: Con
r)  <-
      do (_cxt :: Cxt
_cxt, tcn :: Name
tcn, bs :: [TyVarBndr]
bs, _mk :: Maybe Type
_mk, [r :: Con
r], _ds :: Cxt
_ds)  <-  Dec -> Maybe (Cxt, Name, [TyVarBndr], Maybe Type, [Con], Cxt)
unDataD Dec
tcon
         (Name, [TyVarBndr], Con) -> Maybe (Name, [TyVarBndr], Con)
forall a. a -> Maybe a
Just (Name
tcn, [TyVarBndr]
bs, Con
r)
      Maybe (Name, [TyVarBndr], Con)
-> Maybe (Name, [TyVarBndr], Con) -> Maybe (Name, [TyVarBndr], Con)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      do (_cxt :: Cxt
_cxt, tcn :: Name
tcn, bs :: [TyVarBndr]
bs, _mk :: Maybe Type
_mk,  r :: Con
r , _ds :: Cxt
_ds)  <-  Dec -> Maybe (Cxt, Name, [TyVarBndr], Maybe Type, Con, Cxt)
unNewtypeD Dec
tcon
         (Name, [TyVarBndr], Con) -> Maybe (Name, [TyVarBndr], Con)
forall a. a -> Maybe a
Just (Name
tcn, [TyVarBndr]
bs, Con
r)
    let vns :: [Name]
vns = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
getTV [TyVarBndr]
bs
    case Con
r of
      NormalC dcn :: Name
dcn ts :: [BangType]
ts   -> (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
-> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
forall a. a -> Maybe a
Just (((Name -> [Name] -> TypeQ
buildT Name
tcn [Name]
vns, [Name]
vns), Name -> ExpQ
conE Name
dcn), (Maybe [Name]
forall a. Maybe a
Nothing, [Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t | (_, t :: Type
t) <- [BangType]
ts]))
      RecC    dcn :: Name
dcn vts :: [VarBangType]
vts  -> (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
-> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
forall a. a -> Maybe a
Just (((Name -> [Name] -> TypeQ
buildT Name
tcn [Name]
vns, [Name]
vns), Name -> ExpQ
conE Name
dcn), ([Name] -> Maybe [Name]
forall a. a -> Maybe a
Just [Name]
ns, [m Type]
ts))
        where (ns :: [Name]
ns, ts :: [m Type]
ts) = [(Name, m Type)] -> ([Name], [m Type])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name
n, Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t) | (n :: Name
n, _, t :: Type
t) <- [VarBangType]
vts]
      _                -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
forall a. Maybe a
Nothing
  d _                  =  Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [m Type]))
forall a. Maybe a
Nothing
  getTV :: TyVarBndr -> Name
getTV (PlainTV n :: Name
n)    =  Name
n
  getTV (KindedTV n :: Name
n _) =  Name
n
  buildT :: Name -> [Name] -> TypeQ
buildT tcn :: Name
tcn vns :: [Name]
vns = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
tcn) [ Name -> TypeQ
varT Name
vn | Name
vn <- [Name]
vns ]

-- | Low-level reify interface for record type name.
reifyRecordType :: Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType :: Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType recTypeName :: Name
recTypeName =
  Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
-> ((((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
    -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
-> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
  (String -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msgOnErr)
  (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
-> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall (m :: * -> *) a. Monad m => a -> m a
return
  (Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
 -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> (Info
    -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> Info
-> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
recordInfo' (Info -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])))
-> Q Info -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q Info
reify Name
recTypeName
  where
    recTypeNameS :: String
recTypeNameS = Name -> String
forall a. Show a => a -> String
show Name
recTypeName
    recTypeNameB :: String
recTypeNameB = Name -> String
nameBase Name
recTypeName
    msgOnErr :: String
msgOnErr =
      "Valid record type constructor not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
recTypeNameS String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ "    Possible causes:\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ "      - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
recTypeNameB String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is not a type name.\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ "        (Type name must be prefixed with double-single-quotes: e.g. ''" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
recTypeNameB String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ "      - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
recTypeNameB String -> String -> String
forall a. [a] -> [a] -> [a]
++ " has multiple data constructors.\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ "        (Currently, only types with exactly *one* data constructors are supported)\n"

-- | Make template of ProductConstructor instance from type constructor name.
defineProductConstructor :: Name     -- ^ name of product or record type constructor
                         -> Q [Dec]  -- ^ result template
defineProductConstructor :: Name -> Q [Dec]
defineProductConstructor tyN :: Name
tyN = do
  (((tyQ :: TypeQ
tyQ, _), dtQ :: ExpQ
dtQ), (_, colts :: [TypeQ]
colts))  <- Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType Name
tyN
  [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) tyQ colts) where
        productConstructor = $(dtQ)
    |]

-- | Make template of ProductConstructor instance of tuple type.
defineTupleProductConstructor :: Int     -- ^ n-tuple
                              -> Q [Dec] -- ^ result template
defineTupleProductConstructor :: Int -> Q [Dec]
defineTupleProductConstructor =
  Name -> Q [Dec]
defineProductConstructor (Name -> Q [Dec]) -> (Int -> Name) -> Int -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
tupleTypeName