Add --strict mode

main/Main.hs

@@ -12,6 +12,7 @@ import qualified Data.Text.IO as TextIO (getContents, hPutStr, putStr)
 import Data.Version (showVersion)
 import GHC.IO.Encoding (utf8)
 import qualified Nixfmt
+import Nixfmt.Predoc (layout)
 import Paths_nixfmt (version)
 import System.Console.CmdArgs (
   Data,
@@ -41,6 +42,7 @@ data Nixfmt = Nixfmt
     width :: Width,
     check :: Bool,
     quiet :: Bool,
+    strict :: Bool,
     verify :: Bool,
     ast :: Bool
   }
@@ -58,6 +60,7 @@ options =
             &= help (addDefaultHint defaultWidth "Maximum width in characters"),
         check = False &= help "Check whether files are formatted without modifying them",
         quiet = False &= help "Do not report errors",
+        strict = False &= help "Enable a stricter formatting mode that isn't influenced as much by how the input is formatted",
         verify =
           False
             &= help
@@ -134,8 +137,8 @@ type Formatter = FilePath -> Text -> Either String Text
 
 toFormatter :: Nixfmt -> Formatter
 toFormatter Nixfmt{ast = True} = Nixfmt.printAst
-toFormatter Nixfmt{width, verify = True} = Nixfmt.formatVerify width
-toFormatter Nixfmt{width, verify = False} = Nixfmt.format width
+toFormatter Nixfmt{width, verify = True, strict} = Nixfmt.formatVerify (layout width strict)
+toFormatter Nixfmt{width, verify = False, strict} = Nixfmt.format (layout width strict)
 
 type Operation = Formatter -> Target -> IO Result
 

