{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module HIndent.Ast.Declaration.Data.Body
  ( DataBody
  , mkDataBody
  ) where

import Control.Monad
import Data.Maybe
import GHC.Hs (HsDataDefn(dd_derivs))
import qualified GHC.Types.SrcLoc as GHC
import HIndent.Applicative
import HIndent.Ast.Declaration.Data.Deriving.Clause
import HIndent.Ast.Declaration.Data.GADT.Constructor
import HIndent.Ast.Declaration.Data.Haskell98.Constructor
import HIndent.Ast.NodeComments hiding (fromEpAnn)
import HIndent.Ast.Type
import HIndent.Ast.WithComments
import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
import {-# SOURCE #-} HIndent.Pretty
import HIndent.Pretty.Combinators
import HIndent.Pretty.NodeComments

data DataBody
  = GADT
      { DataBody -> Maybe (WithComments Type)
kind :: Maybe (WithComments Type)
      , DataBody -> [WithComments GADTConstructor]
constructors :: [WithComments GADTConstructor]
      }
  | Haskell98
      { DataBody -> [WithComments Haskell98Constructor]
constructorsH98 :: [WithComments Haskell98Constructor]
      , DataBody -> DerivingClause
derivings :: DerivingClause
      }

instance CommentExtraction DataBody where
  nodeComments :: DataBody -> NodeComments
nodeComments GADT {} = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []
  nodeComments Haskell98 {} = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []

instance Pretty DataBody where
  pretty' :: DataBody -> Printer ()
pretty' GADT {[WithComments GADTConstructor]
Maybe (WithComments Type)
kind :: DataBody -> Maybe (WithComments Type)
constructors :: DataBody -> [WithComments GADTConstructor]
kind :: Maybe (WithComments Type)
constructors :: [WithComments GADTConstructor]
..} = do
    Maybe (WithComments Type)
-> (WithComments Type -> Printer ()) -> Printer ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (WithComments Type)
kind ((WithComments Type -> Printer ()) -> Printer ())
-> (WithComments Type -> Printer ()) -> Printer ()
forall a b. (a -> b) -> a -> b
$ \WithComments Type
x -> HasCallStack => String -> Printer ()
String -> Printer ()
string String
" :: " Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WithComments Type -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments Type
x
    HasCallStack => String -> Printer ()
String -> Printer ()
string String
" where"
    Printer () -> Printer ()
forall a. Printer a -> Printer a
indentedBlock (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ [Printer ()] -> Printer ()
newlinePrefixed ([Printer ()] -> Printer ()) -> [Printer ()] -> Printer ()
forall a b. (a -> b) -> a -> b
$ (WithComments GADTConstructor -> Printer ())
-> [WithComments GADTConstructor] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithComments GADTConstructor -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty [WithComments GADTConstructor]
constructors
  pretty' Haskell98 {[WithComments Haskell98Constructor]
DerivingClause
constructorsH98 :: DataBody -> [WithComments Haskell98Constructor]
derivings :: DataBody -> DerivingClause
constructorsH98 :: [WithComments Haskell98Constructor]
derivings :: DerivingClause
..} = do
    case [WithComments Haskell98Constructor]
constructorsH98 of
      [] -> Printer () -> Printer ()
forall a. Printer a -> Printer a
indentedBlock Printer ()
derivingsAfterNewline
      [WithComments Haskell98Constructor
x]
        | Haskell98Constructor -> Bool
hasSingleRecordConstructor (Haskell98Constructor -> Bool) -> Haskell98Constructor -> Bool
forall a b. (a -> b) -> a -> b
$ WithComments Haskell98Constructor -> Haskell98Constructor
forall a. WithComments a -> a
getNode WithComments Haskell98Constructor
x -> do
          HasCallStack => String -> Printer ()
String -> Printer ()
string String
" = "
          WithComments Haskell98Constructor -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments Haskell98Constructor
x
          Bool -> Printer () -> Printer ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DerivingClause -> Bool
hasDerivings DerivingClause
derivings) (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ Printer ()
space Printer () -> Printer () -> Printer ()
forall a. Printer () -> Printer a -> Printer a
|=> DerivingClause -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty DerivingClause
derivings
        | Bool
otherwise -> do
          HasCallStack => String -> Printer ()
String -> Printer ()
string String
" ="
          Printer ()
newline
          Printer () -> Printer ()
forall a. Printer a -> Printer a
indentedBlock (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ WithComments Haskell98Constructor -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments Haskell98Constructor
x Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer ()
derivingsAfterNewline
      [WithComments Haskell98Constructor]
_ ->
        Printer () -> Printer ()
forall a. Printer a -> Printer a
indentedBlock (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ do
          Printer ()
newline
          HasCallStack => String -> Printer ()
String -> Printer ()
string String
"= " Printer () -> Printer () -> Printer ()
forall a. Printer () -> Printer a -> Printer a
|=> [Printer ()] -> Printer ()
vBarSep ((WithComments Haskell98Constructor -> Printer ())
-> [WithComments Haskell98Constructor] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithComments Haskell98Constructor -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty [WithComments Haskell98Constructor]
constructorsH98)
          Printer ()
derivingsAfterNewline
    where
      derivingsAfterNewline :: Printer ()
derivingsAfterNewline =
        Bool -> Printer () -> Printer ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DerivingClause -> Bool
hasDerivings DerivingClause
derivings) (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ Printer ()
newline Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DerivingClause -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty DerivingClause
derivings

mkDataBody :: GHC.HsDataDefn GHC.GhcPs -> DataBody
mkDataBody :: HsDataDefn GhcPs -> DataBody
mkDataBody defn :: HsDataDefn GhcPs
defn@GHC.HsDataDefn {HsDeriving GhcPs
Maybe (LHsContext GhcPs)
Maybe (XRec GhcPs CType)
Maybe (LHsKind GhcPs)
XCHsDataDefn GhcPs
DataDefnCons (LConDecl GhcPs)
dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_ext :: XCHsDataDefn GhcPs
dd_ctxt :: Maybe (LHsContext GhcPs)
dd_cType :: Maybe (XRec GhcPs CType)
dd_kindSig :: Maybe (LHsKind GhcPs)
dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_derivs :: HsDeriving GhcPs
dd_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ext :: forall pass. HsDataDefn pass -> XCHsDataDefn pass
..} =
  if HsDataDefn GhcPs -> Bool
isGADT HsDataDefn GhcPs
defn
    then GADT
           { constructors :: [WithComments GADTConstructor]
constructors =
               [WithComments GADTConstructor]
-> Maybe [WithComments GADTConstructor]
-> [WithComments GADTConstructor]
forall a. a -> Maybe a -> a
fromMaybe (String -> [WithComments GADTConstructor]
forall a. HasCallStack => String -> a
error String
"Some constructors are not GADT ones.")
                 (Maybe [WithComments GADTConstructor]
 -> [WithComments GADTConstructor])
-> Maybe [WithComments GADTConstructor]
-> [WithComments GADTConstructor]
forall a b. (a -> b) -> a -> b
$ (LConDecl GhcPs -> Maybe (WithComments GADTConstructor))
-> [LConDecl GhcPs] -> Maybe [WithComments GADTConstructor]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((ConDecl GhcPs -> Maybe GADTConstructor)
-> WithComments (ConDecl GhcPs)
-> Maybe (WithComments GADTConstructor)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithComments a -> f (WithComments b)
traverse ConDecl GhcPs -> Maybe GADTConstructor
mkGADTConstructor (WithComments (ConDecl GhcPs)
 -> Maybe (WithComments GADTConstructor))
-> (GenLocated SrcSpanAnnA (ConDecl GhcPs)
    -> WithComments (ConDecl GhcPs))
-> GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> Maybe (WithComments GADTConstructor)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> WithComments (ConDecl GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated)
                 ([LConDecl GhcPs] -> Maybe [WithComments GADTConstructor])
-> [LConDecl GhcPs] -> Maybe [WithComments GADTConstructor]
forall a b. (a -> b) -> a -> b
$ HsDataDefn GhcPs -> [LConDecl GhcPs]
getConDecls HsDataDefn GhcPs
defn
           , Maybe (WithComments Type)
kind :: Maybe (WithComments Type)
kind :: Maybe (WithComments Type)
..
           }
    else Haskell98
           { constructorsH98 :: [WithComments Haskell98Constructor]
constructorsH98 =
               (ConDecl GhcPs -> Haskell98Constructor)
-> WithComments (ConDecl GhcPs)
-> WithComments Haskell98Constructor
forall a b. (a -> b) -> WithComments a -> WithComments b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                 (Haskell98Constructor
-> Maybe Haskell98Constructor -> Haskell98Constructor
forall a. a -> Maybe a -> a
fromMaybe
                    (String -> Haskell98Constructor
forall a. HasCallStack => String -> a
error String
"Some constructors are not in the Haskell 98 style.")
                    (Maybe Haskell98Constructor -> Haskell98Constructor)
-> (ConDecl GhcPs -> Maybe Haskell98Constructor)
-> ConDecl GhcPs
-> Haskell98Constructor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDecl GhcPs -> Maybe Haskell98Constructor
mkHaskell98Constructor)
                 (WithComments (ConDecl GhcPs) -> WithComments Haskell98Constructor)
-> (GenLocated SrcSpanAnnA (ConDecl GhcPs)
    -> WithComments (ConDecl GhcPs))
-> GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> WithComments Haskell98Constructor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> WithComments (ConDecl GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated
                 (GenLocated SrcSpanAnnA (ConDecl GhcPs)
 -> WithComments Haskell98Constructor)
-> [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
-> [WithComments Haskell98Constructor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsDataDefn GhcPs -> [LConDecl GhcPs]
getConDecls HsDataDefn GhcPs
defn
           , DerivingClause
derivings :: DerivingClause
derivings :: DerivingClause
..
           }
  where
    kind :: Maybe (WithComments Type)
kind = (HsType GhcPs -> Type)
-> WithComments (HsType GhcPs) -> WithComments Type
forall a b. (a -> b) -> WithComments a -> WithComments b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsType GhcPs -> Type
mkType (WithComments (HsType GhcPs) -> WithComments Type)
-> (GenLocated SrcSpanAnnA (HsType GhcPs)
    -> WithComments (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> WithComments Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsType GhcPs)
-> WithComments (HsType GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated (GenLocated SrcSpanAnnA (HsType GhcPs) -> WithComments Type)
-> Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe (WithComments Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LHsKind GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
dd_kindSig
    derivings :: DerivingClause
derivings = HsDeriving GhcPs -> DerivingClause
mkDerivingClause HsDeriving GhcPs
dd_derivs

isGADT :: GHC.HsDataDefn GHC.GhcPs -> Bool
isGADT :: HsDataDefn GhcPs -> Bool
isGADT (HsDataDefn GhcPs -> [LConDecl GhcPs]
getConDecls -> (GHC.L SrcSpanAnnA
_ GHC.ConDeclGADT {}:[LConDecl GhcPs]
_)) = Bool
True
isGADT HsDataDefn GhcPs
_ = Bool
False

getConDecls :: GHC.HsDataDefn GHC.GhcPs -> [GHC.LConDecl GHC.GhcPs]
#if MIN_VERSION_ghc_lib_parser(9, 6, 0)
getConDecls :: HsDataDefn GhcPs -> [LConDecl GhcPs]
getConDecls GHC.HsDataDefn {HsDeriving GhcPs
Maybe (LHsContext GhcPs)
Maybe (XRec GhcPs CType)
Maybe (LHsKind GhcPs)
XCHsDataDefn GhcPs
DataDefnCons (LConDecl GhcPs)
dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ext :: forall pass. HsDataDefn pass -> XCHsDataDefn pass
dd_ext :: XCHsDataDefn GhcPs
dd_ctxt :: Maybe (LHsContext GhcPs)
dd_cType :: Maybe (XRec GhcPs CType)
dd_kindSig :: Maybe (LHsKind GhcPs)
dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_derivs :: HsDeriving GhcPs
..} =
  case DataDefnCons (LConDecl GhcPs)
dd_cons of
    GHC.NewTypeCon LConDecl GhcPs
x -> [LConDecl GhcPs
x]
    GHC.DataTypeCons Bool
_ [LConDecl GhcPs]
xs -> [LConDecl GhcPs]
xs
#else
getConDecls GHC.HsDataDefn {..} = dd_cons
#endif