{-# 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