From e1b43531a869468960fd6535a1a35e7ad3de088d Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Sat, 13 Oct 2018 14:31:16 -0400 Subject: [PATCH] Add type synonym formatting --- src-literatetests/10-tests.blt | 94 ++++++++++++++++ .../Brittany/Internal/Layouters/Decl.hs | 105 +++++++++++++++++- .../Haskell/Brittany/Internal/Prelude.hs | 8 ++ 3 files changed, 206 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 1597c4b..f2b02d8 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -906,6 +906,100 @@ import qualified Data.List as L -- Test import Test ( test ) + +############################################################################### +############################################################################### +############################################################################### +#group type synonyms +############################################################################### +############################################################################### +############################################################################### + +#test simple-synonym + +type MySynonym = String + +#test parameterised-synonym + +type MySynonym a = [a] + +#test long-function-synonym + +-- | Important comment thrown in +type MySynonym b a + = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b + +#test overflowing-function-synonym + +type MySynonym3 b a + = MySynonym a b + -> MySynonym a b + -- ^ RandomComment + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-kind-sig + +type MySynonym (a :: * -> *) + = MySynonym a b + -> MySynonym a b + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-constraint + +type MySynonym a = Num a => a -> Int + +#test synonym-overflowing-with-constraint + +type MySynonym a + = Num a + => AReallyLongTypeName + -> AnotherReallyLongTypeName + -> AThirdTypeNameToOverflow + +#test synonym-forall + +{-# LANGUAGE RankNTypes #-} + +type MySynonym = forall a . [a] + +#test synonym-operator + +type (:+:) a b = (a, b) + +#test synonym-infix + +type a `MySynonym` b = a -> b + +#test synonym-infix-operator + +type a :+: b = (a, b) + +#test synonym-infix-parens + +type (a `Foo` b) c = (a, b, c) + +#test synonym-comments +#pending + +type Foo a -- fancy type comment + = -- strange comment + Int + +#test synonym-type-operators +#pending + +type (a :+: b) = (a, b) + +#test synonym-multi-parens +#pending + +type ((a :+: b) c) = (a, c) + + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 2ece967..49fbd12 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -26,7 +26,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils -import GHC ( runGhc, GenLocated(L), moduleNameString ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId (..) + ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn import Name @@ -34,6 +38,9 @@ import BasicTypes ( InlinePragma(..) , Activation(..) , InlineSpec(..) , RuleMatchInfo(..) +#if MIN_VERSION_ghc(8,2,0) + , LexicalFixity(..) +#endif ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) @@ -43,6 +50,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern import Bag ( mapBagM, bagToList, emptyBag ) +import Data.Char (isUpper) @@ -52,6 +60,7 @@ layoutDecl d@(L loc decl) = case decl of ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case Left ns -> docLines $ return <$> ns Right n -> return n + TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD (TyFamInstD{}) -> do -- this is a (temporary (..)) workaround for "type instance" decls -- that do not round-trip through exactprint properly. @@ -69,6 +78,10 @@ layoutDecl d@(L loc decl) = case decl of _ -> briDocByExactNoComment d +-------------------------------------------------------------------------------- +-- Sig +-------------------------------------------------------------------------------- + layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ @@ -168,6 +181,11 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of ] _ -> unknownNodeError "" lgstmt -- TODO + +-------------------------------------------------------------------------------- +-- HsBind +-------------------------------------------------------------------------------- + layoutBind :: ToBriDocC (HsBindLR GhcPs GhcPs) @@ -595,6 +613,91 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ++ wherePartMultiLine + +-------------------------------------------------------------------------------- +-- TyClDecl +-------------------------------------------------------------------------------- + +layoutTyCl :: ToBriDoc TyClDecl +layoutTyCl ltycl@(L _loc tycl) = case tycl of +#if MIN_VERSION_ghc(8,2,0) + SynDecl name vars fixity typ _ -> do + let isInfix = case fixity of + Prefix -> False + Infix -> True +#else + SynDecl name vars typ _ -> do + nameStr <- lrdrNameToTextAnn name + let isInfixTypeOp = case Text.uncons nameStr of + Nothing -> False + Just (c, _) -> not (c == '(' || isUpper c) + isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote +#endif + docWrapNode ltycl $ layoutSynDecl isInfix name (hsq_explicit vars) typ + _ -> briDocByExactNoComment ltycl + +layoutSynDecl + :: Bool + -> Located (IdP GhcPs) + -> [LHsTyVarBndr GhcPs] + -> LHsType GhcPs + -> ToBriDocM BriDocNumbered +layoutSynDecl isInfix name vars typ = do + nameStr <- lrdrNameToTextAnn name + let + lhs = if isInfix + then do + let + (a : b : rest) = vars + -- This isn't quite right, but does give syntactically valid results + hasParens = not $ null rest + docSeq + $ [ appSep $ docLit $ Text.pack "type" + , appSep + . docSeq + $ [ docParenL | hasParens ] + ++ [ appSep $ layoutTyVarBndr a + , appSep $ docLit nameStr + , layoutTyVarBndr b + ] + ++ [ docParenR | hasParens ] + ] + ++ fmap (appSep . layoutTyVarBndr) rest + else + docSeq + $ [appSep $ docLit $ Text.pack "type", appSep $ docLit nameStr] + ++ fmap (appSep . layoutTyVarBndr) vars + typeDoc <- docSharedWrapper layoutType typ + docAlt + [ docSeq [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] + , docAddBaseY BrIndentRegular $ docPar + lhs + (docCols + ColTyOpPrefix + [docLit $ Text.pack "= ", docAddBaseY (BrIndentSpecial 2) typeDoc] + ) + ] + +layoutTyVarBndr :: ToBriDoc HsTyVarBndr +layoutTyVarBndr (L _ bndr) = case bndr of + UserTyVar name -> do + nameStr <- lrdrNameToTextAnn name + docLit nameStr + KindedTyVar name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] + + +-------------------------------------------------------------------------------- +-- ClsInstDecl +-------------------------------------------------------------------------------- + -- | Layout an @instance@ declaration -- -- Layout signatures and bindings using the corresponding layouters from the diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 2d8a038..6b93bf0 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,3 +1,8 @@ +#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +{-# LANGUAGE TypeFamilies #-} +#endif + + module Language.Haskell.Brittany.Internal.Prelude ( module E , module Language.Haskell.Brittany.Internal.Prelude @@ -400,5 +405,8 @@ todo = error "todo" #if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +type family IdP p +type instance IdP GhcPs = RdrName + type GhcPs = RdrName #endif