Merge pull request #222 from tchajed/stack-13.14-compat

.gitignore

@@ -12,3 +12,4 @@ local/
 cabal.sandbox.config
 cabal.project.local
 .ghc.environment.*
+result

README.md

@@ -94,6 +94,12 @@ log the size of the input, but _not_ the full input/output of requests.)
     aura -A brittany
     ~~~~
 
+- via `nix`:
+    ~~~.sh
+    nix build -f release.nix     # or 'nix-build -f release.nix'
+    nix-env -i ./result
+    ~~~
+
 # Editor Integration
 
 #### Sublime text
@@ -111,6 +117,8 @@ log the size of the input, but _not_ the full input/output of requests.)
   brittany built in.
 #### Atom
   [Atom Beautify](https://atom.io/packages/atom-beautify) supports brittany as a formatter for Haskell. Since the default formatter is set to hindent, you will need to change this setting to brittany, after installing the extension.
+#### Emacs
+  [format-all](https://github.com/lassik/emacs-format-all-the-code) support brittany as the default formatter for Haskell.
 
 # Usage
 

brittany.cabal

@@ -86,7 +86,7 @@ library {
     { base >=4.9 && <4.13
     , ghc >=8.0.1 && <8.7
     , ghc-paths >=0.1.0.9 && <0.2
-    , ghc-exactprint >=0.5.8 && <0.7
+    , ghc-exactprint >=0.5.8 && <0.6.2
     , transformers >=0.5.2.0 && <0.6
     , containers >=0.5.7.1 && <0.7
     , mtl >=2.2.1 && <2.3

default.nix

@@ -0,0 +1,38 @@
+{ mkDerivation, aeson, base, butcher, bytestring, cmdargs
+, containers, czipwith, data-tree-print, deepseq, directory, extra
+, filepath, ghc, ghc-boot-th, ghc-exactprint, ghc-paths, hspec
+, monad-memo, mtl, multistate, neat-interpolation, parsec, pretty
+, random, safe, semigroups, stdenv, strict, syb, text, transformers
+, uniplate, unsafe, yaml
+}:
+mkDerivation {
+  pname = "brittany";
+  version = "0.11.0.0";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [
+    aeson base butcher bytestring cmdargs containers czipwith
+    data-tree-print deepseq directory extra filepath ghc ghc-boot-th
+    ghc-exactprint ghc-paths monad-memo mtl multistate
+    neat-interpolation pretty random safe semigroups strict syb text
+    transformers uniplate unsafe yaml
+  ];
+  executableHaskellDepends = [
+    aeson base butcher bytestring cmdargs containers czipwith
+    data-tree-print deepseq directory extra filepath ghc ghc-boot-th
+    ghc-exactprint ghc-paths monad-memo mtl multistate
+    neat-interpolation pretty safe semigroups strict syb text
+    transformers uniplate unsafe yaml
+  ];
+  testHaskellDepends = [
+    aeson base butcher bytestring cmdargs containers czipwith
+    data-tree-print deepseq directory extra filepath ghc ghc-boot-th
+    ghc-exactprint ghc-paths hspec monad-memo mtl multistate
+    neat-interpolation parsec pretty safe semigroups strict syb text
+    transformers uniplate unsafe yaml
+  ];
+  homepage = "https://github.com/lspitzner/brittany/";
+  description = "Haskell source code formatter";
+  license = stdenv.lib.licenses.agpl3;
+}

pkgs.nix

@@ -0,0 +1,5 @@
+{
+  url = "https://github.com/nixos/nixpkgs.git";
+  ref = "release-18.09";
+  rev = "b9fa31cea0e119ecf1867af4944ddc2f7633aacd";
+}

release.nix

@@ -0,0 +1,5 @@
+{ pkgs ? import (fetchGit (import ./pkgs.nix)) {}
+, compiler ? "ghc822"
+}:
+
+pkgs.haskell.packages.${compiler}.callPackage ./shell.nix {}

shell.nix

@@ -0,0 +1,13 @@
+{ pkgs ? import (fetchGit (import ./pkgs.nix)) {}
+, compiler ? "ghc822"
+}:
+
+pkgs.haskell.packages.${compiler}.developPackage {
+  root = ./.;
+  name = "brittany";
+  overrides = with pkgs.haskell.lib; self: super: {
+  };
+  source-overrides = {
+    ghc-exactprint = "0.5.8.0";
+  };
+}

src-literatetests/10-tests.blt

@@ -531,6 +531,45 @@ func = if cond
     -- test
     abc
 
+#test nonempty-case-short
+func = case x of
+  False -> False
+  True  -> True
+
+#test nonempty-case-long
+func =
+  case
+      lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+        lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+    of
+      False -> False
+      True  -> True
+
+#test nonempty-case-long-do
+func = do
+  case
+      lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+        lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+    of
+      False -> False
+      True  -> True
+
+#test empty-case-short
+func = case x of {}
+
+#test empty-case-long
+func =
+  case
+      lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+        lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+    of {}
+
+#test empty-case-long-do
+func = do
+  case
+      lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+        lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+    of {}
 
 ###############################################################################
 ###############################################################################
@@ -1155,3 +1194,44 @@ func = do
 
   other :: Other
   other = True
+
+
+###############################################################################
+###############################################################################
+###############################################################################
+#group typefam.instance
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test simple-typefam-instance
+
+type instance MyFam Bool = String
+
+#test simple-typefam-instance-param-type
+
+type instance MyFam (Maybe a) = a -> Bool
+
+#test simple-typefam-instance-parens
+
+type instance (MyFam (String -> Int)) = String
+
+#test simple-typefam-instance-overflow
+
+type instance MyFam ALongishType
+  =  AMuchLongerTypeThanThat
+  -> AnEvenLongerTypeThanTheLastOne
+  -> ShouldDefinitelyOverflow
+
+#test simple-typefam-instance-comments
+
+-- | A happy family
+type instance MyFam Bool -- This is an odd one
+  = AnotherType -- Here's another
+
+#test simple-typefam-instance-parens-comment
+
+-- | A happy family
+type instance (MyFam Bool) -- This is an odd one
+  = -- Here's another
+    AnotherType

src-literatetests/15-regressions.blt

@@ -650,3 +650,13 @@ jaicyhHumzo btrKpeyiFej mava = do
             )
           Xcde{} -> (s, Pioemav)
       pure imomue
+
+#test issue 214
+-- brittany { lconfig_indentPolicy: IndentPolicyMultiple }
+foo = bar
+  arg1 -- this is the first argument
+  arg2 -- this is the second argument
+  arg3 -- this is the third argument, now I'll skip one comment
+  arg4
+  arg5 -- this is the fifth argument
+  arg6 -- this is the sixth argument

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

@@ -9,6 +9,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
   , askIndent
   , extractAllComments
+  , extractRestComments
   , filterAnns
   , docEmpty
   , docLit
@@ -64,6 +65,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , hasAnyCommentsBelow
   , hasAnyCommentsConnected
   , hasAnyCommentsPrior
+  , hasAnyRegularCommentsConnected
+  , hasAnyRegularCommentsRest
   , hasAnnKeywordComment
   , hasAnnKeyword
   )
@@ -263,9 +266,13 @@ askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
 extractAllComments
   :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
 extractAllComments ann =
-  ExactPrint.annPriorComments ann
+  ExactPrint.annPriorComments ann ++ extractRestComments ann
-    ++ ExactPrint.annFollowingComments ann
+
-    ++ ( ExactPrint.annsDP ann >>= \case
+extractRestComments
+  :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
+extractRestComments ann =
+  ExactPrint.annFollowingComments ann
+    ++ (ExactPrint.annsDP ann >>= \case
          (ExactPrint.AnnComment com, dp) -> [(com, dp)]
          _                               -> []
        )
@@ -278,31 +285,51 @@ filterAnns ast =
 -- a) connected to any node below (in AST sense) the given node AND
 -- b) after (in source code order) the node.
 hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyCommentsBelow ast@(L l _) = do
+hasAnyCommentsBelow ast@(L l _) =
-  anns <- filterAnns ast <$> mAsk
+  List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
-  return
+    <$> astConnectedComments ast
-    $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
-    $ (=<<) extractAllComments
-    $ Map.elems
-    $ anns
 
--- | True if there are any comments that are
+-- | True if there are any comments that are connected to any node below (in AST
--- connected to any node below (in AST sense) the given node
+--   sense) the given node
 hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyCommentsConnected ast = do
+hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
+
+-- | True if there are any regular comments connected to any node below (in AST
+--   sense) the given node
+hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyRegularCommentsConnected ast =
+  any isRegularComment <$> astConnectedComments ast
+
+-- | Regular comments are comments that are actually "source code comments",
+-- i.e. things that start with "--" or "{-". In contrast to comment-annotations
+-- used by ghc-exactprint for capturing symbols (and their exact positioning).
+--
+-- Only the type instance layouter makes use of this filter currently, but
+-- it might make sense to apply it more aggressively or make it the default -
+-- I believe that most of the time we branch on the existence of comments, we
+-- only care about "regular" comments. We simply did not need the distinction
+-- because "irregular" comments are not that common outside of type/data decls.
+isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
+isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
+
+astConnectedComments
+  :: Data ast
+  => GHC.Located ast
+  -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)]
+astConnectedComments ast = do
   anns <- filterAnns ast <$> mAsk