src/Nixfmt.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+
 module Nixfmt (
   errorBundlePretty,
   ParseErrorBundle,
@@ -13,23 +15,24 @@ import Data.Either (fromRight)
 import Data.Text (Text, unpack)
 import Data.Text.Lazy (toStrict)
 import qualified Nixfmt.Parser as Parser
-import Nixfmt.Predoc (layout)
+import Nixfmt.Predoc (Pretty)
 import Nixfmt.Pretty ()
-import Nixfmt.Types (Expression, ParseErrorBundle, Whole (..), walkSubprograms)
+import Nixfmt.Types (Expression, LanguageElement, ParseErrorBundle, Whole (..), walkSubprograms)
 import qualified Text.Megaparsec as Megaparsec (parse)
 import Text.Megaparsec.Error (errorBundlePretty)
 import Text.Pretty.Simple (pShow)
 
 -- import Debug.Trace (traceShow, traceShowId)
 
 type Width = Int
+type Layouter = forall a. (Pretty a, LanguageElement a) => a -> Text
 
 -- | @format w filename source@ returns either a parsing error specifying a
 -- failure in @filename@ or a formatted version of @source@ with a maximum width
 -- of @w@ columns where possible.
-format :: Width -> FilePath -> Text -> Either String Text
-format width filename =
-  bimap errorBundlePretty (layout width)
+format :: Layouter -> FilePath -> Text -> Either String Text
+format layout filename =
+  bimap errorBundlePretty layout
     . Megaparsec.parse Parser.file filename
 
 -- | Pretty print the internal AST for debugging
@@ -44,34 +47,34 @@ printAst path unformatted = do
 --
 -- If any issues are found, the operation will fail and print an error message. It will contain a diff showcasing
 -- the issue on an automatically minimized example based on the input.
-formatVerify :: Width -> FilePath -> Text -> Either String Text
-formatVerify width path unformatted = do
+formatVerify :: Layouter -> FilePath -> Text -> Either String Text
+formatVerify layout path unformatted = do
   unformattedParsed@(Whole unformattedParsed' _) <- parse unformatted
-  let formattedOnce = layout width unformattedParsed
+  let formattedOnce = layout unformattedParsed
   formattedOnceParsed <- first (\x -> pleaseReport "Fails to parse after formatting.\n" <> x <> "\n\nAfter Formatting:\n" <> unpack formattedOnce) (parse formattedOnce)
-  let formattedTwice = layout width formattedOnceParsed
+  let formattedTwice = layout formattedOnceParsed
   if formattedOnceParsed /= unformattedParsed
     then
       Left $
-        let minimized = minimize unformattedParsed' (\e -> parse (layout width e) == Right (Whole e []))
+        let minimized = minimize unformattedParsed' (\e -> parse (layout e) == Right (Whole e []))
         in pleaseReport "Parses differently after formatting."
             <> "\n\nBefore formatting:\n"
             <> show minimized
             <> "\n\nAfter formatting:\n"
-            <> show (fromRight (error "TODO") $ parse (layout width minimized))
+            <> show (fromRight (error "TODO") $ parse (layout minimized))
     else
       if formattedOnce /= formattedTwice
         then
           Left $
             let minimized =
                   minimize
                     unformattedParsed'
-                    (\e -> layout width e == layout width (fromRight (error "TODO") $ parse $ layout width e))
+                    (\e -> layout e == layout (fromRight (error "TODO") $ parse $ layout e))
             in pleaseReport "Nixfmt is not idempotent."
                 <> "\n\nAfter one formatting:\n"
-                <> unpack (layout width minimized)
+                <> unpack (layout minimized)
                 <> "\n\nAfter two:\n"
-                <> unpack (layout width (fromRight (error "TODO") $ parse $ layout width minimized))
+                <> unpack (layout (fromRight (error "TODO") $ parse $ layout minimized))
         else Right formattedOnce
   where
     parse = first errorBundlePretty . Megaparsec.parse Parser.file path

src/Nixfmt/Predoc.hs

@@ -45,6 +45,11 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Data.Maybe (fromMaybe)
 import Data.Text as Text (Text, concat, length, replicate, strip)
 import GHC.Stack (HasCallStack)
+import Nixfmt.Types (
+  LanguageElement,
+  mapAllTokens,
+  removeLineInfo,
+ )
 
 -- | Sequential Spacings are reduced to a single Spacing by taking the maximum.
 -- This means that e.g. a Space followed by an Emptyline results in just an
@@ -342,8 +347,15 @@ mergeSpacings Hardspace (Newlines x) = Newlines x
 mergeSpacings _ (Newlines x) = Newlines (x + 1)
 mergeSpacings _ y = y
 
-layout :: (Pretty a) => Int -> a -> Text
-layout w = (<> "\n") . Text.strip . layoutGreedy w . fixup . pretty
+layout :: (Pretty a, LanguageElement a) => Int -> Bool -> a -> Text
+layout width strict =
+  (<> "\n")
+    . Text.strip
+    . layoutGreedy width
+    . fixup
+    . pretty
+    -- In strict mode, set the line number of all tokens to zero
+    . (if strict then mapAllTokens removeLineInfo else id)
 
 -- 1. Move and merge Spacings.
 -- 2. Convert Softlines to Grouped Lines and Hardspaces to Texts.

src/Nixfmt/Types.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -31,10 +32,13 @@ module Nixfmt.Types (
   Whole (..),
   TrailingComment (..),
   Trivium (..),
+  removeLineInfo,
   hasTrivia,
+  LanguageElement,
   mapFirstToken,
   mapFirstToken',
   mapLastToken',
+  mapAllTokens,
   operators,
   tokenText,
   walkSubprograms,
@@ -49,7 +53,7 @@ import Data.Maybe (maybeToList)
 import Data.Text (Text, pack)
 import Data.Void (Void)
 import Text.Megaparsec (Pos)
-import qualified Text.Megaparsec as MP (ParseErrorBundle, Parsec)
+import qualified Text.Megaparsec as MP (ParseErrorBundle, Parsec, pos1)
 import Prelude hiding (String)
 
 -- | A @megaparsec@ @ParsecT@ specified for use with @nixfmt@.
@@ -81,6 +85,9 @@ data Ann a = Ann
   }
   deriving (Show)
 
+removeLineInfo :: Ann a -> Ann a
+removeLineInfo a = a{sourceLine = MP.pos1}
+
 -- | An annotated value without any trivia or trailing comment
 pattern LoneAnn :: a -> Ann a
 pattern LoneAnn a <- Ann [] _ a Nothing
@@ -113,9 +120,9 @@ data Item a
     Item a
   | -- | Trivia interleaved in items
     Comments Trivia
-  deriving (Foldable, Show)
+  deriving (Foldable, Show, Functor)
 
-newtype Items a = Items {unItems :: [Item a]}
+newtype Items a = Items {unItems :: [Item a]} deriving (Functor)
 
 instance (Eq a) => Eq (Items a) where
   (==) = (==) `on` concatMap Data.Foldable.toList . unItems
@@ -239,6 +246,8 @@ class LanguageElement a where
   -- returned. This is useful for getting/extracting values
   mapLastToken' :: (forall b. Ann b -> (Ann b, c)) -> a -> (a, c)
 
+  mapAllTokens :: (forall b. Ann b -> Ann b) -> a -> a
+
   -- Walk all syntactically valid sub-expressions in a breadth-first search way. This allows
   -- minimizing failing test cases
   walkSubprograms :: a -> [Expression]
@@ -247,6 +256,7 @@ instance LanguageElement (Ann a) where
   mapFirstToken' f = f
   mapLastToken' f = f
   walkSubprograms = error "unreachable"
+  mapAllTokens f = f
 
 instance LanguageElement SimpleSelector where
   mapFirstToken' f = \case
@@ -261,6 +271,11 @@ instance LanguageElement SimpleSelector where
     (InterpolSelector Ann{sourceLine, value = str}) -> pure $ Term $ SimpleString $ ann sourceLine [[str]]
     (StringSelector str) -> [Term (SimpleString str)]
 
+  mapAllTokens f = \case
+    (IDSelector name) -> IDSelector $ f name
+    (InterpolSelector name) -> InterpolSelector $ f name
+    (StringSelector name) -> StringSelector $ f name
+
 instance LanguageElement Selector where
   mapFirstToken' f (Selector Nothing ident) = first (Selector Nothing) $ mapFirstToken' f ident
   mapFirstToken' f (Selector (Just dot) ident) = first (\dot' -> Selector (Just dot') ident) $ mapFirstToken' f dot
@@ -269,6 +284,17 @@ instance LanguageElement Selector where
 
   walkSubprograms (Selector _ ident) = walkSubprograms ident
 
+  mapAllTokens f (Selector dot ident) = Selector (f <$> dot) (mapAllTokens f ident)
+
+instance LanguageElement Binder where
+  mapFirstToken' _ _ = error "unused"
+  mapLastToken' _ _ = error "unused"
+  walkSubprograms _ = error "unused"
+
+  mapAllTokens f = \case
+    (Inherit inherit from sels semicolon) -> Inherit (f inherit) (mapAllTokens f <$> from) (Prelude.map (mapAllTokens f) sels) (f semicolon)
+    (Assignment sels eq rhs semicolon) -> Assignment (Prelude.map (mapAllTokens f) sels) (f eq) (mapAllTokens f rhs) (f semicolon)
+
 instance LanguageElement ParamAttr where
   mapFirstToken' _ _ = error "unreachable"
   mapLastToken' _ _ = error "unreachable"
@@ -278,6 +304,11 @@ instance LanguageElement ParamAttr where
     (ParamAttr name (Just (_, def)) _) -> [Term (Token name), def]
     (ParamEllipsis _) -> []
 
+  mapAllTokens f = \case
+    (ParamAttr name Nothing comma) -> ParamAttr (mapAllTokens f name) Nothing (f <$> comma)
+    (ParamAttr name (Just (qmark, def)) comma) -> ParamAttr (mapAllTokens f name) (Just (f qmark, mapAllTokens f def)) (f <$> comma)
+    (ParamEllipsis dots) -> ParamEllipsis $ f dots
+
 instance LanguageElement Parameter where
   mapFirstToken' f = \case
     (IDParameter name) -> first IDParameter (f name)
@@ -294,6 +325,11 @@ instance LanguageElement Parameter where
     (SetParameter _ bindings _) -> bindings >>= walkSubprograms
     (ContextParameter left _ right) -> walkSubprograms left ++ walkSubprograms right
 
+  mapAllTokens f = \case
+    (IDParameter name) -> IDParameter (f name)
+    (SetParameter open items close) -> SetParameter (f open) (Prelude.map (mapAllTokens f) items) (f close)
+    (ContextParameter first' at second) -> ContextParameter (mapAllTokens f first') (f at) (mapAllTokens f second)
+
 instance LanguageElement Term where
   mapFirstToken' f = \case
     (Token leaf) -> first Token (f leaf)
@@ -353,6 +389,17 @@ instance LanguageElement Term where
       -- TODO: Don't do this stripping at all, Doesn't seem very critical
       stripTrivia a = a{preTrivia = [], trailComment = Nothing}
 
+  mapAllTokens f = \case
+    (Token leaf) -> Token (f leaf)
+    (SimpleString string) -> SimpleString (f string)
+    (IndentedString string) -> IndentedString (f string)
+    (Path path) -> Path (f path)
+    (List open items close) -> List (f open) (mapAllTokens f <$> items) (f close)
+    (Set rec open items close) -> Set (f <$> rec) (f open) (mapAllTokens f <$> items) (f close)
+    (Selection term sels (Just (orToken, def))) -> Selection (mapAllTokens f term) (Prelude.map (mapAllTokens f) sels) $ Just (f orToken, mapAllTokens f def)
+    (Selection term sels Nothing) -> Selection (mapAllTokens f term) (Prelude.map (mapAllTokens f) sels) Nothing
+    (Parenthesized open expr close) -> Parenthesized (f open) (mapAllTokens f expr) (f close)
+
 instance LanguageElement Expression where
   mapFirstToken' f = \case
     (Term term) -> first Term (mapFirstToken' f term)
@@ -405,6 +452,19 @@ instance LanguageElement Expression where
     (Negation _ expr) -> [expr]
     (Inversion _ expr) -> [expr]
 
+  mapAllTokens f = \case
+    (Term term) -> Term (mapAllTokens f term)
+    (With with expr0 semicolon expr1) -> With (f with) (mapAllTokens f expr0) (f semicolon) (mapAllTokens f expr1)
+    (Let let_ items in_ body) -> Let (f let_) (mapAllTokens f <$> items) (f in_) (mapAllTokens f body)
+    (Assert assert cond semicolon body) -> Assert (f assert) (mapAllTokens f cond) (f semicolon) (mapAllTokens f body)
+    (If if_ expr0 then_ expr1 else_ expr2) -> If (f if_) (mapAllTokens f expr0) (f then_) (mapAllTokens f expr1) (f else_) (mapAllTokens f expr2)
+    (Abstraction param colon body) -> Abstraction (mapAllTokens f param) (f colon) (mapAllTokens f body)
+    (Application g a) -> Application (mapAllTokens f g) (mapAllTokens f a)
+    (Operation left op right) -> Operation (mapAllTokens f left) (f op) (mapAllTokens f right)
+    (MemberCheck name dot sels) -> MemberCheck (mapAllTokens f name) (f dot) (Prelude.map (mapAllTokens f) sels)
+    (Negation not_ expr) -> Negation (f not_) (mapAllTokens f expr)
+    (Inversion tilde expr) -> Inversion (f tilde) (mapAllTokens f expr)
+
 instance LanguageElement (Whole Expression) where
   mapFirstToken' f (Whole a trivia) =
     first (`Whole` trivia) (mapFirstToken' f a)
@@ -414,6 +474,8 @@ instance LanguageElement (Whole Expression) where
 
   walkSubprograms (Whole a _) = [a]
 
+  mapAllTokens f (Whole a trivia) = Whole (mapAllTokens f a) trivia
+
 instance (LanguageElement a) => LanguageElement (NonEmpty a) where
   mapFirstToken' f (x :| _) = first pure $ mapFirstToken' f x
 
@@ -422,6 +484,8 @@ instance (LanguageElement a) => LanguageElement (NonEmpty a) where
 
   walkSubprograms = error "unreachable"
 
+  mapAllTokens f = NonEmpty.map (mapAllTokens f)
+
 data Token
   = Integer Int
   | Float Double