module Evoke.Type.Type
  ( Type(..)
  , make
  , qualifiedName
  ) where

import qualified Control.Monad as Monad
import qualified Evoke.Hsc as Hsc
import qualified Evoke.Type.Constructor as Constructor
import qualified GHC.Hs as Ghc
import qualified GhcPlugins as Ghc

data Type = Type
  { Type -> IdP GhcPs
name :: Ghc.IdP Ghc.GhcPs
  , Type -> [IdP GhcPs]
variables :: [Ghc.IdP Ghc.GhcPs]
  , Type -> [Constructor]
constructors :: [Constructor.Constructor]
  }

make
  :: Ghc.LIdP Ghc.GhcPs
  -> Ghc.LHsQTyVars Ghc.GhcPs
  -> [Ghc.LConDecl Ghc.GhcPs]
  -> Ghc.SrcSpan
  -> Ghc.Hsc Type
make :: LIdP GhcPs
-> LHsQTyVars GhcPs -> [LConDecl GhcPs] -> SrcSpan -> Hsc Type
make LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls SrcSpan
srcSpan = do
  [LHsTyVarBndr GhcPs]
lHsTyVarBndrs <- case LHsQTyVars GhcPs
lHsQTyVars of
    Ghc.HsQTvs XHsQTvs GhcPs
_ [LHsTyVarBndr GhcPs]
hsq_explicit -> [LHsTyVarBndr GhcPs] -> Hsc [LHsTyVarBndr GhcPs]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LHsTyVarBndr GhcPs]
hsq_explicit
    LHsQTyVars GhcPs
_ -> SrcSpan -> MsgDoc -> Hsc [LHsTyVarBndr GhcPs]
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc [LHsTyVarBndr GhcPs])
-> MsgDoc -> Hsc [LHsTyVarBndr GhcPs]
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
Ghc.text String
"unsupported LHsQTyVars"
  [RdrName]
theVariables <- [LHsTyVarBndr GhcPs]
-> (LHsTyVarBndr GhcPs -> Hsc RdrName) -> Hsc [RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
Monad.forM [LHsTyVarBndr GhcPs]
lHsTyVarBndrs ((LHsTyVarBndr GhcPs -> Hsc RdrName) -> Hsc [RdrName])
-> (LHsTyVarBndr GhcPs -> Hsc RdrName) -> Hsc [RdrName]
forall a b. (a -> b) -> a -> b
$ \LHsTyVarBndr GhcPs
lHsTyVarBndr ->
    case LHsTyVarBndr GhcPs -> SrcSpanLess (LHsTyVarBndr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LHsTyVarBndr GhcPs
lHsTyVarBndr of
      Ghc.UserTyVar _ var -> RdrName -> Hsc RdrName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RdrName -> Hsc RdrName) -> RdrName -> Hsc RdrName
forall a b. (a -> b) -> a -> b
$ Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LIdP GhcPs
Located RdrName
var
      SrcSpanLess (LHsTyVarBndr GhcPs)
_ -> SrcSpan -> MsgDoc -> Hsc RdrName
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc RdrName) -> MsgDoc -> Hsc RdrName
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
Ghc.text String
"unknown LHsTyVarBndr"
  [Constructor]
theConstructors <- (LConDecl GhcPs -> Hsc Constructor)
-> [LConDecl GhcPs] -> Hsc [Constructor]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan -> LConDecl GhcPs -> Hsc Constructor
Constructor.make SrcSpan
srcSpan) [LConDecl GhcPs]
lConDecls
  Type -> Hsc Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type :: IdP GhcPs -> [IdP GhcPs] -> [Constructor] -> Type
Type
    { name :: IdP GhcPs
name = Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LIdP GhcPs
Located RdrName
lIdP
    , variables :: [IdP GhcPs]
variables = [IdP GhcPs]
[RdrName]
theVariables
    , constructors :: [Constructor]
constructors = [Constructor]
theConstructors
    }

qualifiedName :: Ghc.ModuleName -> Type -> String
qualifiedName :: ModuleName -> Type -> String
qualifiedName ModuleName
moduleName Type
type_ = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
  [ ModuleName -> String
Ghc.moduleNameString ModuleName
moduleName
  , String
"."
  , OccName -> String
Ghc.occNameString (OccName -> String) -> (RdrName -> OccName) -> RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
Ghc.rdrNameOcc (RdrName -> String) -> RdrName -> String
forall a b. (a -> b) -> a -> b
$ Type -> IdP GhcPs
name Type
type_
  ]