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

import qualified Control.Monad as Monad
import qualified Evoke.Hsc as Hsc
import qualified Evoke.Type.Field as Field
import qualified GHC.Hs as Ghc
import qualified GHC.Plugins as Ghc

data Constructor = Constructor
  { Constructor -> IdP GhcPs
name :: Ghc.IdP Ghc.GhcPs,
    Constructor -> [Field]
fields :: [Field.Field]
  }

make :: Ghc.SrcSpan -> Ghc.LConDecl Ghc.GhcPs -> Ghc.Hsc Constructor
make :: SrcSpan -> LConDecl GhcPs -> Hsc Constructor
make SrcSpan
srcSpan LConDecl GhcPs
lConDecl = do
  (GenLocated SrcSpanAnnN RdrName
lIdP, HsConDetails
  Void
  (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
  (GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
hsConDeclDetails) <- case forall l e. GenLocated l e -> e
Ghc.unLoc LConDecl GhcPs
lConDecl of
    Ghc.ConDeclH98 XConDeclH98 GhcPs
_ LIdP GhcPs
x Bool
_ [LHsTyVarBndr Specificity GhcPs]
_ Maybe (LHsContext GhcPs)
_ HsConDeclH98Details GhcPs
y Maybe LHsDocString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (LIdP GhcPs
x, HsConDeclH98Details GhcPs
y)
    ConDecl GhcPs
_ -> forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ String -> SDoc
Ghc.text String
"unsupported LConDecl"
  GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
lConDeclFields <- case HsConDetails
  Void
  (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
  (GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
hsConDeclDetails of
    Ghc.RecCon GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
x
    HsConDetails
  Void
  (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
  (GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
_ -> forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ String -> SDoc
Ghc.text String
"unsupported HsConDeclDetails"
  [Field]
theFields <-
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
Monad.forM (forall l e. GenLocated l e -> e
Ghc.unLoc GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
lConDeclFields) forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnA (ConDeclField GhcPs)
lConDeclField -> do
      ([GenLocated SrcSpan (FieldOcc GhcPs)]
lFieldOccs, GenLocated SrcSpanAnnA (HsType GhcPs)
lHsType) <- case forall l e. GenLocated l e -> e
Ghc.unLoc GenLocated SrcSpanAnnA (ConDeclField GhcPs)
lConDeclField of
        Ghc.ConDeclField XConDeclField GhcPs
_ [LFieldOcc GhcPs]
x LBangType GhcPs
y Maybe LHsDocString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LFieldOcc GhcPs]
x, LBangType GhcPs
y)
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan -> LBangType GhcPs -> LFieldOcc GhcPs -> Hsc Field
Field.make SrcSpan
srcSpan GenLocated SrcSpanAnnA (HsType GhcPs)
lHsType) [GenLocated SrcSpan (FieldOcc GhcPs)]
lFieldOccs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Constructor {name :: IdP GhcPs
name = forall l e. GenLocated l e -> e
Ghc.unLoc GenLocated SrcSpanAnnN RdrName
lIdP, fields :: [Field]
fields = [Field]
theFields}