Merge pull request #189 from ruhatch/type-synonyms

Add type synonym formatting
2018-11-04 18:05:29 +01:00 · 2018-11-04 18:05:29 +01:00 · 268cd333f3
parent d769f30c15 ad5868eb76
commit 268cd333f3
6 changed files with 266 additions and 21 deletions
--- a/src-literatetests/10-tests.blt
+++ b/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)
+
+
 ###############################################################################
 ###############################################################################
 ###############################################################################
--- a/src/Language/Haskell/Brittany/Internal/Backend.hs
+++ b/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
--- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs
+++ b/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)
-      then Just $ case _lstate_curYOrAddNewline state of
-        Left{}  -> if y == 0 then x else _lstate_indLevelLinger state + x
-        Right{} -> _lstate_indLevelLinger state + x
-      else Just $ if y == 0 then x else _lstate_indLevelLinger state + x
-    , _lstate_commentCol       = Just $ case _lstate_commentCol state of
-      Just existing -> existing
-      Nothing       -> case _lstate_curYOrAddNewline state of
-        Left i  -> i + fromMaybe 0 (_lstate_addSepSpace state)
-        Right{} -> lstate_baseY state
+    , _lstate_addSepSpace      =
+      Just $ if Data.Maybe.isJust (_lstate_commentCol state)
+        then case _lstate_curYOrAddNewline state of
+          Left{}  -> if y == 0 then x else _lstate_indLevelLinger state + x
+          Right{} -> _lstate_indLevelLinger state + x
+        else if y == 0 then x else _lstate_indLevelLinger state + x
+    , _lstate_commentCol       =
+      Just $ case _lstate_commentCol state of
+        Just existing -> existing
+        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
--- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/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
-  anns <- mAsk
-  let hasK (ExactPrint.Types.G x, _) = x == annKeyword
-      hasK _                         = False
-  pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
-    Nothing -> False
-    Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
+hasAnnKeyword ast annKeyword = astAnn ast <&> \case
+  Nothing -> False
+  Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
+ where
+  hasK (ExactPrint.Types.G x, _) = x == annKeyword
+  hasK _                         = False
+
+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

--- 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,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
--- 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