{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TupleSections       #-}

module Data.Record.Internal.Record.Resolution.GHC (
    parseRecordInfo
  ) where

import Control.Monad.Except
import Data.Maybe (fromMaybe)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

import qualified Control.Monad.Except as Except

import Data.Record.Generic
import Data.Record.Internal.Record
import Data.Record.Internal.TH.Util

import qualified Data.Record.Internal.TH.Name as N

{-------------------------------------------------------------------------------
  Parsing
-------------------------------------------------------------------------------}

-- | Parse previously constructed type level data
--
-- We do this when we construct record /values/, at which point we have no
-- 'Options', so this must work without options.
--
-- 'Nothing' if this wasn't a type created using @large-records@.
parseRecordInfo :: forall m.
     Quasi m
  => String                       -- ^ User-defined constructor
  -> N.Name 'DataName 'N.Global   -- ^ Internal constructor
  -> m (Either String (Record ()))
parseRecordInfo :: String -> Name 'DataName 'Global -> m (Either String (Record ()))
parseRecordInfo String
userConstr Name 'DataName 'Global
internalConstr = ExceptT String m (Record ()) -> m (Either String (Record ()))
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String m (Record ()) -> m (Either String (Record ())))
-> ExceptT String m (Record ()) -> m (Either String (Record ()))
forall a b. (a -> b) -> a -> b
$ do
    Name 'TcClsName 'Global
parent    <- m Info -> ExceptT String m Info
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Except.lift (Name 'DataName 'Global -> m Info
forall (m :: Type -> Type) (ns :: NameSpace).
Quasi m =>
Name ns 'Global -> m Info
N.reify Name 'DataName 'Global
internalConstr) ExceptT String m Info
-> (Info -> ExceptT String m (Name 'TcClsName 'Global))
-> ExceptT String m (Name 'TcClsName 'Global)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Info -> ExceptT String m (Name 'TcClsName 'Global)
getDataConParent
    Type
saturated <- m Info -> ExceptT String m Info
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Except.lift (Name 'TcClsName 'Global -> m Info
forall (m :: Type -> Type) (ns :: NameSpace).
Quasi m =>
Name ns 'Global -> m Info
N.reify Name 'TcClsName 'Global
parent) ExceptT String m Info
-> (Info -> ExceptT String m Type) -> ExceptT String m Type
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Info -> ExceptT String m Type
getSaturatedType
    ([TyVarBndr], [(String, Type)])
parsed    <- m [InstanceDec] -> ExceptT String m [InstanceDec]
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Except.lift (Type -> m [InstanceDec]
getMetadataInstance Type
saturated) ExceptT String m [InstanceDec]
-> ([InstanceDec]
    -> ExceptT String m ([TyVarBndr], [(String, Type)]))
-> ExceptT String m ([TyVarBndr], [(String, Type)])
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= [InstanceDec] -> ExceptT String m ([TyVarBndr], [(String, Type)])
parseTySynInst
    Record () -> ExceptT String m (Record ())
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Record () -> ExceptT String m (Record ()))
-> Record () -> ExceptT String m (Record ())
forall a b. (a -> b) -> a -> b
$ String -> ([TyVarBndr], [(String, Type)]) -> Record ()
mkRecordInfo (Name 'TcClsName 'Global -> String
forall (ns :: NameSpace) (flavour :: Flavour).
Name ns flavour -> String
N.nameBase Name 'TcClsName 'Global
parent) ([TyVarBndr], [(String, Type)])
parsed
  where
    mkRecordInfo ::
         String
      -> ([TyVarBndr], [(String, Type)])
      -> Record ()
    mkRecordInfo :: String -> ([TyVarBndr], [(String, Type)]) -> Record ()
mkRecordInfo String
rType ([TyVarBndr]
tyVars, [(String, Type)]
fieldTypes) = Record :: forall a. String -> String -> [TyVarBndr] -> [Field a] -> Record a
Record {
          recordType :: String
recordType   = String
rType
        , recordConstr :: String
recordConstr = String
userConstr
        , recordTVars :: [TyVarBndr]
recordTVars  = [TyVarBndr]
tyVars
        , recordFields :: [Field ()]
recordFields = ((String, Type) -> Int -> Field ())
-> [(String, Type)] -> [Int] -> [Field ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((String -> Type -> Int -> Field ())
-> (String, Type) -> Int -> Field ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Type -> Int -> Field ()
mkFieldInfo) [(String, Type)]
fieldTypes [Int
0..]
        }

    mkFieldInfo :: String -> Type -> Int -> Field ()
    mkFieldInfo :: String -> Type -> Int -> Field ()
mkFieldInfo String
fName Type
fType Int
ix = Field :: forall a. String -> Type -> Int -> a -> Field a
Field {
          fieldName :: String
fieldName  = String
fName
        , fieldType :: Type
fieldType  = Type
fType
        , fieldIndex :: Int
fieldIndex = Int
ix
        , fieldVal :: ()
fieldVal   = ()
        }

    saturate :: Name -> [TyVarBndr] -> Type
    saturate :: Name -> [TyVarBndr] -> Type
saturate Name
n = (Type -> TyVarBndr -> Type) -> Type -> [TyVarBndr] -> Type
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
t TyVarBndr
v -> Type
t Type -> Type -> Type
`AppT` Name -> Type
VarT (TyVarBndr -> Name
tyVarName TyVarBndr
v)) (Name -> Type
ConT Name
n)

    getMetadataInstance :: Type -> m [InstanceDec]
    getMetadataInstance :: Type -> m [InstanceDec]
