Merge pull request #189 from ruhatch/type-synonyms

Add type synonym formatting

src-literatetests/10-tests.blt

@@ -906,6 +906,99 @@ 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
+
+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/Backend.hs

@@ -19,6 +19,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
 import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
 import           Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation )
 
+import GHC ( AnnKeywordId (..) )
+
 import           Language.Haskell.Brittany.Internal.LayouterBasics
 import           Language.Haskell.Brittany.Internal.BackendUtils
 import           Language.Haskell.Brittany.Internal.Utils
@@ -170,9 +172,13 @@ layoutBriDocM = \case
         priors
           `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
                     do
-                      -- evil hack for CPP:
                       case comment of
                         ('#':_) -> layoutMoveToCommentPos y (-999)
+                                   --  ^ evil hack for CPP
+                        "("     -> pure ()
+                        ")"     -> pure ()
+                                   --  ^ these two fix the formatting of parens
+                                   -- on the lhs of type alias defs
                         _       -> layoutMoveToCommentPos y x
                       -- fixedX <- fixMoveToLineByIsNewline x
                       -- replicateM_ fixedX layoutWriteNewline
@@ -241,9 +247,12 @@ layoutBriDocM = \case
       Just comments -> do
         comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
           do
-      -- evil hack for CPP:
             case comment of
               ('#':_) -> layoutMoveToCommentPos y (-999)
+                         --  ^ evil hack for CPP
+              ")"     -> pure ()
+                         --  ^ fixes the formatting of parens
+                         --    on the lhs of type alias defs
               _       -> layoutMoveToCommentPos y x
             -- fixedX <- fixMoveToLineByIsNewline x
             -- replicateM_ fixedX layoutWriteNewline

src/Language/Haskell/Brittany/Internal/BackendUtils.hs

@@ -188,19 +188,20 @@ layoutMoveToCommentPos y x = do
     { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
       Left i  -> if y == 0 then Left i else Right y
       Right{} -> Right y
-    , _lstate_addSepSpace      = if Data.Maybe.isJust (_lstate_commentCol state)
+    , _lstate_addSepSpace      =
-      then Just $ case _lstate_curYOrAddNewline state of
+      Just $ if Data.Maybe.isJust (_lstate_commentCol state)
-        Left{}  -> if y == 0 then x else _lstate_indLevelLinger state + x
+        then case _lstate_curYOrAddNewline state of
-        Right{} -> _lstate_indLevelLinger state + x
+          Left{}  -> if y == 0 then x else _lstate_indLevelLinger state + x
-      else Just $ if y == 0 then x else _lstate_indLevelLinger state + x
+          Right{} -> _lstate_indLevelLinger state + x
-    , _lstate_commentCol       = Just $ case _lstate_commentCol state of
+        else if y == 0 then x else _lstate_indLevelLinger state + x
-      Just existing -> existing
+    , _lstate_commentCol       =
-      Nothing       -> case _lstate_curYOrAddNewline state of
+      Just $ case _lstate_commentCol state of
-        Left i  -> i + fromMaybe 0 (_lstate_addSepSpace state)
+        Just existing -> existing
-        Right{} -> lstate_baseY state
+        Nothing -> case _lstate_curYOrAddNewline state of
+          Left i  -> i + fromMaybe 0 (_lstate_addSepSpace state)
+          Right{} -> lstate_baseY state
     }
 
-
 -- | does _not_ add spaces to again reach the current base column.
 layoutWriteNewline
   :: ( MonadMultiWriter Text.Builder.Builder m

src/Language/Haskell/Brittany/Internal/LayouterBasics.hs

@@ -63,6 +63,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , docSharedWrapper
   , hasAnyCommentsBelow
   , hasAnyCommentsConnected
+  , hasAnyCommentsPrior
+  , hasAnnKeywordComment
   , hasAnnKeyword
   )
 where
@@ -296,18 +298,35 @@ hasAnyCommentsConnected ast = do
     $ Map.elems
     $ anns
 
+hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyCommentsPrior ast = astAnn ast <&> \case
+  Nothing -> False
+  Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors
+
+hasAnnKeywordComment
+  :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
+hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
+  Nothing  -> False
+  Just ann -> any hasK (extractAllComments ann)
+  where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
+
 hasAnnKeyword
   :: (Data a, MonadMultiReader (Map AnnKey Annotation) m)
   => Located a
   -> AnnKeywordId
   -> m Bool
-hasAnnKeyword ast annKeyword = do
+hasAnnKeyword ast annKeyword = astAnn ast <&> \case
-  anns <- mAsk
+  Nothing -> False
-  let hasK (ExactPrint.Types.G x, _) = x == annKeyword
+  Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
-      hasK _                         = False
+ where
-  pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
+  hasK (ExactPrint.Types.G x, _) = x == annKeyword
-    Nothing -> False
+  hasK _                         = False
-    Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
+
+astAnn
+  :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
+  => GHC.Located ast
+  -> m (Maybe Annotation)
+astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk
 
 -- new BriDoc stuff
 

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,103 @@ 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
+    -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP
+    -- let parenWrapper = if hasTrailingParen
+    --       then appSep . docWrapNodeRest ltycl
+    --       else id
+    let wrapNodeRest = docWrapNodeRest ltycl
+    docWrapNodePrior ltycl
+      $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ
+  _ -> briDocByExactNoComment ltycl
+
+layoutSynDecl
+  :: Bool
+  -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
+  -> Located (IdP GhcPs)
+  -> [LHsTyVarBndr GhcPs]
+  -> LHsType GhcPs
+  -> ToBriDocM BriDocNumbered
+layoutSynDecl isInfix wrapNodeRest name vars typ = do
+  nameStr <- lrdrNameToTextAnn name
+  let
+    lhs = appSep . wrapNodeRest $ if isInfix
+      then do
+        let (a : b : rest) = vars
+        hasOwnParens <- hasAnnKeywordComment a AnnOpenP
+        -- This isn't quite right, but does give syntactically valid results
+        let needsParens = not $ null rest || hasOwnParens
+        docSeq
+          $  [ docLit $ Text.pack "type"
+             , docSeparator
+             ]
+          ++ [ docParenL | needsParens ]
+          ++ [ layoutTyVarBndr False a
+             , docSeparator
+             , docLit nameStr
+             , docSeparator
+             , layoutTyVarBndr False b
+             ]
+          ++ [ docParenR | needsParens ]
+          ++ fmap (layoutTyVarBndr True) rest
+      else
+        docSeq
+        $  [ docLit $ Text.pack "type"
+           , docSeparator
+           , docWrapNode name $ docLit nameStr
+           ]
+        ++ fmap (layoutTyVarBndr True) vars
+  sharedLhs   <- docSharedWrapper id lhs
+  typeDoc     <- docSharedWrapper layoutType typ
+  hasComments <- hasAnyCommentsConnected typ
+  runFilteredAlternative $ do
+    addAlternativeCond (not hasComments) $ docSeq
+      [sharedLhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc]
+    addAlternative $ docAddBaseY BrIndentRegular $ docPar
+      sharedLhs
+      (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc])
+
+layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr
+layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
+  docWrapNodePrior lbndr $ case bndr of
+    UserTyVar name -> do
+      nameStr <- lrdrNameToTextAnn name
+      docSeq $ [docSeparator | needsSep] ++ [docLit nameStr]
+    KindedTyVar name kind -> do
+      nameStr <- lrdrNameToTextAnn name
+      docSeq
+        $  [ docSeparator | needsSep ]
+        ++ [ 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