    {-# 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