getMetadataInstance = Q [InstanceDec] -> m [InstanceDec]
forall (m :: Type -> Type) a. Quasi m => Q a -> m a
runQ (Q [InstanceDec] -> m [InstanceDec])
-> (Type -> Q [InstanceDec]) -> Type -> m [InstanceDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Type] -> Q [InstanceDec]
reifyInstances ''MetadataOf ([Type] -> Q [InstanceDec])
-> (Type -> [Type]) -> Type -> Q [InstanceDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[])

    getSaturatedType :: Info -> ExceptT String m Type
    getSaturatedType :: Info -> ExceptT String m Type
getSaturatedType (TyConI (NewtypeD [] Name
nm [TyVarBndr]
tyVars Maybe Type
_kind Con
_con [DerivClause]
_deriv)) =
        Type -> ExceptT String m Type
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Type -> ExceptT String m Type) -> Type -> ExceptT String m Type
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndr] -> Type
saturate Name
nm [TyVarBndr]
tyVars
    getSaturatedType Info
i =
        Info -> String -> ExceptT String m Type
forall a b. Show a => a -> String -> ExceptT String m b
unexpected Info
i String
"newtype"

    getDataConParent :: Info -> ExceptT String m (N.Name 'TcClsName 'N.Global)
    getDataConParent :: Info -> ExceptT String m (Name 'TcClsName 'Global)
getDataConParent (DataConI Name
_ Type
_ Name
parent) =
        Name 'TcClsName 'Global
-> ExceptT String m (Name 'TcClsName 'Global)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Name 'TcClsName 'Global
 -> ExceptT String m (Name 'TcClsName 'Global))
-> Name 'TcClsName 'Global
-> ExceptT String m (Name 'TcClsName 'Global)
forall a b. (a -> b) -> a -> b
$ Name -> Name 'TcClsName 'Global
forall (ns :: NameSpace) (flavour :: Flavour).
IsFlavour flavour =>
Name -> Name ns flavour
N.fromTH' Name
parent
    getDataConParent Info
i =
        Info -> String -> ExceptT String m (Name 'TcClsName 'Global)
forall a b. Show a => a -> String -> ExceptT String m b
unexpected Info
i String
"data constructor"

    parseTySynInst ::
         [InstanceDec]
      -> ExceptT String m ([TyVarBndr], [(String, Type)])
    parseTySynInst :: [InstanceDec] -> ExceptT String m ([TyVarBndr], [(String, Type)])
parseTySynInst [TySynInstD (TySynEqn Maybe [TyVarBndr]
vars Type
_lhs Type
rhs)] =
        ([TyVarBndr] -> Maybe [TyVarBndr] -> [TyVarBndr]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [TyVarBndr]
vars, ) ([(String, Type)] -> ([TyVarBndr], [(String, Type)]))
-> ExceptT String m [(String, Type)]
-> ExceptT String m ([TyVarBndr], [(String, Type)])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ExceptT String m [(String, Type)]
parseList Type
rhs
    parseTySynInst [InstanceDec]
is =
        [InstanceDec]
-> String -> ExceptT String m ([TyVarBndr], [(String, Type)])
forall a b. Show a => a -> String -> ExceptT String m b
unexpected [InstanceDec]
is String
"type instance"

    parseList :: Type -> ExceptT String m [(String, Type)]
    parseList :: Type -> ExceptT String m [(String, Type)]
parseList (AppT (AppT Type
PromotedConsT Type
t) Type
ts) =
        (:) ((String, Type) -> [(String, Type)] -> [(String, Type)])
-> ExceptT String m (String, Type)
-> ExceptT String m ([(String, Type)] -> [(String, Type)])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ExceptT String m (String, Type)
parseTuple Type
t ExceptT String m ([(String, Type)] -> [(String, Type)])
-> ExceptT String m [(String, Type)]
-> ExceptT String m [(String, Type)]
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> ExceptT String m [(String, Type)]
parseList Type
ts
    parseList Type
PromotedNilT =
        [(String, Type)] -> ExceptT String m [(String, Type)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
    parseList (SigT Type
t Type
_kind) =
        Type -> ExceptT String m [(String, Type)]
parseList Type
t
    parseList Type
t = Type -> String -> ExceptT String m [(String, Type)]
forall a b. Show a => a -> String -> ExceptT String m b
unexpected Type
t String
"list"

    parseTuple :: Type -> ExceptT String m (String, Type)
    parseTuple :: Type -> ExceptT String m (String, Type)
parseTuple (AppT (AppT (PromotedTupleT Int
2) (LitT (StrTyLit String
f))) Type
t) =
        (String, Type) -> ExceptT String m (String, Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String
f, Type
t)
    parseTuple Type
t = Type -> String -> ExceptT String m (String, Type)
forall a b. Show a => a -> String -> ExceptT String m b
unexpected Type
t String
"tuple"

    unexpected :: Show a => a -> String -> ExceptT String m b
    unexpected :: a -> String -> ExceptT String m b
unexpected a
actual String
expected = String -> ExceptT String m b
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> ExceptT String m b) -> String -> ExceptT String m b
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [
          String
"Unexpected "
        , a -> String
forall a. Show a => a -> String
show a
actual
        , String
" (expected "
        , String
expected
        , String
")"
        ]