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.remotes/ChickenProp/datadecl
Lennart Spitzner
Evan Rutledge Borden
parent
4497fa927f
commit
b347fbe898
|
|
@ -71,6 +71,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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
getDeclBindingNames (L _ decl) = case decl of
|
||||
SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
Loading…
Reference in New Issue