-  return
+  pure $ extractAllComments =<< Map.elems anns
-    $ not
-    $ null
-    $ (=<<) extractAllComments
-    $ 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
 
+hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyRegularCommentsRest ast = astAnn ast <&> \case
+  Nothing -> False
+  Just ann -> any isRegularComment (extractRestComments ann)
+
 hasAnnKeywordComment
   :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
 hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case

src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs

@@ -33,6 +33,9 @@ import           GHC                            ( runGhc
                                                 )
 import           SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc )
 import           HsSyn
+#if MIN_VERSION_ghc(8,6,0)
+import           HsExtension (NoExt (..))
+#endif
 import           Name
 import           BasicTypes ( InlinePragma(..)
                             , Activation(..)
@@ -62,7 +65,8 @@ layoutDecl d@(L loc decl) = case decl of
     Left  ns -> docLines $ return <$> ns
     Right n  -> return n
   TyClD _ tycl           -> withTransformedAnns d $ layoutTyCl (L loc tycl)
-  InstD _ (TyFamInstD{}) -> layoutTyFamInstDWorkaround d
+  InstD _ (TyFamInstD _ tfid) ->
+    withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid)
   InstD _ (ClsInstD _ inst) ->
     withTransformedAnns d $ layoutClsInst (L loc inst)
   _ -> briDocByExactNoComment d
