Add type synonym formatting

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)
+
+
 ###############################################################################
 ###############################################################################
 ###############################################################################

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

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