Introduce nicer style for records (#266)

maksbotan · web-flow · commit b8a731eb948b · 2020-02-17T19:32:01.000+01:00
diff --git a/README.markdown b/README.markdown
@@ -33,6 +33,7 @@ You can also install it using your package manager:
 - Replaces tabs by four spaces (turned off by default)
 - Replaces some ASCII sequences by their Unicode equivalents (turned off by
   default)
+- Format data constructors and fields in records.
 
 Feature requests are welcome! Use the [issue tracker] for that.
 
@@ -102,6 +103,61 @@ Use `stylish-haskell --defaults > .stylish-haskell.yaml` to dump a
 well-documented default configuration to a file, this way you can get started
 quickly.
 
+## Record formatting
+
+Basically, stylish-haskell supports 4 different styles of records, controlled by `records`
+in the config file.
+
+Here's an example of all four styles:
+
+```haskell
+-- equals: "indent 2", "first_field": "indent 2"
+data Foo a
+  = Foo
+      { a :: Int
+      , a2 :: String
+        -- ^ some haddock
+      }
+  | Bar
+      { b :: a
+      }
+  deriving (Eq, Show)
+  deriving (ToJSON) via Bar Foo
+
+-- equals: "same_line", "first_field": "indent 2"
+data Foo a = Foo
+               { a :: Int
+               , a2 :: String
+                 -- ^ some haddock
+               }
+           | Bar
+               { b :: a
+               }
+  deriving (Eq, Show)
+  deriving (ToJSON) via Bar Foo
+
+-- equals: "same_line", "first_field": "same_line"
+data Foo a = Foo { a :: Int
+                 , a2 :: String
+                   -- ^ some haddock
+                 }
+           | Bar { b :: a
+                 }
+  deriving (Eq, Show)
+  deriving (ToJSON) via Bar Foo
+
+-- equals: "indent 2", first_field: "same_line"
+data Foo a
+  = Foo { a :: Int
+        , a2 :: String
+          -- ^ some haddock
+        }
+  | Bar { b :: a
+        }
+  deriving (Eq, Show)
+  deriving (ToJSON) via Bar Foo
+```
+
 ## VIM integration
 
 Since it works as a filter it is pretty easy to integrate this with VIM.
diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml
@@ -15,8 +15,33 @@ steps:
   #     # true.
   #     add_language_pragma: true
 
-  # Format record definitions
-  - records: {}
+  # Format record definitions. This is disabled by default.
+  #
+  # You can control the layout of record fields. The only rules that can't be configured
+  # are these:
+  #
+  # - "|" is always aligned with "="
+  # - "," in fields is always aligned with "{"
+  # - "}" is likewise always aligned with "{"
+  #
+  # - records:
+  #     # How to format equals sign between type constructor and data constructor.
+  #     # Possible values:
+  #     # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor.
+  #     # - "indent N" -- insert a new line and N spaces from the beginning of the next line.
+  #     equals: "indent 2"
+  #
+  #     # How to format first field of each record constructor.
+  #     # Possible values:
+  #     # - "same_line" -- "{" and first field goes on the same line as the data constructor.
+  #     # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor
+  #     first_field: "indent 2"
+  #
+  #     # How many spaces to insert between the column with "," and the beginning of the comment in the next line.
+  #     field_comment: 2
+  #
+  #     # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.
+  #     deriving: 2
 
   # Align the right hand side of some elements.  This is quite conservative
   # and only applies to statements where each element occupies a single
@@ -225,9 +250,6 @@ steps:
   # simple_align but is a bit less conservative.
   # - squash: {}
 
-# A common indentation setting. Different steps take this into account.
-indent: 4
-
 # A common setting is the number of columns (parts of) code will be wrapped
 # to. Different steps take this into account.
 #
diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs
@@ -24,12 +24,14 @@ import           Data.List                                        (intercalate,
 import           Data.Map                                         (Map)
 import qualified Data.Map                                         as M
 import           Data.Maybe                                       (fromMaybe)
+import qualified Data.Text                                        as T
 import           Data.YAML                                        (prettyPosWithSource)
 import           Data.YAML.Aeson                                  (decode1Strict)
 import           System.Directory
 import           System.FilePath                                  ((</>))
 import qualified System.IO                                        as IO (Newline (..),
                                                                          nativeNewline)
+import           Text.Read                                        (readMaybe)
 
 
 --------------------------------------------------------------------------------
@@ -54,7 +56,6 @@ type Extensions = [String]
 --------------------------------------------------------------------------------
 data Config = Config
     { configSteps              :: [Step]
-    , configIndent             :: Int
     , configColumns            :: Maybe Int
     , configLanguageExtensions :: [String]
     , configNewline            :: IO.Newline
@@ -121,7 +122,6 @@ parseConfig (A.Object o) = do
     -- First load the config without the actual steps
     config <- Config
         <$> pure []
-        <*> (o A..:? "indent"              A..!= 4)
         <*> (o A..:! "columns"             A..!= Just 80)
         <*> (o A..:? "language_extensions" A..!= [])
         <*> (o A..:? "newline"             >>= parseEnum newlines IO.nativeNewline)
@@ -186,8 +186,25 @@ parseSimpleAlign c o = SimpleAlign.step
 
 --------------------------------------------------------------------------------
 parseRecords :: Config -> A.Object -> A.Parser Step
-parseRecords c _ = Data.step
-    <$> pure (configIndent c)
+parseRecords _ o = Data.step
+    <$> (Data.Config
+        <$> (o A..: "equals" >>= parseIndent)
+        <*> (o A..: "first_field" >>= parseIndent)
+        <*> (o A..: "field_comment")
+        <*> (o A..: "deriving"))
+
+
+parseIndent :: A.Value -> A.Parser Data.Indent
+parseIndent = A.withText "Indent" $ \t ->
+  if t == "same_line"
+     then return Data.SameLine
+     else
+         if "indent " `T.isPrefixOf` t
+             then
+                 case readMaybe (T.unpack $ T.drop 7 t) of
+                     Just n -> return $ Data.Indent n
+                     Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t)
+             else fail $ "can't parse indent setting: " <> T.unpack t
 
 
 --------------------------------------------------------------------------------
diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs
@@ -1,7 +1,9 @@
+{-# LANGUAGE RecordWildCards #-}
+
 module Language.Haskell.Stylish.Step.Data where
 
 import           Data.List                       (find, intercalate)
-import           Data.Maybe                      (maybeToList)
+import           Data.Maybe                      (fromMaybe, maybeToList)
 import qualified Language.Haskell.Exts           as H
 import           Language.Haskell.Exts.Comments
 import           Language.Haskell.Stylish.Block
@@ -10,20 +12,36 @@ import           Language.Haskell.Stylish.Step
 import           Language.Haskell.Stylish.Util
 import           Prelude                         hiding (init)
 
+data Indent
+    = SameLine
+    | Indent !Int
+  deriving (Show)
+
+data Config = Config
+    { cEquals           :: !Indent
+      -- ^ Indent between type constructor and @=@ sign (measured from column 0)
+    , cFirstField       :: !Indent
+      -- ^ Indent between data constructor and @{@ line (measured from column with data constructor name)
+    , cFieldComment     :: !Int
+      -- ^ Indent between column with @{@ and start of field line comment (this line has @cFieldComment = 2@)
+    , cDeriving         :: !Int
+      -- ^ Indent before @deriving@ lines (measured from column 0)
+    } deriving (Show)
+
 datas :: H.Module l -> [H.Decl l]
 datas (H.Module _ _ _ _ decls) = decls
 datas _                        = []
 
 type ChangeLine = Change String
 
-step :: Int -> Step
-step indentSize = makeStep "Data" (step' indentSize)
+step :: Config -> Step
+step cfg = makeStep "Data" (step' cfg)
 
-step' :: Int -> Lines -> Module -> Lines
-step' indentSize ls (module', allComments) = applyChanges changes ls
+step' :: Config -> Lines -> Module -> Lines
+step' cfg ls (module', allComments) = applyChanges changes ls
   where
     datas' = datas $ fmap linesFromSrcSpan module'
-    changes = datas' >>= maybeToList . changeDecl allComments indentSize
+    changes = datas' >>= maybeToList . changeDecl allComments cfg
 
 findCommentOnLine :: LineBlock -> [Comment] -> Maybe Comment
 findCommentOnLine lb = find commentOnLine
@@ -43,9 +61,9 @@ commentsWithin lb = filter within
     within (Comment _ (H.SrcSpan _ start _ end _) _) =
       start >= blockStart lb && end <= blockEnd lb
 
-changeDecl :: [Comment] -> Int -> H.Decl LineBlock -> Maybe ChangeLine
+changeDecl :: [Comment] -> Config -> H.Decl LineBlock -> Maybe ChangeLine
 changeDecl _ _ (H.DataDecl _ (H.DataType _) Nothing _ [] _) = Nothing
-changeDecl allComments indentSize (H.DataDecl block (H.DataType _) Nothing dhead decls derivings)
+changeDecl allComments cfg@Config{..} (H.DataDecl block (H.DataType _) Nothing dhead decls derivings)
   | hasRecordFields = Just $ change block (const $ concat newLines)
   | otherwise       = Nothing
   where
@@ -54,27 +72,55 @@ changeDecl allComments indentSize (H.DataDecl block (H.DataType _) Nothing dhead
                   (H.QualConDecl _ _ _ (H.RecDecl {})) -> True
                   _ -> False)
       decls
-    newLines = fmap constructors zipped ++ [fmap (indented . H.prettyPrint) derivings]
+
+    typeConstructor = "data " <> H.prettyPrint dhead
+
+    -- In any case set @pipeIndent@ such that @|@ is aligned with @=@.
+    (firstLine, firstLineInit, pipeIndent) =
+      case cEquals of
+        SameLine -> (Nothing, typeConstructor <> " = ", length typeConstructor + 1)
+        Indent n -> (Just [[typeConstructor]], indent n "= ", n)
+
+    newLines = fromMaybe [] firstLine ++ fmap constructors zipped <> [fmap (indent cDeriving . H.prettyPrint) derivings]
     zipped = zip decls ([1..] ::[Int])
-    constructors (decl, 1) = processConstructor allComments typeConstructor indentSize decl
-    constructors (decl, _) = processConstructor allComments (indented "| ") indentSize decl
-    typeConstructor = "data " <> H.prettyPrint dhead <> " = "
-    indented = indent indentSize
+
+    constructors (decl, 1) = processConstructor allComments firstLineInit cfg decl
+    constructors (decl, _) = processConstructor allComments (indent pipeIndent "| ") cfg decl
 changeDecl _ _ _ = Nothing
 
-processConstructor :: [Comment] -> String -> Int -> H.QualConDecl LineBlock -> [String]
-processConstructor allComments init indentSize (H.QualConDecl _ _ _ (H.RecDecl _ dname fields)) = do
-  init <> H.prettyPrint dname : n1 ++ ns ++ [indented "}"]
+processConstructor :: [Comment] -> String -> Config -> H.QualConDecl LineBlock -> [String]
+processConstructor allComments init Config{..} (H.QualConDecl _ _ _ (H.RecDecl _ dname (f:fs))) = do
+  fromMaybe [] firstLine <> n1 <> ns <> [indent fieldIndent "}"]
   where
-    n1 = processName "{ " ( extractField $ head fields)
-    ns = tail fields >>= (processName ", " . extractField)
+    n1 = processName firstLinePrefix (extractField f)
+    ns = fs >>= processName (indent fieldIndent ", ") . extractField
+
+    -- Set @fieldIndent@ such that @,@ is aligned with @{@.
+    (firstLine, firstLinePrefix, fieldIndent) =
+      case cFirstField of
+        SameLine ->
+          ( Nothing
+          , init <> H.prettyPrint dname <> " { "
+          , length init + length (H.prettyPrint dname) + 1
+          )
+        Indent n ->
+          ( Just [init <> H.prettyPrint dname]
+          , indent (length init + n) "{ "
+          , length init + n
+          )
+
     processName prefix (fnames, _type, lineComment, commentBelowLine) =
-      [indented prefix <> intercalate ", " (fmap H.prettyPrint fnames) <> " :: " <> H.prettyPrint _type <> addLineComment lineComment] ++ addCommentBelow commentBelowLine
+      [prefix <> intercalate ", " (fmap H.prettyPrint fnames) <> " :: " <> H.prettyPrint _type <> addLineComment lineComment
+      ] ++ addCommentBelow commentBelowLine
+
     addLineComment (Just (Comment _ _ c)) = " --" <> c
     addLineComment Nothing                = ""
+
+    -- Field comment indent is measured from the column with @{@, hence adding of @fieldIndent@ here.
     addCommentBelow Nothing                = []
-    addCommentBelow (Just (Comment _ _ c)) = [indented "--" <> c]
+    addCommentBelow (Just (Comment _ _ c)) = [indent (fieldIndent + cFieldComment) "--" <> c]
+
     extractField (H.FieldDecl lb names _type) =
       (names, _type, findCommentOnLine lb allComments, findCommentBelowLine lb allComments)
-    indented = indent indentSize
+
 processConstructor _ init _ decl = [init <> trimLeft (H.prettyPrint decl)]
diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal
@@ -64,6 +64,7 @@ Library
     mtl              >= 2.0    && < 2.3,
     semigroups       >= 0.18   && < 0.20,
     syb              >= 0.3    && < 0.8,
+    text             >= 1.2    && < 1.3,
     HsYAML-aeson     >=0.2.0   && < 0.3,
     HsYAML           >=0.2.0   && < 0.3
 
@@ -148,6 +149,7 @@ Test-suite stylish-haskell-tests
     haskell-src-exts >= 1.18   && < 1.24,
     mtl              >= 2.0    && < 2.3,
     syb              >= 0.3    && < 0.8,
+    text             >= 1.2    && < 1.3,
     HsYAML-aeson     >=0.2.0   && < 0.3,
     HsYAML           >=0.2.0   && < 0.3
 
diff --git a/tests/Language/Haskell/Stylish/Config/Tests.hs b/tests/Language/Haskell/Stylish/Config/Tests.hs
@@ -148,8 +148,11 @@ dotStylish = unlines $
   , "      align: false"
   , "      remove_redundant: true"
   , "  - trailing_whitespace: {}"
-  , "  - records: {}"
-  , "indent: 2"
+  , "  - records:"
+  , "      equals: \"same_line\""
+  , "      first_field: \"indent 2\""
+  , "      field_comment: 2"
+  , "      deriving: 4"
   , "columns: 110"
   , "language_extensions:"
   , "  - TemplateHaskell"
diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs
diff --git a/tests/Language/Haskell/Stylish/Tests.hs b/tests/Language/Haskell/Stylish/Tests.hs