@@ -73,25 +77,12 @@ layoutDecl d@(L loc decl) = case decl of
     Left  ns -> docLines $ return <$> ns
     Right n  -> return n
   TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl)
-  InstD (TyFamInstD{}) -> layoutTyFamInstDWorkaround d
+  InstD (TyFamInstD tfid) ->
+    withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid)
   InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst)
   _                    -> briDocByExactNoComment d
 #endif
 
-layoutTyFamInstDWorkaround :: ToBriDoc HsDecl
-layoutTyFamInstDWorkaround d = do
-  -- this is a (temporary (..)) workaround for "type instance" decls
-  -- that do not round-trip through exactprint properly.
-  let fixer s = case List.stripPrefix "type " s of
-        Just rest | not ("instance" `isPrefixOf` rest) ->
-          "type instance " ++ rest
-        _ -> s
-  str <- mAsk <&> \anns ->
-    intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns
-  allocateNode $ BDFExternal (ExactPrint.mkAnnKey d)
-                             (foldedAnnKeys d)
-                             False
-                             (Text.pack str)
 
 --------------------------------------------------------------------------------
 -- Sig
@@ -156,24 +147,11 @@ layoutSig lsig@(L _loc sig) = case sig of
             ]
           ]
         ]
-      else
+      else layoutLhsAndType
-        docAlt
+        hasComments
-          $  [ docSeq
+        (appSep . docWrapNodeRest lsig $ docLit nameStr)
-               [ appSep $ docWrapNodeRest lsig $ docLit nameStr
+        "::"
-               , appSep $ docLit $ Text.pack "::"
+        typeDoc
-               , docForceSingleline typeDoc
-               ]
-             | not hasComments
-             ]
-          ++ [ docAddBaseY BrIndentRegular $ docPar
-               (docWrapNodeRest lsig $ docLit nameStr)
-               ( docCols
-                 ColTyOpPrefix
-                 [ docLit $ Text.pack ":: "
-                 , docAddBaseY (BrIndentSpecial 3) $ typeDoc
-                 ]
-               )
-             ]
 
 specStringCompat
   :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String
