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 GhcPlugins 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
  (Located RdrName
lIdP, HsConDeclDetails GhcPs
hsConDeclDetails) <- case LConDecl GhcPs -> SrcSpanLess (LConDecl GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LConDecl GhcPs
lConDecl of
    Ghc.ConDeclH98 _ x _ _ _ y _ -> (Located RdrName, HsConDeclDetails GhcPs)
-> Hsc (Located RdrName, HsConDeclDetails GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located (IdP GhcPs)
Located RdrName
x, HsConDeclDetails GhcPs
y)
    SrcSpanLess (LConDecl GhcPs)
_ -> SrcSpan -> MsgDoc -> Hsc (Located RdrName, HsConDeclDetails GhcPs)
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc (Located RdrName, HsConDeclDetails GhcPs))
-> MsgDoc -> Hsc (Located RdrName, HsConDeclDetails GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
Ghc.text String
"unsupported LConDecl"
  Located [LConDeclField GhcPs]
lConDeclFields <- case HsConDeclDetails GhcPs
hsConDeclDetails of
    Ghc.RecCon Located [LConDeclField GhcPs]
x -> Located [LConDeclField GhcPs]
-> Hsc (Located [LConDeclField GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Located [LConDeclField GhcPs]
x
    HsConDeclDetails GhcPs
_ -> SrcSpan -> MsgDoc -> Hsc (Located [LConDeclField GhcPs])
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc (Located [LConDeclField GhcPs]))
-> MsgDoc -> Hsc (Located [LConDeclField GhcPs])
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
Ghc.text String
"unsupported HsConDeclDetails"
  [Field]
theFields <-
    ([[Field]] -> [Field]) -> Hsc [[Field]] -> Hsc [Field]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Field]] -> [Field]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Hsc [[Field]] -> Hsc [Field])
-> ((LConDeclField GhcPs -> Hsc [Field]) -> Hsc [[Field]])
-> (LConDeclField GhcPs -> Hsc [Field])
-> Hsc [Field]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LConDeclField GhcPs]
-> (LConDeclField GhcPs -> Hsc [Field]) -> Hsc [[Field]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
Monad.forM (Located [LConDeclField GhcPs]
-> SrcSpanLess (Located [LConDeclField GhcPs])
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc Located [LConDeclField GhcPs]
lConDeclFields) ((LConDeclField GhcPs -> Hsc [Field]) -> Hsc [Field])
-> (LConDeclField GhcPs -> Hsc [Field]) -> Hsc [Field]
forall a b. (a -> b) -> a -> b
$ \LConDeclField GhcPs
lConDeclField -> do
      ([LFieldOcc GhcPs]
lFieldOccs, LBangType GhcPs
lHsType) <- case LConDeclField GhcPs -> SrcSpanLess (LConDeclField GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc LConDeclField GhcPs
lConDeclField of
        Ghc.ConDeclField _ x y _ -> ([LFieldOcc GhcPs], LBangType GhcPs)
-> Hsc ([LFieldOcc GhcPs], LBangType GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LFieldOcc GhcPs]
x, LBangType GhcPs
y)
        SrcSpanLess (LConDeclField GhcPs)
_ -> SrcSpan -> MsgDoc -> Hsc ([LFieldOcc GhcPs], LBangType GhcPs)
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc ([LFieldOcc GhcPs], LBangType GhcPs))
-> MsgDoc -> Hsc ([LFieldOcc GhcPs], LBangType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
Ghc.text String
"unsupported LConDeclField"
      (LFieldOcc GhcPs -> Hsc Field) -> [LFieldOcc GhcPs] -> Hsc [Field]
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 LBangType GhcPs
lHsType) [LFieldOcc GhcPs]
lFieldOccs
  Constructor -> Hsc Constructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure Constructor :: IdP GhcPs -> [Field] -> Constructor
Constructor { name :: IdP GhcPs
name = Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
Ghc.unLoc Located RdrName
lIdP, fields :: [Field]
fields = [Field]
theFields }