From 172866755cc43b49ad82521b6b2917bf08016173 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 30 Mar 2017 23:23:27 +0200 Subject: [PATCH] Start impl. layouting for datatypes (#12) Only newtypes work for now; the "interesting" data records are not touched yet. Comment insertion not really considered yet; probably needs work. --- brittany.cabal | 1 + src/Language/Haskell/Brittany/Internal.hs | 8 +- .../Brittany/Internal/Layouters/DataDecl.hs | 134 ++++++++++++++++++ 3 files changed, 140 insertions(+), 3 deletions(-) create mode 100644 src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs diff --git a/brittany.cabal b/brittany.cabal index 3374405..9274ad7 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -77,6 +77,7 @@ library { Language.Haskell.Brittany.Internal.Layouters.IE Language.Haskell.Brittany.Internal.Layouters.Import Language.Haskell.Brittany.Internal.Layouters.Module + Language.Haskell.Brittany.Internal.Layouters.DataDecl Language.Haskell.Brittany.Internal.Transformations.Alt Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Par diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 9720106..6806f86 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -40,6 +40,7 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Module +import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Backend import Language.Haskell.Brittany.Internal.BackendUtils @@ -51,13 +52,15 @@ import Language.Haskell.Brittany.Internal.Transformations.Par import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Indent -import qualified GHC as GHC +import qualified GHC as GHC hiding ( parseModule ) import ApiAnnotation ( AnnKeywordId(..) ) -import GHC ( runGhc +import GHC ( Located + , runGhc , GenLocated(L) , moduleNameString ) +import RdrName ( RdrName(..) ) import SrcLoc ( SrcSpan ) import HsSyn import qualified DynFlags as GHC @@ -485,7 +488,6 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () - getDeclBindingNames :: LHsDecl GhcPs -> [String] #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ getDeclBindingNames (L _ decl) = case decl of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs new file mode 100644 index 0000000..0102034 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE KindSignatures #-} + +module Language.Haskell.Brittany.Internal.Layouters.DataDecl + ( layoutDataDecl + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName ( RdrName(..) ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import qualified GHC +import HsSyn +import Name +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) + +import Language.Haskell.Brittany.Internal.Layouters.Type +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Utils + +import Bag ( mapBagM ) + + + +layoutDataDecl + :: Located (HsDecl RdrName) + -> Located RdrName + -> LHsQTyVars RdrName + -> HsDataDefn RdrName + -> ToBriDocM BriDocNumbered +layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of + HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _)) -> + docWrapNode ld $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarDocs <- bndrs `forM` \case + (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + tyVarLine <- + fmap return + $ docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLit (Text.pack "(") + , docLit vname + , docSeparator + , kind + , docLit (Text.pack ")") + ] + headDoc <- fmap return $ docSeq + [ appSep $ docLit (Text.pack "newtype") + , appSep $ docLit nameStr + , appSep tyVarLine + ] + rhsDoc <- fmap return $ case details of + PrefixCon args -> docSeq + [ docLit consNameStr + , docSeparator + , docSeq $ List.intersperse docSeparator $ args <&> layoutType + ] + RecCon (L _ fields) -> docSeq + [ appSep $ docLit $ Text.pack "{" + , docSeq + $ List.intersperse docSeparator + $ fields + <&> \(L _ (ConDeclField names t _)) -> do + docSeq + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \(L _ (FieldOcc fieldName _)) -> + docLit =<< lrdrNameToTextAnn fieldName + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , layoutType t + ] + , docLit $ Text.pack "}" + ] + InfixCon arg1 arg2 -> docSeq + [ layoutType arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType arg2 + ] + let + mainDoc = + docSeq + [ headDoc + , docSeparator + , docLit (Text.pack "=") + , docSeparator + , rhsDoc + ] + case mDerivs of + Nothing -> mainDoc + Just (L _ [(HsIB _ t)]) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [docLit $ Text.pack "deriving", docSeparator, layoutType t] + Just (L _ ts ) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [ docLit $ Text.pack "deriving" + , docSeparator + , docLit $ Text.pack "(" + , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> + layoutType t + , docLit $ Text.pack ")" + ] + _ -> briDocByExactNoComment ld + + -- HsDataDefn DataType _ctxt _ctype Nothing _conss _derivs -> do + -- -- _ name vars ctxt ctype mKindSig conss derivs + -- nameStr <- lrdrNameToTextAnn name + -- docLit nameStr + + _ -> briDocByExactNoComment ld +