@@ -754,12 +732,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
   sharedLhs   <- docSharedWrapper id lhs
   typeDoc     <- docSharedWrapper layoutType typ
   hasComments <- hasAnyCommentsConnected typ
-  runFilteredAlternative $ do
+  layoutLhsAndType hasComments sharedLhs "=" typeDoc
-    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
@@ -788,6 +761,55 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
            ]
 
 
+--------------------------------------------------------------------------------
+-- TyFamInstDecl
+--------------------------------------------------------------------------------
+
+layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl
+layoutTyFamInstDecl inClass (L loc tfid) = do
+  let
+#if MIN_VERSION_ghc(8,6,0)
+    linst = L loc (TyFamInstD NoExt tfid)
+    feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid
+    lfeqn = L loc feqn
+#elif MIN_VERSION_ghc(8,4,0)
+    linst = L loc (TyFamInstD tfid)
+    feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid
+    lfeqn = L loc feqn
+#elif MIN_VERSION_ghc(8,2,0)
+    linst = L loc (TyFamInstD tfid)
+    lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid
+    pats = hsib_body boundPats
+#else
+    linst = L loc (TyFamInstD tfid)
+    lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid
+    pats = hsib_body boundPats
+#endif
+  docWrapNodePrior linst $ do
+    nameStr   <- lrdrNameToTextAnn name
+    needsParens <- hasAnnKeyword lfeqn AnnOpenP
+    let
+      instanceDoc = if inClass
+        then docLit $ Text.pack "type"
+        else docSeq
+          [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"]
+      lhs =
+        docWrapNode lfeqn
+          .  appSep
+          .  docWrapNodeRest linst
+          .  docSeq
+          $  (appSep instanceDoc :)
+          $  [ docParenL | needsParens ]
+          ++ [appSep $ docWrapNode name $ docLit nameStr]
+          ++ intersperse docSeparator (layoutType <$> pats)
+          ++ [ docParenR | needsParens ]
+    hasComments <- (||)
+      <$> hasAnyRegularCommentsConnected lfeqn
+      <*> hasAnyRegularCommentsRest linst
+    typeDoc <- docSharedWrapper layoutType typ
+    layoutLhsAndType hasComments lhs "=" typeDoc
+
+
 --------------------------------------------------------------------------------
 -- ClsInstDecl
 --------------------------------------------------------------------------------
@@ -855,12 +877,7 @@ layoutClsInst lcid@(L _ cid) = docLines
   layoutAndLocateTyFamInsts
     :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered)
   layoutAndLocateTyFamInsts ltfid@(L loc _) =
