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_ ]