{-# 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 (..), nameBase,)
import Language.Haskell.TH.Compat.Data (unDataD, unNewtypeD, unTyVarBndr)
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' =  forall {m :: * -> *} {m :: * -> *} {m :: * -> *}.
(Quote m, Quote m, Monad m) =>
Info -> Maybe (((m Type, [Name]), m Exp), (Maybe [Name], [m Type]))
d  where
  d :: Info -> Maybe (((m Type, [Name]), m Exp), (Maybe [Name], [m Type]))
d (TyConI Dec
tcon) = do
    (Name
tcn, [TyVarBndr ()]
bs, Con
r)  <-
      do (Cxt
_cxt, Name
tcn, [TyVarBndr ()]
bs, Maybe Type
_mk, [Con
r], Cxt
_ds)  <-  Dec -> Maybe (Cxt, Name, [TyVarBndr ()], Maybe Type, [Con], Cxt)
unDataD Dec
tcon
         forall a. a -> Maybe a
Just (Name
tcn, [TyVarBndr ()]
bs, Con
r)
      forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      do (Cxt
_cxt, Name
tcn, [TyVarBndr ()]
bs, Maybe Type
_mk,  Con
r , Cxt
_ds)  <-  Dec -> Maybe (Cxt, Name, [TyVarBndr ()], Maybe Type, Con, Cxt)
unNewtypeD Dec
tcon
         forall a. a -> Maybe a
Just (Name
tcn, [TyVarBndr ()]
bs, Con
r)
    let vns :: [Name]
vns = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. TyVarBndr a -> Name
tyVarName [TyVarBndr ()]
bs
    case Con
r of
      NormalC Name
dcn [BangType]
ts   -> forall a. a -> Maybe a
Just (((forall {m :: * -> *}. Quote m => Name -> [Name] -> m Type
buildT Name
tcn [Name]
vns, [Name]
vns), forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
dcn), (forall a. Maybe a
Nothing, [forall (m :: * -> *) a. Monad m => a -> m a
return Type
t | (Bang
_, Type
t) <- [BangType]
ts]))
      RecC    Name
dcn [VarBangType]
vts  -> forall a. a -> Maybe a
Just (((forall {m :: * -> *}. Quote m => Name -> [Name] -> m Type
buildT Name
tcn [Name]
vns, [Name]
vns), forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
dcn), (forall a. a -> Maybe a
Just [Name]
ns, [m Type]
ts))
        where ([Name]
ns, [m Type]
ts) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Name
n, forall (m :: * -> *) a. Monad m => a -> m a
return Type
t) | (Name
n, Bang
_, Type
t) <- [VarBangType]
vts]
      Con
_                -> forall a. Maybe a
Nothing
  d Info
_                  =  forall a. Maybe a
Nothing
  tyVarName :: TyVarBndr a -> Name
tyVarName = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TyVarBndr a -> (Name, Maybe a)
unTyVarBndr
  buildT :: Name -> [Name] -> m Type
buildT Name
tcn [Name]
vns = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tcn) [ forall (m :: * -> *). Quote m => Name -> m Type
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 Name
recTypeName =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe
  (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msgOnErr)
  forall (m :: * -> *) a. Monad m => a -> m a
return
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
recordInfo' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q Info
reify Name
recTypeName
  where
    recTypeNameS :: String
recTypeNameS = forall a. Show a => a -> String
show Name
recTypeName
    recTypeNameB :: String
recTypeNameB = Name -> String
nameBase Name
recTypeName
    msgOnErr :: String
msgOnErr =
      String
"Valid record type constructor not found: " forall a. [a] -> [a] -> [a]
++ String
recTypeNameS forall a. [a] -> [a] -> [a]
++ String
".\n"
      forall a. [a] -> [a] -> [a]
++ String
"    Possible causes:\n"
      forall a. [a] -> [a] -> [a]
++ String
"      - " forall a. [a] -> [a] -> [a]
++ String
recTypeNameB forall a. [a] -> [a] -> [a]
++ String
" is not a type name.\n"
      forall a. [a] -> [a] -> [a]
++ String
"        (Type name must be prefixed with double-single-quotes: e.g. ''" forall a. [a] -> [a] -> [a]
++ String
recTypeNameB forall a. [a] -> [a] -> [a]
++ String
")\n"
      forall a. [a] -> [a] -> [a]
++ String
"      - " forall a. [a] -> [a] -> [a]
++ String
recTypeNameB forall a. [a] -> [a] -> [a]
++ String
" has multiple data constructors.\n"
      forall a. [a] -> [a] -> [a]
++ String
"        (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 Name
tyN = do
  (((TypeQ
tyQ, [Name]
_), ExpQ
dtQ), (Maybe [Name]
_, [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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Name
tupleTypeName