-    L loc <$> layoutTyFamInstDecl ltfid
+    L loc <$> layoutTyFamInstDecl True ltfid
-
-  -- | Send to ExactPrint then remove unecessary whitespace
-  layoutTyFamInstDecl :: ToBriDoc TyFamInstDecl
-  layoutTyFamInstDecl ltfid =
-    fmap stripWhitespace <$> briDocByExactNoComment ltfid
 
   layoutAndLocateDataFamInsts
     :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered)
@@ -928,3 +945,32 @@ layoutClsInst lcid@(L _ cid) = docLines
     isTypeOrData t' =
       (Text.pack "type" `Text.isPrefixOf` t')
         || (Text.pack "data" `Text.isPrefixOf` t')
+
+
+--------------------------------------------------------------------------------
+-- Common Helpers
+--------------------------------------------------------------------------------
+
+layoutLhsAndType
+  :: Bool
+  -> ToBriDocM BriDocNumbered
+  -> String
+  -> ToBriDocM BriDocNumbered
+  -> ToBriDocM BriDocNumbered
+layoutLhsAndType hasComments lhs sep typeDoc = do
+  let sepDoc = appSep . docLit $ Text.pack sep
+  runFilteredAlternative $ do
+    -- (separators probably are "=" or "::")
+    -- lhs = type
+    -- lhs :: type
+    addAlternativeCond (not hasComments)
+      $ docSeq [lhs, sepDoc, docForceSingleline typeDoc]
+    -- lhs
+    --   :: typeA
+    --   -> typeB
+    -- lhs
+    --   =  typeA
+    --   -> typeB
+    addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols
+      ColTyOpPrefix
+      [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc]

src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs

@@ -136,6 +136,17 @@ layoutExpr lexpr@(L _ expr) = do
 #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
     HsLamCase _ XMatchGroup{} ->
       error "brittany internal error: HsLamCase XMatchGroup"
+#endif
+#if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
+    HsLamCase _ (MG _ (L _ []) _) -> do
+#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/
+    HsLamCase (MG (L _ []) _ _ _) -> do
+#else                        /* ghc-8.0 */
+    HsLamCase _ (MG (L _ []) _ _ _) -> do
+#endif
+      docSetParSpacing $ docAddBaseY BrIndentRegular $
+        (docLit $ Text.pack "\\case {}")
+#if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
     HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do
 #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4*/
     HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do
@@ -172,9 +183,10 @@ layoutExpr lexpr@(L _ expr) = do
             _ -> docSeq
       headDoc <- docSharedWrapper layoutExpr headE
       paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs
+      hasComments <- hasAnyCommentsConnected exp2
       runFilteredAlternative $ do
         -- foo x y
-        addAlternative
+        addAlternativeCond (not hasComments)
           $ colsOrSequence
           $ appSep (docForceSingleline headDoc)
           : spacifyDocs (docForceSingleline <$> paramDocs)
@@ -520,6 +532,27 @@ layoutExpr lexpr@(L _ expr) = do
 #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
     HsCase _ _ XMatchGroup{} ->
       error "brittany internal error: HsCase XMatchGroup"
+#endif
+#if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
+    HsCase _ cExp (MG _ (L _ []) _) -> do
+#else
+    HsCase cExp (MG (L _ []) _ _ _) -> do
+#endif
+      cExpDoc <- docSharedWrapper layoutExpr cExp
+      docAlt
+        [ docAddBaseY BrIndentRegular
+        $ docSeq
+            [ appSep $ docLit $ Text.pack "case"
+            , appSep $ docForceSingleline cExpDoc
+            , docLit $ Text.pack "of {}"
+            ]
+        , docPar
+            ( docAddBaseY BrIndentRegular
+            $ docPar (docLit $ Text.pack "case") cExpDoc
+            )
+            (docLit $ Text.pack "of {}")
+        ]
+#if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
     HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do
 #else
     HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do