diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,61 @@ +## Fourmolu 0.20.0.0 + +Now installable with GHCup! See README for details. + +* Improve `import-grouping` configuration + + * Add the `scope` option for import grouping ([#525](https://github.com/fourmolu/fourmolu/pull/525)). + + * Deprecate the `match` option for import grouping in favor of `glob` and `scope` ([#525](https://github.com/fourmolu/fourmolu/pull/525)). + + * Add the `import-list` option for import grouping ([#522](https://github.com/fourmolu/fourmolu/pull/522)). + +* Add a `record-style` to configure the placement of record braces. ([#467](https://github.com/fourmolu/fourmolu/issues/467)) + +* Fix applying `indent-wheres` configuration to pattern synonyms with explicit bidirectional `where` clauses ([#486](https://github.com/fourmolu/fourmolu/issues/486)) + +### Upstream changed: + +#### Ormolu 0.8.1.1 + +* Add missing braces for case expressions in single‑line do blocks. [Issue 1180](https://github.com/tweag/ormolu/issues/1180). + +* Fix the import grouping logic in the presence of imports with explicit levels. [Issue 1192](https://github.com/tweag/ormolu/issues/1192). + +#### Ormolu 0.8.1.0 + +* Fixed printing of guards on pattern binds. [Issue + 1178](https://github.com/tweag/ormolu/issues/1178). + +* Switched to `ghc-lib-parser-9.14`, with the following new syntactic features: + * GHC proposal [#493](https://github.com/ghc-proposals/ghc-proposals/blob/e2c683698323cec3e33625369ae2b5f585387c70/proposals/0493-specialise-expressions.rst): expressions in SPECIALISE pragmas + * Multiline strings in foreign import declarations. + * `ExplicitNamespaces` supports the `data` namespace specifier in import and export lists, replacing `pattern`. + * `LinearTypes` adds new syntax to support non-linear record fields. + * `RequiredTypeArguments` allows visible forall in GADT syntax. + +* Updated to `Cabal-syntax-3.16`. + +* Correctly format string literals containing the `\^\` escape sequence. [Issue + 1165](https://github.com/tweag/ormolu/issues/1165). + +* Correctly preserve consecutive blank lines in multiline strings. [Issue + 1194](https://github.com/tweag/ormolu/issues/1194). + +* Fixed printing of multi-line or-patterns inside as-patterns. [Issue + 1183](https://github.com/tweag/ormolu/issues/1183). + +* Fixed an issue where or-patterns would be indented twice. [Issue + 1188](https://github.com/tweag/ormolu/issues/1188). + +* Add support for `ExplicitLevelImports`. [Issue + 1192](https://github.com/tweag/ormolu/issues/1192). + ## Fourmolu 0.19.0.1 + +### Upstream changed: + +#### Ormolu 0.8.0.2 * Fixed a performance regression introduced in 0.8.0.0. [Issue 1176](https://github.com/tweag/ormolu/issues/1176). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -49,12 +49,23 @@ ## Installation -To install the latest release from Hackage, simply install with Cabal or Stack: +### (Recommended) Install with GHCup -```console -$ cabal install fourmolu -$ stack install fourmolu +```bash +ghcup config add-release-channel 3rdparty +ghcup install fourmolu latest ``` + +### Install with Cabal/Stack + +```bash +cabal install fourmolu +stack install fourmolu +``` + +### Install with [dotslash](https://dotslash-cli.com/docs/) + +Copy the configuration in the GitHub release notes. ## Building from source diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -468,7 +468,7 @@ help "Fail if formatting is not idempotent" ] -- We cannot parse the source type here, because we might need to do - -- autodection based on the input file extension (not available here) + -- autodetection based on the input file extension (not available here) -- before storing the resolved value in the config struct. <*> pure ModuleSource <*> (option parseColorMode . mconcat) @@ -492,7 +492,6 @@ <*> pure defaultPrinterOpts -- unused; overwritten in resolveConfig <*> (fmap Set.fromList . many . strOption . mconcat) [ long "local-modules", - short 'm', metavar "LOCAL_MODULES", help "Modules Fourmolu should consider as local by the current Cabal package" ] diff --git a/data/examples/declaration/data/linear-four-out.hs b/data/examples/declaration/data/linear-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/linear-four-out.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LinearTypes #-} + +data Record = Rec {x %'Many :: Int, y :: Char} + +data T2 a b c where + MkT2 :: a -> b %1 -> c %1 -> T2 a b c + +data T2 a b c = MkT2 {x %Many :: a, y :: b, z :: c} + +data T3 a m where + MkT3 :: a %m -> T3 a m diff --git a/data/examples/declaration/data/linear-out.hs b/data/examples/declaration/data/linear-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/linear-out.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LinearTypes #-} + +data Record = Rec {x %'Many :: Int, y :: Char} + +data T2 a b c where + MkT2 :: a -> b %1 -> c %1 -> T2 a b c + +data T2 a b c = MkT2 {x %Many :: a, y :: b, z :: c} + +data T3 a m where + MkT3 :: a %m -> T3 a m diff --git a/data/examples/declaration/data/linear.hs b/data/examples/declaration/data/linear.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/linear.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +data Record = Rec { x %'Many :: Int, y :: Char } + +data T2 a b c where + MkT2 :: a -> b %1 -> c %1 -> T2 a b c + +data T2 a b c = MkT2 { x %Many :: a, y :: b, z :: c } + +data T3 a m where + MkT3 :: a %m -> T3 a m diff --git a/data/examples/declaration/data/record-four-out.hs b/data/examples/declaration/data/record-four-out.hs --- a/data/examples/declaration/data/record-four-out.hs +++ b/data/examples/declaration/data/record-four-out.hs @@ -11,7 +11,7 @@ , fooGag , fooGog :: NonEmpty - ( Indentity + ( Identity Bool ) -- ^ GagGog diff --git a/data/examples/declaration/data/record-out.hs b/data/examples/declaration/data/record-out.hs --- a/data/examples/declaration/data/record-out.hs +++ b/data/examples/declaration/data/record-out.hs @@ -12,7 +12,7 @@ fooGag, fooGog :: NonEmpty - ( Indentity + ( Identity Bool ), -- | Huh! diff --git a/data/examples/declaration/data/record.hs b/data/examples/declaration/data/record.hs --- a/data/examples/declaration/data/record.hs +++ b/data/examples/declaration/data/record.hs @@ -6,7 +6,7 @@ { fooX :: Int -- ^ X , fooY :: Int -- ^ Y , fooBar, fooBaz :: NonEmpty (Identity Bool) -- ^ BarBaz - , fooGag, fooGog :: NonEmpty (Indentity + , fooGag, fooGog :: NonEmpty (Identity Bool) -- ^ GagGog , fooFoo diff --git a/data/examples/declaration/data/required-type-arguments-four-out.hs b/data/examples/declaration/data/required-type-arguments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/required-type-arguments-four-out.hs @@ -0,0 +1,25 @@ +data T a where + Typed :: forall a -> a -> T a + +f1 (Typed a x) = x :: a +f2 (Typed Int n) = n * 2 +f3 (Typed ((->) w Bool) g) = not . g + +data D x where + MkD1 :: + forall a b -> + a -> + b -> + D (a, b) + MkD2 :: + forall a. + forall b -> + a -> + b -> + D (a, b) + MkD3 :: + forall a -> + a -> + forall b -> + b -> + D (a, b) diff --git a/data/examples/declaration/data/required-type-arguments-out.hs b/data/examples/declaration/data/required-type-arguments-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/required-type-arguments-out.hs @@ -0,0 +1,27 @@ +data T a where + Typed :: forall a -> a -> T a + +f1 (Typed a x) = x :: a + +f2 (Typed Int n) = n * 2 + +f3 (Typed ((->) w Bool) g) = not . g + +data D x where + MkD1 :: + forall a b -> + a -> + b -> + D (a, b) + MkD2 :: + forall a. + forall b -> + a -> + b -> + D (a, b) + MkD3 :: + forall a -> + a -> + forall b -> + b -> + D (a, b) diff --git a/data/examples/declaration/data/required-type-arguments.hs b/data/examples/declaration/data/required-type-arguments.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/required-type-arguments.hs @@ -0,0 +1,24 @@ +data T a where + Typed :: forall a -> a -> T a + +f1 (Typed a x) = x :: a +f2 (Typed Int n) = n*2 +f3 (Typed ((->) w Bool) g) = not . g + +data D x where + MkD1 :: forall a b -> + a -> + b -> + D (a, b) + + MkD2 :: forall a. + forall b -> + a -> + b -> + D (a, b) + + MkD3 :: forall a -> + a -> + forall b -> + b -> + D (a, b) diff --git a/data/examples/declaration/foreign/foreign-import-multiline-four-out.hs b/data/examples/declaration/foreign/foreign-import-multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/foreign/foreign-import-multiline-four-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MultilineStrings #-} + +foreign import capi + """ + foo + bar + """ + foo :: Int -> Int diff --git a/data/examples/declaration/foreign/foreign-import-multiline-out.hs b/data/examples/declaration/foreign/foreign-import-multiline-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/foreign/foreign-import-multiline-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MultilineStrings #-} + +foreign import capi + """ + foo + bar + """ + foo :: Int -> Int diff --git a/data/examples/declaration/foreign/foreign-import-multiline.hs b/data/examples/declaration/foreign/foreign-import-multiline.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/foreign/foreign-import-multiline.hs @@ -0,0 +1,6 @@ +{-# language MultilineStrings #-} + +foreign import capi """ + foo + bar + """ foo :: Int -> Int diff --git a/data/examples/declaration/rewrite-rule/prelude2-four-out.hs b/data/examples/declaration/rewrite-rule/prelude2-four-out.hs --- a/data/examples/declaration/rewrite-rule/prelude2-four-out.hs +++ b/data/examples/declaration/rewrite-rule/prelude2-four-out.hs @@ -11,7 +11,7 @@ -- when we disable the rule that expands (++) into foldr -- The foldr/cons rule looks nice, but it can give disastrously --- bloated code when commpiling +-- bloated code when compiling -- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ] -- i.e. when there are very very long literal lists -- So I've disabled it for now. We could have special cases diff --git a/data/examples/declaration/rewrite-rule/prelude2-out.hs b/data/examples/declaration/rewrite-rule/prelude2-out.hs --- a/data/examples/declaration/rewrite-rule/prelude2-out.hs +++ b/data/examples/declaration/rewrite-rule/prelude2-out.hs @@ -11,7 +11,7 @@ -- when we disable the rule that expands (++) into foldr -- The foldr/cons rule looks nice, but it can give disastrously --- bloated code when commpiling +-- bloated code when compiling -- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ] -- i.e. when there are very very long literal lists -- So I've disabled it for now. We could have special cases diff --git a/data/examples/declaration/rewrite-rule/prelude2.hs b/data/examples/declaration/rewrite-rule/prelude2.hs --- a/data/examples/declaration/rewrite-rule/prelude2.hs +++ b/data/examples/declaration/rewrite-rule/prelude2.hs @@ -11,7 +11,7 @@ -- when we disable the rule that expands (++) into foldr -- The foldr/cons rule looks nice, but it can give disastrously --- bloated code when commpiling +-- bloated code when compiling -- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ] -- i.e. when there are very very long literal lists -- So I've disabled it for now. We could have special cases diff --git a/data/examples/declaration/signature/specialize/specialize-2-four-out.hs b/data/examples/declaration/signature/specialize/specialize-2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-2-four-out.hs @@ -0,0 +1,8 @@ +{-# SPECIALIZE addMult @Double #-} +{-# SPECIALIZE addMult (5 :: Int) #-} +{-# SPECIALIZE addMult 5 :: Int -> Int #-} + +{-# SPECIALIZE [1] forall x y. f @Int True (x, y) #-} + +{-# SPECIALIZE forall x xs. loop (x : xs) + #-} diff --git a/data/examples/declaration/signature/specialize/specialize-2-out.hs b/data/examples/declaration/signature/specialize/specialize-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-2-out.hs @@ -0,0 +1,8 @@ +{-# SPECIALIZE addMult @Double #-} +{-# SPECIALIZE addMult (5 :: Int) #-} +{-# SPECIALIZE addMult 5 :: Int -> Int #-} + +{-# SPECIALIZE [1] forall x y. f @Int True (x, y) #-} + +{-# SPECIALIZE forall x xs. loop (x : xs) + #-} diff --git a/data/examples/declaration/signature/specialize/specialize-2.hs b/data/examples/declaration/signature/specialize/specialize-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-2.hs @@ -0,0 +1,9 @@ +{-# SPECIALISE addMult @Double #-} +{-# SPECIALISE addMult (5 :: Int) #-} +{-# SPECIALISE addMult 5 :: Int -> Int #-} + +{-# SPECIALISE [1] forall x y. f @Int True (x,y) #-} + +{-# SPECIALISE + forall x xs . + loop (x:xs) #-} diff --git a/data/examples/declaration/signature/specialize/specialize-3-four-out.hs b/data/examples/declaration/signature/specialize/specialize-3-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-3-four-out.hs @@ -0,0 +1,10 @@ +sep, fsep, hsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc +sep = fmap P.sep . sequenceAFoldable +{-# SPECIALIZE NOINLINE sep :: [TCM Doc] -> TCM Doc #-} +{-# SPECIALIZE NOINLINE sep :: List1 (TCM Doc) -> TCM Doc #-} +fsep = fmap P.fsep . sequenceAFoldable +{-# SPECIALIZE NOINLINE [2] fsep :: [TCM Doc] -> TCM Doc #-} +{-# SPECIALIZE NOINLINE [2] fsep :: List1 (TCM Doc) -> TCM Doc #-} +hsep = fmap P.hsep . sequenceAFoldable +{-# SPECIALIZE NOINLINE [~2] hsep :: [TCM Doc] -> TCM Doc #-} +{-# SPECIALIZE NOINLINE [~2] hsep :: List1 (TCM Doc) -> TCM Doc #-} diff --git a/data/examples/declaration/signature/specialize/specialize-3-out.hs b/data/examples/declaration/signature/specialize/specialize-3-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-3-out.hs @@ -0,0 +1,10 @@ +sep, fsep, hsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc +sep = fmap P.sep . sequenceAFoldable +{-# SPECIALIZE NOINLINE sep :: [TCM Doc] -> TCM Doc #-} +{-# SPECIALIZE NOINLINE sep :: List1 (TCM Doc) -> TCM Doc #-} +fsep = fmap P.fsep . sequenceAFoldable +{-# SPECIALIZE NOINLINE [2] fsep :: [TCM Doc] -> TCM Doc #-} +{-# SPECIALIZE NOINLINE [2] fsep :: List1 (TCM Doc) -> TCM Doc #-} +hsep = fmap P.hsep . sequenceAFoldable +{-# SPECIALIZE NOINLINE [~2] hsep :: [TCM Doc] -> TCM Doc #-} +{-# SPECIALIZE NOINLINE [~2] hsep :: List1 (TCM Doc) -> TCM Doc #-} diff --git a/data/examples/declaration/signature/specialize/specialize-3.hs b/data/examples/declaration/signature/specialize/specialize-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-3.hs @@ -0,0 +1,4 @@ +sep, fsep, hsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc +sep = fmap P.sep . sequenceAFoldable ; {-# SPECIALIZE NOINLINE sep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE sep :: List1 (TCM Doc) -> TCM Doc #-} +fsep = fmap P.fsep . sequenceAFoldable ; {-# SPECIALIZE NOINLINE [2] fsep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE [2] fsep :: List1 (TCM Doc) -> TCM Doc #-} +hsep = fmap P.hsep . sequenceAFoldable ; {-# SPECIALIZE NOINLINE [~2] hsep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE [~2] hsep :: List1 (TCM Doc) -> TCM Doc #-} diff --git a/data/examples/declaration/value/function/arrow/proc-do-complex-four-out.hs b/data/examples/declaration/value/function/arrow/proc-do-complex-four-out.hs --- a/data/examples/declaration/value/function/arrow/proc-do-complex-four-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-complex-four-out.hs @@ -12,7 +12,7 @@ ) -> do -- Begin do - (x, y) <- -- GHC parser fails if layed out over multiple lines + (x, y) <- -- GHC parser fails if laid out over multiple lines f -- Call into f ( a , c -- Tuple together arguments diff --git a/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs b/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs --- a/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs @@ -12,7 +12,7 @@ ) -> do -- Begin do - (x, y) <- -- GHC parser fails if layed out over multiple lines + (x, y) <- -- GHC parser fails if laid out over multiple lines f -- Call into f ( a, c -- Tuple together arguments diff --git a/data/examples/declaration/value/function/arrow/proc-do-complex.hs b/data/examples/declaration/value/function/arrow/proc-do-complex.hs --- a/data/examples/declaration/value/function/arrow/proc-do-complex.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-complex.hs @@ -9,7 +9,7 @@ (e, f) ) -> do -- Begin do - (x,y) -- GHC parser fails if layed out over multiple lines + (x,y) -- GHC parser fails if laid out over multiple lines <- f -- Call into f (a, c) -- Tuple together arguments diff --git a/data/examples/declaration/value/function/case-single-line-with-braces-four-out.hs b/data/examples/declaration/value/function/case-single-line-with-braces-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-single-line-with-braces-four-out.hs @@ -0,0 +1,2 @@ +getValue :: Maybe Int -> Int +getValue x = case x of Just n -> n; Nothing -> 0 diff --git a/data/examples/declaration/value/function/case-single-line-with-braces-out.hs b/data/examples/declaration/value/function/case-single-line-with-braces-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-single-line-with-braces-out.hs @@ -0,0 +1,2 @@ +getValue :: Maybe Int -> Int +getValue x = case x of Just n -> n; Nothing -> 0 diff --git a/data/examples/declaration/value/function/case-single-line-with-braces.hs b/data/examples/declaration/value/function/case-single-line-with-braces.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-single-line-with-braces.hs @@ -0,0 +1,2 @@ +getValue :: Maybe Int -> Int +getValue x = case x of {Just n -> n; Nothing -> 0} diff --git a/data/examples/declaration/value/function/do-multiline-with-case-four-out.hs b/data/examples/declaration/value/function/do-multiline-with-case-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-multiline-with-case-four-out.hs @@ -0,0 +1,13 @@ +handleInput :: IO () +handleInput = do + putStrLn "Enter command:" + cmd <- getLine + case cmd of + "quit" -> putStrLn "Goodbye" + "help" -> do + putStrLn "Available commands:" + putStrLn " quit - exit the program" + putStrLn " help - show this message" + _ -> do + putStrLn $ "Unknown command: " ++ cmd + handleInput diff --git a/data/examples/declaration/value/function/do-multiline-with-case-out.hs b/data/examples/declaration/value/function/do-multiline-with-case-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-multiline-with-case-out.hs @@ -0,0 +1,13 @@ +handleInput :: IO () +handleInput = do + putStrLn "Enter command:" + cmd <- getLine + case cmd of + "quit" -> putStrLn "Goodbye" + "help" -> do + putStrLn "Available commands:" + putStrLn " quit - exit the program" + putStrLn " help - show this message" + _ -> do + putStrLn $ "Unknown command: " ++ cmd + handleInput diff --git a/data/examples/declaration/value/function/do-multiline-with-case.hs b/data/examples/declaration/value/function/do-multiline-with-case.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-multiline-with-case.hs @@ -0,0 +1,13 @@ +handleInput :: IO () +handleInput = do + putStrLn "Enter command:" + cmd <- getLine + case cmd of + "quit" -> putStrLn "Goodbye" + "help" -> do + putStrLn "Available commands:" + putStrLn " quit - exit the program" + putStrLn " help - show this message" + _ -> do + putStrLn $ "Unknown command: " ++ cmd + handleInput diff --git a/data/examples/declaration/value/function/do-single-line-case-guards-four-out.hs b/data/examples/declaration/value/function/do-single-line-case-guards-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-case-guards-four-out.hs @@ -0,0 +1,2 @@ +checkValue :: Int -> IO () +checkValue n = do putStr "Value is: "; case () of { _ | n < 0 -> putStrLn "negative" | n == 0 -> putStrLn "zero" | otherwise -> putStrLn "positive" } diff --git a/data/examples/declaration/value/function/do-single-line-case-guards-out.hs b/data/examples/declaration/value/function/do-single-line-case-guards-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-case-guards-out.hs @@ -0,0 +1,2 @@ +checkValue :: Int -> IO () +checkValue n = do putStr "Value is: "; case () of { _ | n < 0 -> putStrLn "negative" | n == 0 -> putStrLn "zero" | otherwise -> putStrLn "positive" } diff --git a/data/examples/declaration/value/function/do-single-line-case-guards.hs b/data/examples/declaration/value/function/do-single-line-case-guards.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-case-guards.hs @@ -0,0 +1,2 @@ +checkValue :: Int -> IO () +checkValue n = do {putStr "Value is: "; case () of {_ | n < 0 -> putStrLn "negative" | n == 0 -> putStrLn "zero" | otherwise -> putStrLn "positive"}} diff --git a/data/examples/declaration/value/function/do-single-line-lambda-case-four-out.hs b/data/examples/declaration/value/function/do-single-line-lambda-case-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-lambda-case-four-out.hs @@ -0,0 +1,2 @@ +processValue :: Maybe Int -> IO () +processValue x = do putStrLn "Processing:"; \case { Just n -> print n; Nothing -> putStrLn "Empty" } x; putStrLn "Done" diff --git a/data/examples/declaration/value/function/do-single-line-lambda-case-out.hs b/data/examples/declaration/value/function/do-single-line-lambda-case-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-lambda-case-out.hs @@ -0,0 +1,2 @@ +processValue :: Maybe Int -> IO () +processValue x = do putStrLn "Processing:"; \case { Just n -> print n; Nothing -> putStrLn "Empty" } x; putStrLn "Done" diff --git a/data/examples/declaration/value/function/do-single-line-lambda-case.hs b/data/examples/declaration/value/function/do-single-line-lambda-case.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-lambda-case.hs @@ -0,0 +1,2 @@ +processValue :: Maybe Int -> IO () +processValue x = do {putStrLn "Processing:"; \case {Just n -> print n; Nothing -> putStrLn "Empty"} x; putStrLn "Done"} diff --git a/data/examples/declaration/value/function/do-single-line-multiple-cases-four-out.hs b/data/examples/declaration/value/function/do-single-line-multiple-cases-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-multiple-cases-four-out.hs @@ -0,0 +1,2 @@ +processPair :: Maybe Int -> Maybe String -> IO () +processPair x y = do case x of { Just n -> print n; Nothing -> putStrLn "No number" }; case y of { Just s -> putStrLn s; Nothing -> putStrLn "No string" } diff --git a/data/examples/declaration/value/function/do-single-line-multiple-cases-out.hs b/data/examples/declaration/value/function/do-single-line-multiple-cases-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-multiple-cases-out.hs @@ -0,0 +1,2 @@ +processPair :: Maybe Int -> Maybe String -> IO () +processPair x y = do case x of { Just n -> print n; Nothing -> putStrLn "No number" }; case y of { Just s -> putStrLn s; Nothing -> putStrLn "No string" } diff --git a/data/examples/declaration/value/function/do-single-line-multiple-cases.hs b/data/examples/declaration/value/function/do-single-line-multiple-cases.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-multiple-cases.hs @@ -0,0 +1,2 @@ +processPair :: Maybe Int -> Maybe String -> IO () +processPair x y = do {case x of {Just n -> print n; Nothing -> putStrLn "No number"}; case y of {Just s -> putStrLn s; Nothing -> putStrLn "No string"}} diff --git a/data/examples/declaration/value/function/do-single-line-nested-case-four-out.hs b/data/examples/declaration/value/function/do-single-line-nested-case-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-nested-case-four-out.hs @@ -0,0 +1,2 @@ +nestedDo :: Either String Int -> IO () +nestedDo e = do putStr "Start: "; case e of { Left s -> do { putStr "Error: "; putStrLn s }; Right n -> do { putStr "Value: "; print n } }; putStrLn "End" diff --git a/data/examples/declaration/value/function/do-single-line-nested-case-out.hs b/data/examples/declaration/value/function/do-single-line-nested-case-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-nested-case-out.hs @@ -0,0 +1,2 @@ +nestedDo :: Either String Int -> IO () +nestedDo e = do putStr "Start: "; case e of { Left s -> do { putStr "Error: "; putStrLn s }; Right n -> do { putStr "Value: "; print n } }; putStrLn "End" diff --git a/data/examples/declaration/value/function/do-single-line-nested-case.hs b/data/examples/declaration/value/function/do-single-line-nested-case.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-nested-case.hs @@ -0,0 +1,2 @@ +nestedDo :: Either String Int -> IO () +nestedDo e = do {putStr "Start: "; case e of {Left s -> do {putStr "Error: "; putStrLn s}; Right n -> do {putStr "Value: "; print n}}; putStrLn "End"} diff --git a/data/examples/declaration/value/function/do-single-line-with-case-four-out.hs b/data/examples/declaration/value/function/do-single-line-with-case-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-with-case-four-out.hs @@ -0,0 +1,2 @@ +doGuessing :: (Ord t, Read t) => t -> IO () +doGuessing num = do putStrLn "Enter your guess:"; guess <- getLine; case compare (read guess) num of { LT -> do { putStrLn "Too low!"; doGuessing num }; GT -> do { putStrLn "Too high!"; doGuessing num }; EQ -> putStrLn "You win!" } diff --git a/data/examples/declaration/value/function/do-single-line-with-case-out.hs b/data/examples/declaration/value/function/do-single-line-with-case-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-with-case-out.hs @@ -0,0 +1,2 @@ +doGuessing :: (Ord t, Read t) => t -> IO () +doGuessing num = do putStrLn "Enter your guess:"; guess <- getLine; case compare (read guess) num of { LT -> do { putStrLn "Too low!"; doGuessing num }; GT -> do { putStrLn "Too high!"; doGuessing num }; EQ -> putStrLn "You win!" } diff --git a/data/examples/declaration/value/function/do-single-line-with-case.hs b/data/examples/declaration/value/function/do-single-line-with-case.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-with-case.hs @@ -0,0 +1,2 @@ +doGuessing :: (Ord t, Read t) => t -> IO () +doGuessing num = do {putStrLn "Enter your guess:"; guess <- getLine; case compare (read guess) num of {LT -> do {putStrLn "Too low!"; doGuessing num}; GT -> do { putStrLn "Too high!"; doGuessing num}; EQ -> putStrLn "You win!"}} diff --git a/data/examples/declaration/value/function/guards-four-out.hs b/data/examples/declaration/value/function/guards-four-out.hs --- a/data/examples/declaration/value/function/guards-four-out.hs +++ b/data/examples/declaration/value/function/guards-four-out.hs @@ -10,3 +10,5 @@ quux :: Int -> Int quux x | x < 0 = x quux x = x + +(a, b) | c = d diff --git a/data/examples/declaration/value/function/guards-out.hs b/data/examples/declaration/value/function/guards-out.hs --- a/data/examples/declaration/value/function/guards-out.hs +++ b/data/examples/declaration/value/function/guards-out.hs @@ -10,3 +10,5 @@ quux :: Int -> Int quux x | x < 0 = x quux x = x + +(a, b) | c = d diff --git a/data/examples/declaration/value/function/guards.hs b/data/examples/declaration/value/function/guards.hs --- a/data/examples/declaration/value/function/guards.hs +++ b/data/examples/declaration/value/function/guards.hs @@ -10,3 +10,5 @@ quux :: Int -> Int quux x | x < 0 = x quux x = x + +(a, b) | c = d diff --git a/data/examples/declaration/value/function/linear-bindings-four-out.hs b/data/examples/declaration/value/function/linear-bindings-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/linear-bindings-four-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE LinearTypes #-} + +h x = g y + where + %1 y = f x + +let %1 x = u in () +let %Many (x, y) = u in () +let %1 ~(x, y) = u in () diff --git a/data/examples/declaration/value/function/linear-bindings-out.hs b/data/examples/declaration/value/function/linear-bindings-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/linear-bindings-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE LinearTypes #-} + +h x = g y + where + %1 y = f x + +let %1 x = u in () +let %Many (x, y) = u in () +let %1 ~(x, y) = u in () diff --git a/data/examples/declaration/value/function/linear-bindings.hs b/data/examples/declaration/value/function/linear-bindings.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/linear-bindings.hs @@ -0,0 +1,9 @@ +{-# Language LinearTypes #-} + +h x = g y + where + %1 y = f x + +let %1 x = u in () +let %Many (x, y) = u in () +let %1 ~(x, y) = u in () diff --git a/data/examples/declaration/value/function/multiline-strings-9-four-out.hs b/data/examples/declaration/value/function/multiline-strings-9-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-9-four-out.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultilineStrings #-} + +multilineBlank = + """ + 1 + + + + + 6 + """ diff --git a/data/examples/declaration/value/function/multiline-strings-9-out.hs b/data/examples/declaration/value/function/multiline-strings-9-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-9-out.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultilineStrings #-} + +multilineBlank = + """ + 1 + + + + + 6 + """ diff --git a/data/examples/declaration/value/function/multiline-strings-9.hs b/data/examples/declaration/value/function/multiline-strings-9.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-9.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultilineStrings #-} + +multilineBlank = + """ + 1 + + + + + 6 + """ diff --git a/data/examples/declaration/value/function/pattern/or-patterns-four-out.hs b/data/examples/declaration/value/function/pattern/or-patterns-four-out.hs --- a/data/examples/declaration/value/function/pattern/or-patterns-four-out.hs +++ b/data/examples/declaration/value/function/pattern/or-patterns-four-out.hs @@ -20,7 +20,8 @@ sane e = case e of 1 2 - 3 -> a + 3 -> + a 4 5 6 -> b @@ -33,3 +34,10 @@ (D; E (Just _) Nothing) -> 4 F -> 5 + +food + foo@( A; + B; + C + ) = Just foo +food _ = Nothing diff --git a/data/examples/declaration/value/function/pattern/or-patterns-out.hs b/data/examples/declaration/value/function/pattern/or-patterns-out.hs --- a/data/examples/declaration/value/function/pattern/or-patterns-out.hs +++ b/data/examples/declaration/value/function/pattern/or-patterns-out.hs @@ -21,7 +21,8 @@ sane e = case e of 1 2 - 3 -> a + 3 -> + a 4 5 6 -> b @@ -34,3 +35,10 @@ (D; E (Just _) Nothing) -> 4 F -> 5 + +food + foo@( A; + B; + C + ) = Just foo +food _ = Nothing diff --git a/data/examples/declaration/value/function/pattern/or-patterns.hs b/data/examples/declaration/value/function/pattern/or-patterns.hs --- a/data/examples/declaration/value/function/pattern/or-patterns.hs +++ b/data/examples/declaration/value/function/pattern/or-patterns.hs @@ -20,7 +20,8 @@ sane e = case e of 1 2 - 3 -> a + 3 -> + a 4 5;6 -> b 7;8 -> c @@ -31,3 +32,8 @@ (D; E (Just _) Nothing) -> 4 F -> 5 + +food foo@(A; + B; + C) = Just foo +food _ = Nothing diff --git a/data/examples/declaration/value/function/strings-four-out.hs b/data/examples/declaration/value/function/strings-four-out.hs --- a/data/examples/declaration/value/function/strings-four-out.hs +++ b/data/examples/declaration/value/function/strings-four-out.hs @@ -8,3 +8,5 @@ \baz" weirdGap = "\65\ \0" + +weirdEscape = "\^\ " diff --git a/data/examples/declaration/value/function/strings-out.hs b/data/examples/declaration/value/function/strings-out.hs --- a/data/examples/declaration/value/function/strings-out.hs +++ b/data/examples/declaration/value/function/strings-out.hs @@ -10,3 +10,5 @@ \baz" weirdGap = "\65\ \0" + +weirdEscape = "\^\ " diff --git a/data/examples/declaration/value/function/strings.hs b/data/examples/declaration/value/function/strings.hs --- a/data/examples/declaration/value/function/strings.hs +++ b/data/examples/declaration/value/function/strings.hs @@ -7,3 +7,5 @@ \baz" weirdGap = "\65\ \0" + +weirdEscape = "\^\ " diff --git a/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-four-out.hs b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-four-out.hs --- a/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-four-out.hs +++ b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-four-out.hs @@ -3,19 +3,19 @@ pattern P a <- C a where P a = C a pattern HeadC x <- x : xs - where - HeadC x = [x] + where + HeadC x = [x] pattern HeadC' x <- x : xs - where - HeadC' x = [x] + where + HeadC' x = [x] pattern Simple <- "Simple" - where - Simple = "Complicated" + where + Simple = "Complicated" pattern a :< b <- (a, b) - where - a :< b = (a, b) + where + a :< b = (a, b) diff --git a/data/examples/import/data-four-out.hs b/data/examples/import/data-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/data-four-out.hs @@ -0,0 +1,3 @@ +module Bar (data P, T (data P), data f) where + +import N (T (data P), data P, data f) diff --git a/data/examples/import/data-out.hs b/data/examples/import/data-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/data-out.hs @@ -0,0 +1,3 @@ +module Bar (data P, T (data P), data f) where + +import N (T (data P), data P, data f) diff --git a/data/examples/import/data.hs b/data/examples/import/data.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/data.hs @@ -0,0 +1,6 @@ + +module Bar (data P, T(data P), data f) where + +import N (data P) +import N (T(data P)) +import N (data f) diff --git a/data/examples/import/explicit-level-imports-four-out.hs b/data/examples/import/explicit-level-imports-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports-four-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ExplicitLevelImports #-} + +import A splice +import {-# SOURCE #-} safe qualified A splice as QA hiding (a, b, c, d, e, f) +import quote qualified B as QB +import qualified C splice as SC +import qualified D splice +import Data.ByteString (e) +import Data.ByteString.Lazy quote (d) +import splice Data.Text (a, b, c) +import PyF () +import splice PyF (fmt, tmf) +import quote PyF (abc) diff --git a/data/examples/import/explicit-level-imports-out.hs b/data/examples/import/explicit-level-imports-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ExplicitLevelImports #-} + +import A splice +import {-# SOURCE #-} safe qualified A splice as QA hiding (a, b, c, d, e, f) +import quote qualified B as QB +import qualified C splice as SC +import qualified D splice +import Data.ByteString (e) +import Data.ByteString.Lazy quote (d) +import splice Data.Text (a, b, c) +import PyF () +import splice PyF (fmt, tmf) +import quote PyF (abc) diff --git a/data/examples/import/explicit-level-imports-qualified-post-four-out.hs b/data/examples/import/explicit-level-imports-qualified-post-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports-qualified-post-four-out.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE ImportQualifiedPost #-} + +import quote A qualified as QA +import B quote qualified as QB diff --git a/data/examples/import/explicit-level-imports-qualified-post-out.hs b/data/examples/import/explicit-level-imports-qualified-post-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports-qualified-post-out.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE ImportQualifiedPost #-} + +import quote A qualified as QA +import B quote qualified as QB diff --git a/data/examples/import/explicit-level-imports-qualified-post.hs b/data/examples/import/explicit-level-imports-qualified-post.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports-qualified-post.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE ImportQualifiedPost #-} + +import qualified B quote as QB +import quote qualified A as QA diff --git a/data/examples/import/explicit-level-imports.hs b/data/examples/import/explicit-level-imports.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ExplicitLevelImports #-} + +import splice Data.Text (a, b, c) +import Data.ByteString.Lazy quote (d) +import Data.ByteString (e) +import {-# SOURCE #-} safe qualified A splice as QA hiding (a, b, c, d, e, f) +import quote qualified B as QB +import qualified C splice as SC +import A splice +import qualified D splice +import quote PyF (abc) +import splice PyF (fmt) +import splice PyF (tmf) +import PyF () diff --git a/data/examples/other/empty-forall-four-out.hs b/data/examples/other/empty-forall-four-out.hs --- a/data/examples/other/empty-forall-four-out.hs +++ b/data/examples/other/empty-forall-four-out.hs @@ -12,7 +12,7 @@ forall. T x = x {-# RULES -"r" +"r" forall. r a = () #-} diff --git a/data/examples/other/empty-forall-out.hs b/data/examples/other/empty-forall-out.hs --- a/data/examples/other/empty-forall-out.hs +++ b/data/examples/other/empty-forall-out.hs @@ -12,7 +12,7 @@ forall. T x = x {-# RULES -"r" +"r" forall. r a = () #-} diff --git a/data/fourmolu/haddock-style/output-multi_line-module=multi_line.hs b/data/fourmolu/haddock-style/output-multi_line-module=multi_line.hs --- a/data/fourmolu/haddock-style/output-multi_line-module=multi_line.hs +++ b/data/fourmolu/haddock-style/output-multi_line-module=multi_line.hs @@ -37,6 +37,6 @@ {- | This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\} +> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int diff --git a/data/fourmolu/haddock-style/output-multi_line-module=multi_line_compact.hs b/data/fourmolu/haddock-style/output-multi_line-module=multi_line_compact.hs --- a/data/fourmolu/haddock-style/output-multi_line-module=multi_line_compact.hs +++ b/data/fourmolu/haddock-style/output-multi_line-module=multi_line_compact.hs @@ -37,6 +37,6 @@ {- | This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\} +> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int diff --git a/data/fourmolu/haddock-style/output-multi_line-module=single_line.hs b/data/fourmolu/haddock-style/output-multi_line-module=single_line.hs --- a/data/fourmolu/haddock-style/output-multi_line-module=single_line.hs +++ b/data/fourmolu/haddock-style/output-multi_line-module=single_line.hs @@ -36,6 +36,6 @@ {- | This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\} +> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int diff --git a/data/fourmolu/haddock-style/output-multi_line.hs b/data/fourmolu/haddock-style/output-multi_line.hs --- a/data/fourmolu/haddock-style/output-multi_line.hs +++ b/data/fourmolu/haddock-style/output-multi_line.hs @@ -37,6 +37,6 @@ {- | This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\} +> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int diff --git a/data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line.hs b/data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line.hs --- a/data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line.hs +++ b/data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line.hs @@ -37,6 +37,6 @@ {-| This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\} +> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int diff --git a/data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line_compact.hs b/data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line_compact.hs --- a/data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line_compact.hs +++ b/data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line_compact.hs @@ -37,6 +37,6 @@ {-| This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\} +> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int diff --git a/data/fourmolu/haddock-style/output-multi_line_compact-module=single_line.hs b/data/fourmolu/haddock-style/output-multi_line_compact-module=single_line.hs --- a/data/fourmolu/haddock-style/output-multi_line_compact-module=single_line.hs +++ b/data/fourmolu/haddock-style/output-multi_line_compact-module=single_line.hs @@ -36,6 +36,6 @@ {-| This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\} +> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int diff --git a/data/fourmolu/haddock-style/output-multi_line_compact.hs b/data/fourmolu/haddock-style/output-multi_line_compact.hs --- a/data/fourmolu/haddock-style/output-multi_line_compact.hs +++ b/data/fourmolu/haddock-style/output-multi_line_compact.hs @@ -37,6 +37,6 @@ {-| This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\} +> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int diff --git a/data/fourmolu/import-grouping/input.hs b/data/fourmolu/import-grouping/input.hs --- a/data/fourmolu/import-grouping/input.hs +++ b/data/fourmolu/import-grouping/input.hs @@ -1,13 +1,16 @@ module Main where +import Data.Either import Data.Text (Text) import Data.Maybe (maybe) import qualified Data.Text import Control.Monad (Monad (..)) +import Data.Functor import qualified System.IO as SIO import SomeInternal.Module1 (anotherDefinition, someDefinition) import qualified SomeInternal.Module2 as Mod2 import Text.Printf (printf) import qualified SomeModule +import SomeInternal.Module2 diff --git a/data/fourmolu/import-grouping/output-by_qualified.hs b/data/fourmolu/import-grouping/output-by_qualified.hs --- a/data/fourmolu/import-grouping/output-by_qualified.hs +++ b/data/fourmolu/import-grouping/output-by_qualified.hs @@ -1,9 +1,12 @@ module Main where import Control.Monad (Monad (..)) +import Data.Either +import Data.Functor import Data.Maybe (maybe) import Data.Text (Text) import SomeInternal.Module1 (anotherDefinition, someDefinition) +import SomeInternal.Module2 import Text.Printf (printf) import qualified Data.Text diff --git a/data/fourmolu/import-grouping/output-by_scope.hs b/data/fourmolu/import-grouping/output-by_scope.hs --- a/data/fourmolu/import-grouping/output-by_scope.hs +++ b/data/fourmolu/import-grouping/output-by_scope.hs @@ -1,6 +1,8 @@ module Main where import Control.Monad (Monad (..)) +import Data.Either +import Data.Functor import Data.Maybe (maybe) import Data.Text (Text) import qualified Data.Text @@ -9,4 +11,5 @@ import Text.Printf (printf) import SomeInternal.Module1 (anotherDefinition, someDefinition) +import SomeInternal.Module2 import qualified SomeInternal.Module2 as Mod2 diff --git a/data/fourmolu/import-grouping/output-by_scope_then_qualified.hs b/data/fourmolu/import-grouping/output-by_scope_then_qualified.hs --- a/data/fourmolu/import-grouping/output-by_scope_then_qualified.hs +++ b/data/fourmolu/import-grouping/output-by_scope_then_qualified.hs @@ -1,6 +1,8 @@ module Main where import Control.Monad (Monad (..)) +import Data.Either +import Data.Functor import Data.Maybe (maybe) import Data.Text (Text) import Text.Printf (printf) @@ -10,5 +12,6 @@ import qualified System.IO as SIO import SomeInternal.Module1 (anotherDefinition, someDefinition) +import SomeInternal.Module2 import qualified SomeInternal.Module2 as Mod2 diff --git a/data/fourmolu/import-grouping/output-custom.hs b/data/fourmolu/import-grouping/output-custom.hs --- a/data/fourmolu/import-grouping/output-custom.hs +++ b/data/fourmolu/import-grouping/output-custom.hs @@ -1,5 +1,9 @@ module Main where +import Data.Either +import Data.Functor +import SomeInternal.Module2 + import Data.Text (Text) import qualified Data.Text diff --git a/data/fourmolu/import-grouping/output-preserve.hs b/data/fourmolu/import-grouping/output-preserve.hs --- a/data/fourmolu/import-grouping/output-preserve.hs +++ b/data/fourmolu/import-grouping/output-preserve.hs @@ -1,12 +1,15 @@ module Main where +import Data.Either import Data.Maybe (maybe) import Data.Text (Text) import Control.Monad (Monad (..)) +import Data.Functor import qualified Data.Text import SomeInternal.Module1 (anotherDefinition, someDefinition) +import SomeInternal.Module2 import qualified SomeInternal.Module2 as Mod2 import qualified SomeModule import qualified System.IO as SIO diff --git a/data/fourmolu/import-grouping/output-single.hs b/data/fourmolu/import-grouping/output-single.hs --- a/data/fourmolu/import-grouping/output-single.hs +++ b/data/fourmolu/import-grouping/output-single.hs @@ -1,10 +1,13 @@ module Main where import Control.Monad (Monad (..)) +import Data.Either +import Data.Functor import Data.Maybe (maybe) import Data.Text (Text) import qualified Data.Text import SomeInternal.Module1 (anotherDefinition, someDefinition) +import SomeInternal.Module2 import qualified SomeInternal.Module2 as Mod2 import qualified SomeModule import qualified System.IO as SIO diff --git a/data/fourmolu/indentation/input.hs b/data/fourmolu/indentation/input.hs --- a/data/fourmolu/indentation/input.hs +++ b/data/fourmolu/indentation/input.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module Foo ( asdf, bar, @@ -21,3 +23,7 @@ class Foo a where foo :: a -> Int + +pattern HeadC x <- x : xs + where + HeadC x = [x] diff --git a/data/fourmolu/indentation/output-2-indent_wheres.hs b/data/fourmolu/indentation/output-2-indent_wheres.hs --- a/data/fourmolu/indentation/output-2-indent_wheres.hs +++ b/data/fourmolu/indentation/output-2-indent_wheres.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module Foo ( asdf, bar, @@ -21,3 +23,7 @@ class Foo a where foo :: a -> Int + +pattern HeadC x <- x : xs + where + HeadC x = [x] diff --git a/data/fourmolu/indentation/output-2.hs b/data/fourmolu/indentation/output-2.hs --- a/data/fourmolu/indentation/output-2.hs +++ b/data/fourmolu/indentation/output-2.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module Foo ( asdf, bar, @@ -21,3 +23,7 @@ class Foo a where foo :: a -> Int + +pattern HeadC x <- x : xs + where + HeadC x = [x] diff --git a/data/fourmolu/indentation/output-3-indent_wheres.hs b/data/fourmolu/indentation/output-3-indent_wheres.hs --- a/data/fourmolu/indentation/output-3-indent_wheres.hs +++ b/data/fourmolu/indentation/output-3-indent_wheres.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module Foo ( asdf, bar, @@ -21,3 +23,7 @@ class Foo a where foo :: a -> Int + +pattern HeadC x <- x : xs + where + HeadC x = [x] diff --git a/data/fourmolu/indentation/output-3.hs b/data/fourmolu/indentation/output-3.hs --- a/data/fourmolu/indentation/output-3.hs +++ b/data/fourmolu/indentation/output-3.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module Foo ( asdf, bar, @@ -21,3 +23,7 @@ class Foo a where foo :: a -> Int + +pattern HeadC x <- x : xs + where + HeadC x = [x] diff --git a/data/fourmolu/indentation/output-4-indent_wheres.hs b/data/fourmolu/indentation/output-4-indent_wheres.hs --- a/data/fourmolu/indentation/output-4-indent_wheres.hs +++ b/data/fourmolu/indentation/output-4-indent_wheres.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module Foo ( asdf, bar, @@ -21,3 +23,7 @@ class Foo a where foo :: a -> Int + +pattern HeadC x <- x : xs + where + HeadC x = [x] diff --git a/data/fourmolu/indentation/output-4.hs b/data/fourmolu/indentation/output-4.hs --- a/data/fourmolu/indentation/output-4.hs +++ b/data/fourmolu/indentation/output-4.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module Foo ( asdf, bar, @@ -21,3 +23,7 @@ class Foo a where foo :: a -> Int + +pattern HeadC x <- x : xs + where + HeadC x = [x] diff --git a/data/fourmolu/record-style/input.hs b/data/fourmolu/record-style/input.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/record-style/input.hs @@ -0,0 +1,24 @@ +data Foo = Foo + { a :: Int + , b :: Int + , c :: Int + } + +-- Test nesting +data Client = PremiumClient { name :: String, + address :: String, aFieldWithAnUnneccessarilyLongFieldName :: String } + -- And some comment here as well + | NotSoPremiumClient { name :: String, + address :: String, aFieldWithAnUnneccessarilyLongFieldName :: String } + +x :: Foo -> [Int] +x Foo{ a = possiblyLongName, + b = anotherLongName, + c = longNameAsWell + } = [possiblyLongName, anotherLongName, longNameAsWell] + +y :: Int -> Int -> Int -> Foo +y possiblyLongName anotherLongName longNameAsWell = Foo{ a = possiblyLongName, + b = anotherLongName, + c = longNameAsWell + } diff --git a/data/fourmolu/record-style/output-aligned-leading.hs b/data/fourmolu/record-style/output-aligned-leading.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/record-style/output-aligned-leading.hs @@ -0,0 +1,35 @@ +data Foo = Foo + { a :: Int + , b :: Int + , c :: Int + } + +-- Test nesting +data Client + = PremiumClient + { name :: String + , address :: String + , aFieldWithAnUnneccessarilyLongFieldName :: String + } + | -- And some comment here as well + NotSoPremiumClient + { name :: String + , address :: String + , aFieldWithAnUnneccessarilyLongFieldName :: String + } + +x :: Foo -> [Int] +x + Foo + { a = possiblyLongName + , b = anotherLongName + , c = longNameAsWell + } = [possiblyLongName, anotherLongName, longNameAsWell] + +y :: Int -> Int -> Int -> Foo +y possiblyLongName anotherLongName longNameAsWell = + Foo + { a = possiblyLongName + , b = anotherLongName + , c = longNameAsWell + } diff --git a/data/fourmolu/record-style/output-aligned-trailing.hs b/data/fourmolu/record-style/output-aligned-trailing.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/record-style/output-aligned-trailing.hs @@ -0,0 +1,35 @@ +data Foo = Foo + { a :: Int, + b :: Int, + c :: Int + } + +-- Test nesting +data Client + = PremiumClient + { name :: String, + address :: String, + aFieldWithAnUnneccessarilyLongFieldName :: String + } + | -- And some comment here as well + NotSoPremiumClient + { name :: String, + address :: String, + aFieldWithAnUnneccessarilyLongFieldName :: String + } + +x :: Foo -> [Int] +x + Foo + { a = possiblyLongName, + b = anotherLongName, + c = longNameAsWell + } = [possiblyLongName, anotherLongName, longNameAsWell] + +y :: Int -> Int -> Int -> Foo +y possiblyLongName anotherLongName longNameAsWell = + Foo + { a = possiblyLongName, + b = anotherLongName, + c = longNameAsWell + } diff --git a/data/fourmolu/record-style/output-knr-leading.hs b/data/fourmolu/record-style/output-knr-leading.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/record-style/output-knr-leading.hs @@ -0,0 +1,35 @@ +data Foo = Foo { + a :: Int + , b :: Int + , c :: Int + } + +-- Test nesting +data Client + = PremiumClient { + name :: String + , address :: String + , aFieldWithAnUnneccessarilyLongFieldName :: String + } + | -- And some comment here as well + NotSoPremiumClient { + name :: String + , address :: String + , aFieldWithAnUnneccessarilyLongFieldName :: String + } + +x :: Foo -> [Int] +x + Foo { + a = possiblyLongName + , b = anotherLongName + , c = longNameAsWell + } = [possiblyLongName, anotherLongName, longNameAsWell] + +y :: Int -> Int -> Int -> Foo +y possiblyLongName anotherLongName longNameAsWell = + Foo { + a = possiblyLongName + , b = anotherLongName + , c = longNameAsWell + } diff --git a/data/fourmolu/record-style/output-knr-trailing.hs b/data/fourmolu/record-style/output-knr-trailing.hs new file mode 100644 --- /dev/null +++ b/data/fourmolu/record-style/output-knr-trailing.hs @@ -0,0 +1,35 @@ +data Foo = Foo { + a :: Int, + b :: Int, + c :: Int +} + +-- Test nesting +data Client + = PremiumClient { + name :: String, + address :: String, + aFieldWithAnUnneccessarilyLongFieldName :: String + } + | -- And some comment here as well + NotSoPremiumClient { + name :: String, + address :: String, + aFieldWithAnUnneccessarilyLongFieldName :: String + } + +x :: Foo -> [Int] +x + Foo { + a = possiblyLongName, + b = anotherLongName, + c = longNameAsWell + } = [possiblyLongName, anotherLongName, longNameAsWell] + +y :: Int -> Int -> Int -> Foo +y possiblyLongName anotherLongName longNameAsWell = + Foo { + a = possiblyLongName, + b = anotherLongName, + c = longNameAsWell + } diff --git a/data/fourmolu/unicode-syntax/output-always.hs b/data/fourmolu/unicode-syntax/output-always.hs --- a/data/fourmolu/unicode-syntax/output-always.hs +++ b/data/fourmolu/unicode-syntax/output-always.hs @@ -55,8 +55,8 @@ deconstruct (MkT1 x) = x pattern HeadC x ← x : xs - where - HeadC x = [x] + where + HeadC x = [x] pattern Point ∷ Int → Int → (Int, Int) pattern Point{x, y} = (x, y) diff --git a/data/fourmolu/unicode-syntax/output-detect.hs b/data/fourmolu/unicode-syntax/output-detect.hs --- a/data/fourmolu/unicode-syntax/output-detect.hs +++ b/data/fourmolu/unicode-syntax/output-detect.hs @@ -55,8 +55,8 @@ deconstruct (MkT1 x) = x pattern HeadC x ← x : xs - where - HeadC x = [x] + where + HeadC x = [x] pattern Point ∷ Int → Int → (Int, Int) pattern Point{x, y} = (x, y) diff --git a/data/fourmolu/unicode-syntax/output-never.hs b/data/fourmolu/unicode-syntax/output-never.hs --- a/data/fourmolu/unicode-syntax/output-never.hs +++ b/data/fourmolu/unicode-syntax/output-never.hs @@ -55,8 +55,8 @@ deconstruct (MkT1 x) = x pattern HeadC x <- x : xs - where - HeadC x = [x] + where + HeadC x = [x] pattern Point :: Int -> Int -> (Int, Int) pattern Point{x, y} = (x, y) diff --git a/fourmolu.cabal b/fourmolu.cabal --- a/fourmolu.cabal +++ b/fourmolu.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: fourmolu -version: 0.19.0.1 +version: 0.20.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: @@ -8,9 +8,9 @@ George Thomas Brandon Chinn tested-with: - ghc ==9.8.4 - ghc ==9.10.1 - ghc ==9.12.1 + ghc ==9.10.2 + ghc ==9.12.2 + ghc ==9.14.1 homepage: https://github.com/fourmolu/fourmolu bug-reports: https://github.com/fourmolu/fourmolu/issues @@ -84,6 +84,7 @@ Ormolu.Printer.Meat.Module Ormolu.Printer.Meat.Pragma Ormolu.Printer.Meat.Type + Ormolu.Printer.Meat.Type.Function Ormolu.Printer.Operators Ormolu.Printer.SpanStream Ormolu.Processing.Common @@ -100,7 +101,7 @@ other-modules: GHC.DynFlags default-language: GHC2021 build-depends: - Cabal-syntax >=3.14 && <3.15, + Cabal-syntax >=3.16 && <3.17, Diff >=0.4 && <2, MemoTrie >=0.6 && <0.7, ansi-terminal >=0.10 && <1.2, @@ -109,11 +110,11 @@ binary >=0.8 && <0.9, bytestring >=0.2 && <0.13, choice >=0.2.4.1 && <0.3, - containers >=0.5 && <0.8, + containers >=0.5 && <0.9, directory ^>=1.3, file-embed >=0.0.15 && <0.1, filepath >=1.2 && <1.6, - ghc-lib-parser >=9.12 && <9.13, + ghc-lib-parser >=9.14 && <9.15, megaparsec >=9, mtl >=2 && <3, syb >=0.7 && <0.8, @@ -152,13 +153,13 @@ autogen-modules: Paths_fourmolu default-language: GHC2021 build-depends: - Cabal-syntax >=3.14 && <3.15, + Cabal-syntax >=3.16 && <3.17, base >=4.12 && <5, - containers >=0.5 && <0.8, + containers >=0.5 && <0.9, directory ^>=1.3, filepath >=1.2 && <1.6, - ghc-lib-parser >=9.12 && <9.13, - optparse-applicative >=0.14 && <0.19, + ghc-lib-parser >=9.14 && <9.15, + optparse-applicative >=0.14 && <0.20, text >=2.1 && <3, th-env >=0.1.1 && <0.2, unliftio >=0.2.10 && <0.3, @@ -210,14 +211,14 @@ default-language: GHC2021 build-depends: - Cabal-syntax >=3.14 && <3.15, + Cabal-syntax >=3.16 && <3.17, QuickCheck >=2.14, base >=4.14 && <5, choice >=0.2.4.1 && <0.3, - containers >=0.5 && <0.8, + containers >=0.5 && <0.9, directory ^>=1.3, filepath >=1.2 && <1.6, - ghc-lib-parser >=9.12 && <9.13, + ghc-lib-parser >=9.14 && <9.15, hspec >=2 && <3, hspec-megaparsec >=2.2, megaparsec >=9, diff --git a/fourmolu.yaml b/fourmolu.yaml --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -5,6 +5,7 @@ column-limit: none function-arrows: trailing comma-style: trailing +record-style: aligned import-export-style: trailing import-grouping: legacy indent-wheres: true diff --git a/src/GHC/DynFlags.hs b/src/GHC/DynFlags.hs --- a/src/GHC/DynFlags.hs +++ b/src/GHC/DynFlags.hs @@ -7,10 +7,12 @@ ) where +import GHC.Data.FastString import GHC.Driver.Session import GHC.Platform import GHC.Settings import GHC.Settings.Config +import GHC.Unit.Types import GHC.Utils.Fingerprint fakeSettings :: Settings @@ -43,6 +45,10 @@ platform_constants = Nothing }, sPlatformMisc = PlatformMisc {}, + sUnitSettings = + UnitSettings + { unitSettings_baseUnitId = UnitId $ fsLit "ormolu" + }, sToolSettings = ToolSettings { toolSettings_opt_P_fingerprint = fingerprint0, diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -35,6 +35,7 @@ fillMissingPrinterOpts, resolvePrinterOpts, CommaStyle (..), + RecordStyle (..), FunctionArrowsStyle (..), HaddockPrintStyle (..), HaddockPrintStyleModule (..), @@ -43,12 +44,13 @@ ImportGrouping (..), ImportGroup (..), ImportGroupRule (..), - ImportModuleMatcher (..), ImportRulePriority (..), matchAllRulePriority, matchLocalRulePriority, defaultImportRulePriority, + ImportListMatcher (..), QualifiedImportMatcher (..), + ImportScopeMatcher (..), LetStyle (..), InStyle (..), IfStyle (..), diff --git a/src/Ormolu/Config/Gen.hs b/src/Ormolu/Config/Gen.hs --- a/src/Ormolu/Config/Gen.hs +++ b/src/Ormolu/Config/Gen.hs @@ -9,6 +9,7 @@ module Ormolu.Config.Gen ( PrinterOpts (..) , CommaStyle (..) + , RecordStyle (..) , FunctionArrowsStyle (..) , HaddockPrintStyle (..) , HaddockPrintStyleModule (..) @@ -54,6 +55,8 @@ poFunctionArrows :: f FunctionArrowsStyle , -- | How to place commas in multi-line lists, records, etc. poCommaStyle :: f CommaStyle + , -- | How to place braces in records + poRecordStyle :: f RecordStyle , -- | Styling of import/export lists poImportExportStyle :: f ImportExportStyle , -- | Rules for grouping import declarations @@ -102,6 +105,7 @@ , poColumnLimit = Nothing , poFunctionArrows = Nothing , poCommaStyle = Nothing + , poRecordStyle = Nothing , poImportExportStyle = Nothing , poImportGrouping = Nothing , poIndentWheres = Nothing @@ -130,6 +134,7 @@ , poColumnLimit = pure NoLimit , poFunctionArrows = pure TrailingArrows , poCommaStyle = pure Leading + , poRecordStyle = pure RecordStyleAligned , poImportExportStyle = pure ImportExportDiffFriendly , poImportGrouping = pure ImportGroupLegacy , poIndentWheres = pure False @@ -165,6 +170,7 @@ , poColumnLimit = maybe (poColumnLimit p2) pure (poColumnLimit p1) , poFunctionArrows = maybe (poFunctionArrows p2) pure (poFunctionArrows p1) , poCommaStyle = maybe (poCommaStyle p2) pure (poCommaStyle p1) + , poRecordStyle = maybe (poRecordStyle p2) pure (poRecordStyle p1) , poImportExportStyle = maybe (poImportExportStyle p2) pure (poImportExportStyle p1) , poImportGrouping = maybe (poImportGrouping p2) pure (poImportGrouping p1) , poIndentWheres = maybe (poIndentWheres p2) pure (poIndentWheres p1) @@ -209,6 +215,10 @@ "How to place commas in multi-line lists, records, etc. (choices: \"leading\" or \"trailing\") (default: leading)" "OPTION" <*> f + "record-style" + "How to place braces in records (choices: \"aligned\" or \"knr\") (default: aligned)" + "OPTION" + <*> f "import-export-style" "Styling of import/export lists (choices: \"leading\", \"trailing\", or \"diff-friendly\") (default: diff-friendly)" "OPTION" @@ -295,6 +305,7 @@ <*> f "column-limit" <*> f "function-arrows" <*> f "comma-style" + <*> f "record-style" <*> f "import-export-style" <*> f "import-grouping" <*> f "indent-wheres" @@ -348,6 +359,11 @@ | Trailing deriving (Eq, Show, Enum, Bounded) +data RecordStyle + = RecordStyleAligned + | RecordStyleKnr + deriving (Eq, Show, Enum, Bounded) + data FunctionArrowsStyle = TrailingArrows | LeadingArrows @@ -450,6 +466,28 @@ Leading -> "leading" Trailing -> "trailing" +instance Aeson.FromJSON RecordStyle where + parseJSON = + Aeson.withText "RecordStyle" $ \s -> + either Aeson.parseFail pure $ + parsePrinterOptType (Text.unpack s) + +instance PrinterOptsFieldType RecordStyle where + parsePrinterOptType s = + case s of + "aligned" -> Right RecordStyleAligned + "knr" -> Right RecordStyleKnr + _ -> + Left . unlines $ + [ "unknown value: " <> show s + , "Valid values are: \"aligned\" or \"knr\"" + ] + +instance RenderPrinterOpt RecordStyle where + renderPrinterOpt = \case + RecordStyleAligned -> "aligned" + RecordStyleKnr -> "knr" + instance Aeson.FromJSON FunctionArrowsStyle where parseJSON = Aeson.withText "FunctionArrowsStyle" $ \s -> @@ -776,6 +814,9 @@ , "" , "# How to place commas in multi-line lists, records, etc. (choices: leading or trailing)" , "comma-style: leading" + , "" + , "# How to place braces in records (choices: aligned or knr)" + , "record-style: aligned" , "" , "# Styling of import/export lists (choices: leading, trailing, or diff-friendly)" , "import-export-style: diff-friendly" diff --git a/src/Ormolu/Config/Types.hs b/src/Ormolu/Config/Types.hs --- a/src/Ormolu/Config/Types.hs +++ b/src/Ormolu/Config/Types.hs @@ -1,20 +1,22 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Ormolu.Config.Types ( ImportGroup (..), ImportGroupRule (..), - ImportModuleMatcher (..), ImportRulePriority (..), matchAllRulePriority, matchLocalRulePriority, defaultImportRulePriority, + ImportListMatcher (..), QualifiedImportMatcher (..), + ImportScopeMatcher (..), ) where -import Control.Applicative (Alternative (..), asum) -import Data.Aeson ((.!=), (.:), (.:?)) +import Control.Applicative (Alternative (..)) +import Data.Aeson ((.!=), (.:?)) import Data.Aeson qualified as Aeson import Data.Aeson.Types qualified as Aeson import Data.List.NonEmpty (NonEmpty) @@ -34,28 +36,47 @@ <*> Aeson.parseField o "rules" data ImportGroupRule = ImportGroupRule - { igrModuleMatcher :: !ImportModuleMatcher, + { igrGlob :: !Glob, + igrImportListMatcher :: !ImportListMatcher, igrQualifiedMatcher :: !QualifiedImportMatcher, + igrScopeMatcher :: !ImportScopeMatcher, igrPriority :: !ImportRulePriority } deriving (Eq, Show) instance Aeson.FromJSON ImportGroupRule where parseJSON = Aeson.withObject "rule" $ \o -> do - let parseModuleMatcher = Aeson.parseJSON (Aeson.Object o) - failUnknownModuleMatcher = Aeson.parseFail "Unknown or invalid module matcher" - attemptParseModuleMatcher = parseModuleMatcher <|> failUnknownModuleMatcher - igrModuleMatcher <- attemptParseModuleMatcher + legacyMatch <- o .:? "match" + (defaultPriority, defaultScope) <- case legacyMatch of + Just "all" -> pure (matchAllRulePriority, pure MatchAllModules) + Just "local-modules" -> pure (matchLocalRulePriority, pure MatchLocalModules) + Just other -> Aeson.parseFail $ "Unknown legacy match value: " <> other + Nothing -> pure (defaultImportRulePriority, empty) - qualified <- o .:? "qualified" - igrQualifiedMatcher <- case qualified of - Just True -> pure MatchQualifiedOnly - Just False -> pure MatchUnqualifiedOnly - Nothing -> pure MatchBothQualifiedAndUnqualified + igrGlob <- mkGlob <$> o .:? "glob" .!= "**" - let defaultPriority - | MatchAllModules <- igrModuleMatcher = matchAllRulePriority - | otherwise = defaultImportRulePriority + igrImportListMatcher <- + o .:? "import-list" .!= "any" >>= \case + "any" -> pure MatchAnyImportDeclaration + "explicit" -> pure MatchExplicitImportList + "hiding" -> pure MatchHidingImportClause + "none" -> pure MatchWholeModuleImport + other -> Aeson.parseFail $ "Unknown import list matcher: " <> other + + igrQualifiedMatcher <- + o .:? "qualified" >>= \case + Just True -> pure MatchQualifiedOnly + Just False -> pure MatchUnqualifiedOnly + Nothing -> pure MatchBothQualifiedAndUnqualified + + igrScopeMatcher <- + o .:? "scope" >>= \case + Just "any" -> pure MatchAllModules + Just "local" -> pure MatchLocalModules + Just "external" -> pure MatchExternalModules + Nothing -> defaultScope <|> pure MatchAllModules + Just other -> Aeson.parseFail ("Unknown scope matcher: " <> other) + igrPriority <- o .:? "priority" .!= defaultPriority pure ImportGroupRule {..} @@ -75,35 +96,21 @@ defaultImportRulePriority :: ImportRulePriority defaultImportRulePriority = ImportRulePriority 50 +data ImportListMatcher + = MatchExplicitImportList + | MatchHidingImportClause + | MatchWholeModuleImport + | MatchAnyImportDeclaration + deriving (Eq, Show) + data QualifiedImportMatcher = MatchQualifiedOnly | MatchUnqualifiedOnly | MatchBothQualifiedAndUnqualified deriving (Eq, Show) -data ImportModuleMatcher - = MatchAllModules +data ImportScopeMatcher + = MatchExternalModules | MatchLocalModules - | MatchGlob !Glob + | MatchAllModules deriving (Eq, Show) - -instance Aeson.FromJSON ImportModuleMatcher where - parseJSON v = - asum - [ parseMatchModuleMatcher v, - parseGlobModuleMatcher v - ] - where - parseMatchModuleMatcher :: Aeson.Value -> Aeson.Parser ImportModuleMatcher - parseMatchModuleMatcher = Aeson.withObject "ImportModuleMatcher" $ \o -> do - c <- Aeson.parseField @String o "match" - case c of - "all" -> pure MatchAllModules - "local-modules" -> pure MatchLocalModules - other -> Aeson.parseFail $ "Unknown matcher: " <> other - - parseGlobModuleMatcher :: Aeson.Value -> Aeson.Parser ImportModuleMatcher - parseGlobModuleMatcher = Aeson.withObject "ImportModuleMatcher" $ \o -> do - rawGlob <- o .: "glob" - let glob = mkGlob rawGlob - pure (MatchGlob glob) diff --git a/src/Ormolu/Diff/ParseResult.hs b/src/Ormolu/Diff/ParseResult.hs --- a/src/Ormolu/Diff/ParseResult.hs +++ b/src/Ormolu/Diff/ParseResult.hs @@ -106,11 +106,13 @@ `extQ` considerEqual @EpLayout `extQ` considerEqual @AnnSig `extQ` considerEqual @HsRuleAnn - `extQ` considerEqual @EpLinearArrow + `extQ` considerEqual @EpLinear `extQ` considerEqual @AnnSynDecl `extQ` considerEqual @IsUnicodeSyntax -- FastString (for example for string literals) `extQ` considerEqualVia' ((==) @FastString) + -- ModuleName is a newtype of FastString + `extQ` considerEqualVia' ((==) @ModuleName) -- Haddock strings `extQ` hsDocStringEq -- Whether imports are pre- or post-qualified @@ -170,6 +172,7 @@ epAnnEq :: EpAnn a -> b -> ParseResultDiff epAnnEq _ _ = Same + importDeclQualifiedStyleEq :: forall a. (Data a) => ImportDeclQualifiedStyle -> a -> ParseResultDiff importDeclQualifiedStyleEq = considerEqualVia' f where f QualifiedPre QualifiedPost = True @@ -177,7 +180,7 @@ f x x' = x == x' hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff - hsDocStringEq = considerEqualVia' ((==) `on` (map (T.dropWhile isSpace) . splitDocString True)) + hsDocStringEq = considerEqualVia' ((==) `on` (map (T.dropWhile isSpace) . splitDocString)) forLocated :: (Data e0, Data e1) => diff --git a/src/Ormolu/Diff/Text.hs b/src/Ormolu/Diff/Text.hs --- a/src/Ormolu/Diff/Text.hs +++ b/src/Ormolu/Diff/Text.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QualifiedDo #-} @@ -24,9 +23,6 @@ import GHC.Types.SrcLoc import Ormolu.Terminal import Ormolu.Terminal.QualifiedDo qualified as Term -#if !MIN_VERSION_base(4,20,0) -import Data.List (foldl') -#endif ---------------------------------------------------------------------------- -- Types diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -28,11 +27,8 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Config (ImportGrouping) -import Ormolu.Imports.Grouping (Import (..), groupImports, prepareExistingGroups) +import Ormolu.Imports.Grouping (Import (..), ImportList (..), groupImports, prepareExistingGroups) import Ormolu.Utils (notImplemented, showOutputable) -#if !MIN_VERSION_base(4,20,0) -import Data.List (foldl') -#endif -- | Sort, group and normalize imports. -- @@ -51,7 +47,15 @@ . prepareExistingGroups importGrouping respectful where toImport :: (ImportId, x) -> Import - toImport (ImportId {..}, _) = Import {importName = importIdName, importQualified} + toImport (ImportId {..}, _) = + Import + { importName = importIdName, + importList = case importHiding of + Just (ImportListInterpretationOrd Exactly) -> Just ImportList + Just (ImportListInterpretationOrd EverythingBut) -> Just HidingList + Nothing -> Nothing, + importQualified + } g :: LImportDecl GhcPs -> LImportDecl GhcPs g (L l ImportDecl {..}) = @@ -90,10 +94,23 @@ importSafe :: Bool, importQualified :: Bool, importAs :: Maybe ModuleName, - importHiding :: Maybe ImportListInterpretationOrd + importHiding :: Maybe ImportListInterpretationOrd, + importLevel :: Maybe ImportDeclLevelOrd } deriving (Eq, Ord) +-- | A wrapper for 'ImportDeclLevel' that provides an 'Ord' instance. +newtype ImportDeclLevelOrd = ImportDeclLevelOrd + { unImportDeclLevelOrd :: ImportDeclLevel + } + deriving stock (Eq) + +instance Ord ImportDeclLevelOrd where + compare = compare `on` toBool . unImportDeclLevelOrd + where + toBool ImportDeclSplice = False + toBool ImportDeclQuote = True + data ImportPkgQual = -- | The import is not qualified by a package name. NoImportPkgQual @@ -137,11 +154,16 @@ QualifiedPost -> True NotQualified -> False, importAs = unLoc <$> ideclAs, - importHiding = ImportListInterpretationOrd . fst <$> ideclImportList + importHiding = ImportListInterpretationOrd . fst <$> ideclImportList, + importLevel = importLevelOf ideclLevelSpec } where isPrelude = moduleNameString moduleName == "Prelude" moduleName = unLoc ideclName + importLevelOf = \case + LevelStylePre l -> Just (ImportDeclLevelOrd l) + LevelStylePost l -> Just (ImportDeclLevelOrd l) + NotLevelled -> Nothing -- | Normalize a collection of import items. normalizeLies :: [LIE GhcPs] -> [LIE GhcPs] @@ -231,6 +253,7 @@ IEDefault _ x -> (1, x) IEPattern _ x -> (2, x) IEType _ x -> (3, x) + IEData _ x -> (4, x) compareRdrName :: RdrName -> RdrName -> Ordering compareRdrName x y = diff --git a/src/Ormolu/Imports/Grouping.hs b/src/Ormolu/Imports/Grouping.hs --- a/src/Ormolu/Imports/Grouping.hs +++ b/src/Ormolu/Imports/Grouping.hs @@ -3,6 +3,7 @@ module Ormolu.Imports.Grouping ( Import (..), + ImportList (..), prepareExistingGroups, groupImports, ) @@ -19,18 +20,24 @@ import Distribution.ModuleName qualified as Cabal import GHC.Hs (GhcPs, getLocA) import Language.Haskell.Syntax (LImportDecl, ModuleName, moduleNameString) -import Ormolu.Config (ImportGroup (..), ImportGroupRule (..), ImportGrouping (..), ImportModuleMatcher (..)) +import Ormolu.Config (ImportGroup (..), ImportGroupRule (..), ImportGrouping (..)) import Ormolu.Config qualified as Config import Ormolu.Utils (ghcModuleNameToCabal, groupBy', separatedByBlank) -import Ormolu.Utils.Glob (matchesGlob) +import Ormolu.Utils.Glob (matchAllGlob, matchesGlob) newtype ImportGroups = ImportGroups (NonEmpty ImportGroup) data Import = Import { importName :: ModuleName, + importList :: Maybe ImportList, importQualified :: Bool } +data ImportList + = ImportList + | HidingList + deriving (Eq) + importGroupSingleStrategy :: ImportGroups importGroupSingleStrategy = ImportGroups $ @@ -94,16 +101,20 @@ matchAllImportRule :: ImportGroupRule matchAllImportRule = ImportGroupRule - { igrModuleMatcher = MatchAllModules, + { igrGlob = matchAllGlob, + igrImportListMatcher = Config.MatchAnyImportDeclaration, igrQualifiedMatcher = Config.MatchBothQualifiedAndUnqualified, + igrScopeMatcher = Config.MatchAllModules, igrPriority = Config.matchAllRulePriority } matchLocalModulesRule :: ImportGroupRule matchLocalModulesRule = ImportGroupRule - { igrModuleMatcher = MatchLocalModules, + { igrGlob = matchAllGlob, + igrImportListMatcher = Config.MatchAnyImportDeclaration, igrQualifiedMatcher = Config.MatchBothQualifiedAndUnqualified, + igrScopeMatcher = Config.MatchLocalModules, igrPriority = Config.matchLocalRulePriority } @@ -122,16 +133,30 @@ } matchesRule :: Set Cabal.ModuleName -> Import -> ImportGroupRule -> Bool -matchesRule localMods Import {..} ImportGroupRule {..} = matchesModules && matchesQualified +matchesRule localMods Import {..} ImportGroupRule {..} = + and + [ matchingGlob, + matchingImportList, + matchingQualified, + matchingScope + ] where - matchesModules = case igrModuleMatcher of - MatchAllModules -> True - MatchLocalModules -> ghcModuleNameToCabal importName `Set.member` localMods - MatchGlob gl -> moduleNameString importName `matchesGlob` gl - matchesQualified = case igrQualifiedMatcher of + matchingGlob = moduleNameString importName `matchesGlob` igrGlob + matchingImportList = case igrImportListMatcher of + Config.MatchExplicitImportList -> importList == Just ImportList + Config.MatchHidingImportClause -> importList == Just HidingList + Config.MatchWholeModuleImport -> importList == Nothing + Config.MatchAnyImportDeclaration -> True + matchingQualified = case igrQualifiedMatcher of Config.MatchQualifiedOnly -> importQualified Config.MatchUnqualifiedOnly -> not importQualified Config.MatchBothQualifiedAndUnqualified -> True + matchingScope = + let isLocalModule = ghcModuleNameToCabal importName `Set.member` localMods + in case igrScopeMatcher of + Config.MatchAllModules -> True + Config.MatchExternalModules -> not isLocalModule + Config.MatchLocalModules -> isLocalModule prepareExistingGroups :: ImportGrouping -> Bool -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]] prepareExistingGroups ig respectful = diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -30,7 +30,7 @@ import GHC.Data.FastString qualified as GHC import GHC.Data.Maybe (orElse) import GHC.Data.StringBuffer (StringBuffer) -import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Parser (initParserOpts, supportedLanguagePragmas) import GHC.Driver.Errors.Types qualified as GHC import GHC.Driver.Session as GHC import GHC.DynFlags (baseDynFlags) @@ -45,6 +45,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Error import GHC.Utils.Exception (ExceptionMonad) +import GHC.Utils.Logger (initLogger) import GHC.Utils.Panic qualified as GHC import Ormolu.Config import Ormolu.Config.Gen (SingleConstraintParens (..)) @@ -317,10 +318,14 @@ let (_warnings, fileOpts) = GHC.getOptions (initParserOpts flags) + (supportedLanguagePragmas flags) input filepath + -- 'initLogger' does not have any hooks installed, so we don't get any + -- (unwanted) output. + logger <- initLogger (flags', leftovers, warnings) <- - parseDynamicFilePragma flags (extraOpts <> fileOpts) + parseDynamicFilePragma logger flags (extraOpts <> fileOpts) case NE.nonEmpty leftovers of Nothing -> return () Just unrecognizedOpts -> diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -24,6 +24,7 @@ newline, declNewline, multilineCommentNewline, + newlineLiteral, inci, inciBy, inciIf, @@ -48,6 +49,7 @@ -- ** Formatting lists sep, sepSemi, + sepSemi', canUseBraces, useBraces, dontUseBraces, @@ -58,6 +60,7 @@ backticks, banana, braces, + recordBraces, brackets, parens, parensHash, @@ -256,7 +259,25 @@ -- | Elements to render [a] -> R () -sepSemi f xs = vlayout singleLine multiLine +sepSemi = sepSemi' False + +-- | A version of 'sepSemi' that allows to control whether semicolons should +-- be inserted in multi-line layout. +-- +-- > useBraces $ sepSemi' False txt ["foo", "bar"] +-- > == vlayout (txt "{ foo; bar }") (txt "foo\nbar") +-- +-- > dontUseBraces $ sepSemi' True txt ["foo", "bar"] +-- > == vlayout (txt "foo; bar") (txt "foo;\nbar") +sepSemi' :: + -- | Whether to insert semicolons in multi-line layout + Bool -> + -- | How to render an element + (a -> R ()) -> + -- | Elements to render + [a] -> + R () +sepSemi' addMultiColSemi f xs = vlayout singleLine multiLine where singleLine = do ub <- canUseBraces @@ -272,7 +293,10 @@ txt "}" else sep (txt ";" >> space) f xs' multiLine = - sep newline (dontUseBraces . f) xs + sep + (if addMultiColSemi then txt ";" >> newline else newline) + (dontUseBraces . f) + xs ---------------------------------------------------------------------------- -- Wrapping @@ -368,6 +392,31 @@ else space >> sitcc m newline inciIf (style == S) close + +-- With leading commas align the close brace with commas +-- otherwise move the close brace back to the left +recordBraces :: R () -> R () +recordBraces m = do + commaStyle <- getPrinterOpt poCommaStyle + recordBraces_ (commaStyle == Trailing) m + +recordBraces_ :: Bool -> R () -> R () +recordBraces_ moveBraceBack m = do + style <- getPrinterOpt poRecordStyle + case style of + RecordStyleAligned -> braces N m + RecordStyleKnr -> + vlayout + (txt "{" >> m >> txt "}") + ( do + txt "{" + newline + sitcc m + newline + if moveBraceBack + then inciByFrac (-1) (txt "}") + else txt "}" + ) ---------------------------------------------------------------------------- -- Literals diff --git a/src/Ormolu/Printer/Internal.hs b/src/Ormolu/Printer/Internal.hs --- a/src/Ormolu/Printer/Internal.hs +++ b/src/Ormolu/Printer/Internal.hs @@ -20,6 +20,7 @@ newline, declNewline, multilineCommentNewline, + newlineLiteral, askSourceType, askModuleFixityMap, askDebug, @@ -437,6 +438,19 @@ VeryBeginning -> VeryBeginning _ -> AfterNewline } + +-- | Insert a newline literal without modifying the internal state of the +-- parser. This is to be used exceptionally, e.g. for printing multiline +-- string literals. +newlineLiteral :: R () +newlineLiteral = R . modify $ \sc -> + sc + { scBuilder = scBuilder sc <> "\n", + scColumn = 0, + scIndent = 0, + scThisLineSpans = [], + scRequestedDelimiter = AfterNewline + } -- | Return the source type. askSourceType :: R SourceType diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -15,6 +15,7 @@ p_hsDoc', p_sourceText, p_namespaceSpec, + p_hsMultAnn, p_arrow, ) where @@ -29,13 +30,13 @@ import GHC.Hs.Doc import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp +import GHC.Hs.Type import GHC.LanguageExtensions.Type (Extension (..)) import GHC.Parser.Annotation import GHC.Types.Name.Occurrence (OccName (..), occNameString) import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc -import Language.Haskell.Syntax (HsArrowOf (..)) import Language.Haskell.Syntax.Module.Name import Ormolu.Config import Ormolu.Printer.Combinators @@ -48,7 +49,7 @@ | -- | Top-level declarations Free --- | Outputs the name of the module-like entity, preceeded by the correct prefix ("module" or "signature"). +-- | Outputs the name of the module-like entity, preceded by the correct prefix ("module" or "signature"). p_hsmodName :: ModuleName -> R () p_hsmodName mname = do sourceType <- askSourceType @@ -73,6 +74,10 @@ txt "type" space p_rdrName x + IEData _ x -> do + txt "data" + space + p_rdrName x -- | Render a @'LocatedN' 'RdrName'@. p_rdrName :: LocatedN RdrName -> R () @@ -93,7 +98,7 @@ -- insert spaces when we have a parenthesized operator starting with `#`. handleUnboxedSumsAndHashInteraction | unboxedSums, - -- Qualified names do not start wth a `#`. + -- Qualified names do not start with a `#`. Unqual (occNameString -> '#' : _) <- x = \y -> space *> y <* space | otherwise = id @@ -190,12 +195,7 @@ -- Make sure the Haddock is separated by a newline from other comments. when goesAfterComment newline - let shouldEscapeCommentBraces = - case poHStyle of - HaddockSingleLine -> False - HaddockMultiLine -> True - HaddockMultiLineCompact -> True - let docStringLines = splitDocString shouldEscapeCommentBraces $ hsDocString str + let docStringLines = splitDocString $ hsDocString str if poHStyle == HaddockSingleLine || length docStringLines <= 1 then do @@ -242,10 +242,18 @@ TypeNamespaceSpecifier _ -> txt "type" *> space DataNamespaceSpecifier _ -> txt "data" *> space -p_arrow :: (mult -> R ()) -> HsArrowOf mult GhcPs -> R () +p_hsMultAnn :: (mult -> R ()) -> HsMultAnnOf mult GhcPs -> R () +p_hsMultAnn p_mult = \case + HsUnannotated _ -> pure () + HsLinearAnn _ -> txt "%1" + HsExplicitMult _ mult -> txt "%" *> p_mult mult + +-- | Like 'p_hsMultAnn', except specifically for arrows, taking -XUnicodeSyntax +-- into account. +p_arrow :: (mult -> R ()) -> HsMultAnnOf mult GhcPs -> R () p_arrow p_mult = \case - HsUnrestrictedArrow _ -> token'rarrow - HsLinearArrow _ -> token'lolly + HsUnannotated _ -> token'rarrow + HsLinearAnn _ -> token'lolly HsExplicitMult _ mult -> do txt "%" p_mult mult diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -256,7 +256,7 @@ TypeSynonym :: RdrName -> HsDecl GhcPs pattern InlinePragma n <- SigD _ (InlineSig _ (L _ n) _) -pattern SpecializePragma n <- SigD _ (SpecSig _ (L _ n) _ _) +pattern SpecializePragma n <- SigD _ (isSpecSig -> Just n) pattern SCCPragma n <- SigD _ (SCCFunSig _ (L _ n) _) pattern AnnTypePragma n <- AnnD _ (HsAnnotation _ (TypeAnnProvenance (L _ n)) _) pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ (ValueAnnProvenance (L _ n)) _) @@ -266,6 +266,12 @@ pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _) pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _)) pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _) + +isSpecSig :: Sig GhcPs -> Maybe RdrName +isSpecSig = \case + SpecSig _ (L _ n) _ _ -> Just n + SpecSigE _ _ (deconstructExprFromSpecSigE -> (L _ n, _, _)) _ -> Just n + _ -> Nothing -- Declarations which can refer to multiple names diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs @@ -3,9 +3,12 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | Renedring of data type declarations. module Ormolu.Printer.Meat.Declaration.Data @@ -21,7 +24,6 @@ import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust, isNothing, maybeToList) import Data.Text qualified as Text -import Data.Void import GHC.Hs import GHC.Types.Fixity import GHC.Types.ForeignCall @@ -154,7 +156,7 @@ deriving (Eq, Ord) p_conDecl :: Choice "singleRecCon" -> ConDecl GhcPs -> R () -p_conDecl _ ConDeclGADT {..} = do +p_conDecl _ decl@ConDeclGADT {..} = do mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc switchLayout conDeclSpn $ do let c :| cs = con_names @@ -162,61 +164,42 @@ unless (null cs) . inci $ do commaDel sep commaDel p_rdrName cs - inci $ do - let conTy = case con_g_args of - PrefixConGADT NoExtField xs -> - let go (HsScaled a b) t = addCLocA t b (HsFunTy NoExtField a b t) - in foldr go con_res_ty xs - RecConGADT _ r -> - addCLocA r con_res_ty $ - HsFunTy - NoExtField - (HsUnrestrictedArrow noAnn) - (la2la $ HsRecTy noAnn <$> r) - con_res_ty - qualTy = case con_mb_cxt of - Nothing -> conTy - Just qs -> - addCLocA qs conTy $ - HsQualTy NoExtField qs conTy - quantifiedTy :: LHsType GhcPs - quantifiedTy = - addCLocA con_bndrs qualTy $ - hsOuterTyVarBndrsToHsType (unLoc con_bndrs) qualTy - p_hsTypeAnnotation quantifiedTy + inci $ p_hsFun decl where conDeclSpn = - fmap getLocA (NE.toList con_names) - <> [getLocA con_bndrs] + fmap getLocA (NE.toList con_names) <> conSigSpans + conSigSpans = + [getLocA con_outer_bndrs] <> maybeToList (fmap getLocA con_mb_cxt) - <> conArgsSpans - conArgsSpans = case con_g_args of - PrefixConGADT NoExtField xs -> getLocA . hsScaledThing <$> xs - RecConGADT _ x -> [getLocA x] + <> conArgResSpans + conArgResSpans = + getLocA con_res_ty : case con_g_args of + PrefixConGADT NoExtField xs -> getLocA . cdf_type <$> xs + RecConGADT _ x -> [getLocA x] p_conDecl singleRecCon ConDeclH98 {..} = case con_args of - PrefixCon (_ :: [Void]) xs -> do + PrefixCon xs -> do renderConDoc renderContext switchLayout conDeclSpn $ do p_rdrName con_name - let args = hsScaledThing <$> xs - argsHaveDocs = conArgsHaveHaddocks args + let argsHaveDocs = conArgsHaveHaddocks xs delimiter = if argsHaveDocs then newline else breakpoint unless (null xs) delimiter inci . sitcc $ - sep delimiter (sitcc . located' p_hsType) args + sep delimiter (sitcc . p_hsConDeclFieldWithDoc) xs RecCon l -> do renderConDoc renderContext switchLayout conDeclSpn $ do p_rdrName con_name - breakpoint - inciIf (Choice.isFalse singleRecCon) (located l p_conDeclFields) - InfixCon (HsScaled _ l) (HsScaled _ r) -> do + recordStyle <- getPrinterOpt poRecordStyle + if recordStyle == RecordStyleKnr then space else breakpoint + inciIf (Choice.isFalse singleRecCon) (located l p_hsConDeclRecFields) + InfixCon l r -> do -- manually render these - let (lType, larg_doc) = splitDocTy l - let (rType, rarg_doc) = splitDocTy r + let larg_doc = cdf_doc l + rarg_doc = cdf_doc r -- the constructor haddock can go on top of the entire constructor -- only if neither argument has haddocks @@ -229,10 +212,10 @@ if isJust con_doc then do mapM_ (p_hsDoc Pipe (With #endNewline)) larg_doc - located lType p_hsType + p_hsConDeclField l breakpoint else do - located lType p_hsType + p_hsConDeclField l case larg_doc of Just doc -> space >> p_hsDoc Caret (With #endNewline) doc Nothing -> breakpoint @@ -242,7 +225,7 @@ case rarg_doc of Just doc -> newline >> p_hsDoc Pipe (With #endNewline) doc Nothing -> breakpoint - located rType p_hsType + p_hsConDeclField r where renderConDoc = mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc renderContext = @@ -262,13 +245,9 @@ conDeclSpn = conNameSpn : conArgsSpans conNameSpn = getLocA con_name conArgsSpans = case con_args of - PrefixCon (_ :: [Void]) xs -> getLocA . hsScaledThing <$> xs + PrefixCon xs -> getLocA . cdf_type <$> xs RecCon l -> [getLocA l] - InfixCon x y -> getLocA . hsScaledThing <$> [x, y] - - splitDocTy = \case - L _ (HsDocTy _ ty doc) -> (ty, Just doc) - ty -> (ty, Nothing) + InfixCon x y -> getLocA . cdf_type <$> [x, y] p_lhsContext :: LHsContext GhcPs -> @@ -337,6 +316,105 @@ located sigTy p_hsSigType ---------------------------------------------------------------------------- +-- FunRepr ConDeclGADT + +-- | ConDecl, except should only be called with the ConDeclGADT constructor. +type ConDeclGADT = ConDecl + +-- | FunRepr ConDeclGADT renders a GADT constructor type annotation, which looks +-- similar to a function type, except the arguments of the function have two +-- additional capabilities: +-- * They can specify UNPACK/strictness +-- * It can be a single argument with a record fields syntax +instance FunRepr (ConDeclGADT GhcPs) where + parseFunRepr = \case + L _ ConDeclGADT {..} -> + fst + . addSig + . addOuter con_outer_bndrs + . addInner con_inner_bndrs + . addCtx con_mb_cxt + . addArgs con_g_args + $ mkRet con_res_ty + _ -> error "parseFunRepr @ConDeclGADT unexpectedly called on non-GADT constructor" + where + addSig (next, loc) = (ParsedFunSig {sig = (), next}, loc) + addOuter (L ann bndrs) = + case bndrs :: HsOuterSigTyVarBndrs GhcPs of + HsOuterImplicit {} -> id + HsOuterExplicit _ bndrs' -> \(next, loc) -> + let loc' = combineSrcSpans loc (getHasLoc ann) + fun = + ParsedFunForall + { tele = L (l2l loc') $ mkHsForAllInvisTele noAnn bndrs', + next + } + in (fun, loc') + addInner = + let go tele (next, loc) = + let loc' = + combineSrcSpans loc $ + case tele of + HsForAllVis x _ -> getHasLoc x + HsForAllInvis x _ -> getHasLoc x + fun = ParsedFunForall {tele = L (l2l loc') tele, next} + in (fun, loc') + in foldr (\tele acc -> go tele . acc) id + addCtx = \case + Nothing -> id + Just ctxs -> \(next, loc) -> + let loc' = combineSrcSpans loc (getHasLoc ctxs) + fun = ParsedFunQuals {ctxs = [L (l2l loc') ctxs], next} + in (fun, loc') + addArgs details = + case details :: HsConDeclGADTDetails GhcPs of + PrefixConGADT _ fields -> + let go field (next, loc) = + let loc' = combineSrcSpans loc (getHasLoc field.cdf_type) + fun = + ParsedFunArg + { span = l2l loc', + arg = L noAnn (Left field), + doc = field.cdf_doc, + multAnn = field.cdf_multiplicity, + next + } + in (fun, loc') + in foldr (\field acc -> go field . acc) id fields + RecConGADT _ fields -> \(next, loc) -> + let loc' = combineSrcSpans (getHasLoc fields) loc + fun = + ParsedFunArg + { span = l2l loc', + arg = la2la $ Right <$> fields, + doc = Nothing, + multAnn = HsUnannotated (EpArrow noAnn), + next + } + in (fun, loc') + mkRet ty = + let fun = + case ty of + L _ (HsDocTy _ ret doc) -> ParsedFunReturn {ret, doc = Just doc} + ret -> ParsedFunReturn {ret, doc = Nothing} + in (fun, getHasLoc ty) + + type FunReprCtx (ConDeclGADT GhcPs) = HsType GhcPs + renderFunReprCtx = p_hsType + + -- Invariant: Exactly one of the following must be true: + -- * There's exactly one 'Right' arg + -- * There are zero or more 'Left' args + type FunReprArg (ConDeclGADT GhcPs) = Either (HsConDeclField GhcPs) [LocatedA (HsConDeclRecField GhcPs)] + renderFunReprArg = either p_hsConDeclField p_hsConDeclRecFields + + type FunReprMult (ConDeclGADT GhcPs) = HsType GhcPs + renderFunReprMult = p_hsType + + type FunReprRet (ConDeclGADT GhcPs) = HsType GhcPs + renderFunReprRet = p_hsType + +---------------------------------------------------------------------------- -- Helpers isInfix :: LexicalFixity -> Bool @@ -349,14 +427,9 @@ where f ConDeclH98 {..} = isJust con_doc || case con_args of - PrefixCon [] xs -> - conArgsHaveHaddocks (hsScaledThing <$> xs) + PrefixCon xs -> conArgsHaveHaddocks xs _ -> False f _ = False -conArgsHaveHaddocks :: [LBangType GhcPs] -> Bool -conArgsHaveHaddocks xs = - let hasDocs = \case - HsDocTy {} -> True - _ -> False - in any (hasDocs . unLoc) xs +conArgsHaveHaddocks :: [HsConDeclField GhcPs] -> Bool +conArgsHaveHaddocks = any (isJust . cdf_doc) diff --git a/src/Ormolu/Printer/Meat/Declaration/Foreign.hs b/src/Ormolu/Printer/Meat/Declaration/Foreign.hs --- a/src/Ormolu/Printer/Meat/Declaration/Foreign.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Foreign.hs @@ -9,10 +9,12 @@ import Control.Monad import GHC.Hs import GHC.Types.ForeignCall +import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Signature +import Ormolu.Printer.Meat.Declaration.StringLiteral p_foreignDecl :: ForeignDecl GhcPs -> R () p_foreignDecl = \case @@ -56,8 +58,11 @@ located cCallConv atom -- Need to check for 'noLoc' for the 'safe' annotation when (isGoodSrcSpan $ getLocA safety) (space >> atom safety) - space - located sourceText p_sourceText + inci $ located sourceText $ \case + NoSourceText -> pure () + SourceText lit -> do + breakpoint + p_stringLit lit p_foreignExport :: ForeignExport GhcPs -> R () p_foreignExport (CExport sourceText (L loc (CExportStatic _ _ cCallConv))) = do diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -138,12 +138,7 @@ putOpsExprs prevExpr (opi : ops') (expr : exprs') = do let isLast = null exprs' ub' = if not isLast then ub else id - -- Distinguish holes used in infix notation. - -- eg. '1 _foo 2' and '1 `_foo` 2' - opWrapper = case unLoc (opiOp opi) of - HsUnboundVar _ _ -> backticks - _ -> id - p_op = located (opiOp opi) (opWrapper . p_hsExpr) + p_op = located (opiOp opi) p_hsExpr p_y = ub' $ p_exprOpTree N expr if isTrailing then do diff --git a/src/Ormolu/Printer/Meat/Declaration/Rule.hs b/src/Ormolu/Printer/Meat/Declaration/Rule.hs --- a/src/Ormolu/Printer/Meat/Declaration/Rule.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Rule.hs @@ -4,16 +4,16 @@ module Ormolu.Printer.Meat.Declaration.Rule ( p_ruleDecls, + p_ruleBndrs, ) where -import Control.Monad (unless) import GHC.Hs import GHC.Types.Basic import GHC.Types.SourceText import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common -import Ormolu.Printer.Meat.Declaration.Signature +import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Signature import Ormolu.Printer.Meat.Declaration.Value import Ormolu.Printer.Meat.Type @@ -22,21 +22,12 @@ pragma "RULES" $ sep breakpoint (sitcc . located' p_ruleDecl) xs p_ruleDecl :: RuleDecl GhcPs -> R () -p_ruleDecl (HsRule _ ruleName activation tyvars ruleBndrs lhs rhs) = do +p_ruleDecl (HsRule _ ruleName activation ruleBndrs lhs rhs) = do located ruleName p_ruleName space p_activation activation space - case tyvars of - Nothing -> return () - Just xs -> do - p_forallBndrs ForAllInvis p_hsTyVarBndr xs - space - -- It appears that there is no way to tell if there was an empty forall - -- in the input or no forall at all. We do not want to add redundant - -- foralls, so let's just skip the empty ones. - unless (null ruleBndrs) $ - p_forallBndrs ForAllInvis p_ruleBndr ruleBndrs + p_ruleBndrs ruleBndrs breakpoint inci $ do located lhs p_hsExpr @@ -48,6 +39,17 @@ p_ruleName :: RuleName -> R () p_ruleName name = atom (HsString NoSourceText name :: HsLit GhcPs) + +p_ruleBndrs :: RuleBndrs GhcPs -> R () +p_ruleBndrs (RuleBndrs HsRuleBndrsAnn {..} tyvars ruleBndrs) = do + case tyvars of + Nothing -> return () + Just xs -> do + p_forallBndrs ForAllInvis p_hsTyVarBndr xs + space + case rb_tmanns of + Nothing -> pure () + Just _ -> p_forallBndrs ForAllInvis p_ruleBndr ruleBndrs p_ruleBndr :: RuleBndr GhcPs -> R () p_ruleBndr = \case diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -- | Type signature declarations. module Ormolu.Printer.Meat.Declaration.Signature @@ -8,18 +9,24 @@ p_typeAscription, p_activation, p_standaloneKindSig, + deconstructExprFromSpecSigE, ) where import Control.Monad +import Data.Maybe (maybeToList) import GHC.Data.BooleanFormula import GHC.Hs +import GHC.Stack (HasCallStack) import GHC.Types.Basic import GHC.Types.Fixity import GHC.Types.Name.Reader import GHC.Types.SourceText +import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common +import Ormolu.Printer.Meat.Declaration.Rule +import Ormolu.Printer.Meat.Declaration.Value (p_hsExpr) import Ormolu.Printer.Meat.Type import Ormolu.Utils @@ -30,7 +37,9 @@ ClassOpSig _ def names sigType -> p_classOpSig def names sigType FixSig _ sig -> p_fixSig sig InlineSig _ name inlinePragma -> p_inlineSig name inlinePragma - SpecSig _ name ts inlinePragma -> p_specSig name ts inlinePragma + SpecSig _ name ts inlinePragma -> + p_specSig Nothing (noLocA $ HsVar NoExtField name) ts inlinePragma + SpecSigE _ ruleBndrs expr inlinePragma -> p_specSigE ruleBndrs expr inlinePragma SpecInstSig _ sigType -> p_specInstSig sigType MinimalSig _ booleanFormula -> p_minimalSig booleanFormula CompleteMatchSig _ cs ty -> p_completeSig cs ty @@ -116,26 +125,71 @@ p_rdrName name p_specSig :: - -- | Name - LocatedN RdrName -> + -- | Rule binders + Maybe (RuleBndrs GhcPs) -> + -- | Expression to specialize + LHsExpr GhcPs -> -- | The types to specialize to [LHsSigType GhcPs] -> -- | For specialize inline InlinePragma -> R () -p_specSig name ts InlinePragma {..} = pragmaBraces $ do +p_specSig mRuleBndrs specExpr ts InlinePragma {..} = pragmaBraces $ do txt "SPECIALIZE" space p_inlineSpec inl_inline space - p_activation inl_act - space - p_rdrName name - space - token'dcolon - breakpoint - inci $ sep commaDel (located' p_hsSigType) ts + case (inl_inline, inl_act) of + (NoInline _, NeverActive) -> return () + _ -> p_activation inl_act + inci $ do + space + forM_ mRuleBndrs $ \ruleBndrs -> do + p_ruleBndrs ruleBndrs + space + located specExpr p_hsExpr + case ts of + [] -> pure () + _ -> do + space + token'dcolon + breakpoint + sep commaDel (located' p_hsSigType) ts +p_specSigE :: + -- | Rule binders + RuleBndrs GhcPs -> + -- | Expression to specialize + LHsExpr GhcPs -> + -- | For specialize inline + InlinePragma -> + R () +p_specSigE ruleBndrs expr = + p_specSig (Just ruleBndrs) specExpr (maybeToList sigTy) + where + (_, specExpr, sigTy) = deconstructExprFromSpecSigE expr + +-- | The 'LHsExpr' in a 'SpecSigE' can only be of a very specific form, namely a +-- variable applied to value/type-level arguments, optionally with a type +-- signature. +-- +-- https://github.com/ghc-proposals/ghc-proposals/blob/e2c683698323cec3e33625369ae2b5f585387c70/proposals/0493-specialise-expressions.rst#2proposed-change-specification +deconstructExprFromSpecSigE :: + (HasCallStack) => + LHsExpr GhcPs -> + (LocatedN RdrName, LHsExpr GhcPs, Maybe (LHsSigType GhcPs)) +deconstructExprFromSpecSigE = \case + L _ (ExprWithTySig _ e HsWC {hswc_body}) -> + (findVar e, e, Just hswc_body) + e -> (findVar e, e, Nothing) + where + findVar :: LHsExpr GhcPs -> LocatedN RdrName + findVar = \case + L _ (HsVar _ name) -> name + L _ (HsApp _ e _) -> findVar e + L _ (HsAppType _ e _) -> findVar e + _ -> error "unreachble" + p_inlineSpec :: InlineSpec -> R () p_inlineSpec = \case Inline _ -> txt "INLINE" @@ -165,7 +219,7 @@ p_minimalSig :: -- | Boolean formula - LBooleanFormula (LocatedN RdrName) -> + LBooleanFormula GhcPs -> R () p_minimalSig = located' $ \booleanFormula -> @@ -173,7 +227,7 @@ p_booleanFormula :: -- | Boolean formula - BooleanFormula (LocatedN RdrName) -> + BooleanFormula GhcPs -> R () p_booleanFormula = \case Var name -> p_rdrName name diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs-boot b/src/Ormolu/Printer/Meat/Declaration/Signature.hs-boot new file mode 100644 --- /dev/null +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs-boot @@ -0,0 +1,14 @@ +module Ormolu.Printer.Meat.Declaration.Signature + ( p_sigDecl, + p_typeAscription, + p_activation, + ) +where + +import GHC.Hs +import GHC.Types.Basic +import Ormolu.Printer.Combinators + +p_sigDecl :: Sig GhcPs -> R () +p_typeAscription :: LHsSigType GhcPs -> R () +p_activation :: Activation -> R () diff --git a/src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs b/src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs --- a/src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs +++ b/src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs @@ -40,7 +40,7 @@ LastPos -> txt "\\" *> txt s vlayout singleLine multiLine MultilineStringLiteral -> - sep breakpoint' txt segments + sep newlineLiteral txt segments txt endMarker -- | The start/end marker of the literal, whether it is a regular or a multiline @@ -91,12 +91,25 @@ where go [] = [s] go ((pre, suf) : bs) = case T.uncons suf of - Just ('\\', T.uncons -> Just (c, s')) - | is_space c, - let rest = T.drop 1 $ T.dropWhile (/= '\\') s' -> + Just ('\\', suf') + | (gap, T.uncons -> Just ('\\', rest)) <- T.span is_space suf', + -- If there is a space after the backslash, this definitely is a + -- string gap. Continue parsing gaps after the next backslash. + not $ T.null gap -> pre : splitGaps rest - | otherwise -> go $ (if c == '\\' then drop 1 else id) bs + | otherwise -> + -- Check whether @suf@ starts with an escape sequence involving + -- another backslash. If so, it can not be the start of a string + -- gap, so we skip it. + let skipNextBackslash = + any (`T.isPrefixOf` suf') escapesWithAnotherBackslash + in go $ (if skipNextBackslash then drop 1 else id) bs _ -> go bs + + -- All escape sequences (without the initial backslash) with another + -- backslash. See + -- https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6 + escapesWithAnotherBackslash = ["\\", "^\\"] -- See the the MultilineStrings GHC proposal and 'lexMultilineString' from -- "GHC.Parser.String" for reference. diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -31,7 +32,6 @@ import Data.Maybe import Data.Text (Text) import Data.Text qualified as Text -import Data.Void import GHC.Data.Strict qualified as Strict import GHC.Hs import GHC.LanguageExtensions.Type (Extension (NegativeLiterals)) @@ -47,7 +47,7 @@ import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree -import Ormolu.Printer.Meat.Declaration.Signature +import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Signature import Ormolu.Printer.Meat.Declaration.StringLiteral import Ormolu.Printer.Meat.Type import Ormolu.Printer.Operators @@ -100,15 +100,15 @@ MatchGroup GhcPs (LocatedA body) -> R () p_matchGroup' placer render style mg@MG {..} = do - let ob = case style of - Case -> bracesIfEmpty - LambdaCase -> bracesIfEmpty - _ -> dontUseBraces - where - bracesIfEmpty = if isEmptyMatchGroup mg then useBraces else id -- Since we are forcing braces on 'sepSemi' based on 'ob', we have to -- restore the brace state inside the sepsemi. ub <- bool dontUseBraces useBraces <$> canUseBraces + let ob = case style of + Case -> bracesIfNecessary + LambdaCase -> bracesIfNecessary + _ -> dontUseBraces + where + bracesIfNecessary = if isEmptyMatchGroup mg then useBraces else ub ob $ sepSemi (located' (ub . p_Match)) (unLoc mg_alts) where p_Match m@Match {..} = @@ -117,7 +117,7 @@ render (adjustMatchGroupStyle m style) (isInfixMatch m) - (HsNoMultAnn NoExtField) + (HsUnannotated EpPatBind) (matchStrictness m) -- We use the spans of the individual patterns. (unLoc m_pats) @@ -126,7 +126,7 @@ -- | Function id obtained through pattern matching on 'FunBind' should not -- be used to print the actual equations because the different ‘RdrNames’ -- used in the equations may have different “decorations” (such as backticks --- and paretheses) associated with them. It is necessary to use per-equation +-- and parentheses) associated with them. It is necessary to use per-equation -- names obtained from 'm_ctxt' of 'Match'. This function replaces function -- name inside of 'Function' accordingly. adjustMatchGroupStyle :: @@ -134,14 +134,13 @@ MatchGroupStyle -> MatchGroupStyle adjustMatchGroupStyle m = \case - Function _ -> (Function . mc_fun . m_ctxt) m + Function _ | FunRhs {mc_fun = f} <- m_ctxt m -> Function f style -> style matchStrictness :: Match id body -> SrcStrictness -matchStrictness match = - case m_ctxt match of - FunRhs {mc_strictness = s} -> s - _ -> NoSrcStrict +matchStrictness = \case + Match {m_ctxt = FunRhs {mc_strictness = s}} -> s + _ -> NoSrcStrict p_match :: -- | Style of the group @@ -186,17 +185,19 @@ -- would start with two indentation steps applied, which is ugly, so we -- need to be a bit more clever here and bump indentation level only when -- pattern group is multiline. + p_hsMultAnn (located' p_hsType) multAnn case multAnn of - HsNoMultAnn NoExtField -> pure () - HsPct1Ann _ -> txt "%1" *> space - HsMultAnn _ ty -> do - txt "%" - located ty p_hsType - space + HsUnannotated {} -> pure () + HsLinearAnn {} -> space + HsExplicitMult {} -> space case strictness of NoSrcStrict -> return () SrcStrict -> txt "!" SrcLazy -> txt "~" + let isCase = \case + Case -> True + LambdaCase -> True + _ -> False indentBody <- case NE.nonEmpty m_pats of Nothing -> False <$ case style of @@ -207,7 +208,12 @@ Function name -> combineSrcSpans (getLocA name) patSpans _ -> patSpans patSpans = combineSrcSpans' (getLocA <$> ne_pats) - indentBody = not (isOneLineSpan combinedSpans) + containsOrPat = everything (||) $ \b -> case cast @_ @(Pat GhcPs) b of + Just OrPat {} -> True + _ -> False + indentBody = + not (isOneLineSpan combinedSpans) + && not (isCase style && containsOrPat ne_pats) switchLayoutNoLimit [combinedSpans] $ do let stdCase = sep breakpoint (located' p_pat) m_pats case style of @@ -244,14 +250,10 @@ Function name -> Just (getLocA name) _ -> Nothing Just pats -> (Just . getLocA . NE.last) pats - isCase = \case - Case -> True - LambdaCase -> True - _ -> False hasGuards = withGuards grhssGRHSs grhssSpan = combineSrcSpans' $ - getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs + getGRHSSpan . unLoc <$> grhssGRHSs patGrhssSpan = maybe grhssSpan @@ -277,7 +279,7 @@ sep breakpoint (located' (p_grhs' placement placer render groupStyle)) - grhssGRHSs + (NE.toList grhssGRHSs) p_where = do unless (eqEmptyLocalBinds grhssLocalBinds) $ do breakpoint @@ -290,6 +292,7 @@ case style of Function _ | hasGuards -> return () Function _ -> space >> inci equals + PatternBind | hasGuards -> return () PatternBind -> space >> inci equals s | isCase s && hasGuards -> return () _ -> space >> token'rarrow @@ -375,10 +378,10 @@ located cmd (p_hsCmd' Applicand s) breakpoint inci $ located expr p_hsExpr - HsCmdLam _ variant mgroup -> p_lam isApp variant cmdPlacement p_hsCmd mgroup + HsCmdLam _ variant mgroup -> p_lam isApp s variant cmdPlacement p_hsCmd mgroup HsCmdPar _ c -> parens N $ sitcc $ located c p_hsCmd HsCmdCase _ e mgroup -> - p_case isApp cmdPlacement p_hsCmd e mgroup + p_case isApp s cmdPlacement p_hsCmd e mgroup HsCmdIf anns _ if' then' else' -> p_if cmdPlacement p_hsCmd anns if' then' else' HsCmdLet (letToken, _) localBinds c -> @@ -565,8 +568,8 @@ p_dotFieldOcc = p_rdrName . fmap (mkVarUnqual . field_label) . dfoLabel -p_dotFieldOccs :: [DotFieldOcc GhcPs] -> R () -p_dotFieldOccs = sep (txt ".") p_dotFieldOcc +p_dotFieldOccs :: NonEmpty (DotFieldOcc GhcPs) -> R () +p_dotFieldOccs = sep (txt ".") p_dotFieldOcc . NE.toList p_fieldOcc :: FieldOcc GhcPs -> R () p_fieldOcc FieldOcc {..} = p_rdrName foLabel @@ -591,7 +594,7 @@ p_hsExpr = p_hsExpr' NotApplicand N -- | An applicand is the left-hand side in a function application, i.e. @f@ in --- @f a@. We need to track this in order to add extra identation in cases like +-- @f a@. We need to track this in order to add extra indentation in cases like -- -- > foo = -- > do @@ -604,10 +607,18 @@ Applicand -> inci . inci NotApplicand -> inci +-- | Adjust bracing as needed for certain cases e.g. involving case +-- expressions and lambdas. +adjustBracing :: IsApplicand -> BracketStyle -> R () -> R () +adjustBracing isApp s p = do + layout <- getLayout + case (s, layout, isApp) of + (S, SingleLine, NotApplicand) -> useBraces p + _ -> p + p_hsExpr' :: IsApplicand -> BracketStyle -> HsExpr GhcPs -> R () p_hsExpr' isApp s = \case HsVar _ name -> p_rdrName name - HsUnboundVar _ occ -> atom occ HsOverLabel sourceText _ -> do txt "#" p_sourceText sourceText @@ -622,7 +633,7 @@ HsMultilineString (SourceText stxt) _ -> p_stringLit stxt r -> atom r HsLam _ variant mgroup -> - p_lam isApp variant exprPlacement p_hsExpr mgroup + p_lam isApp s variant exprPlacement p_hsExpr mgroup HsApp _ f x -> do let -- In order to format function applications with multiple parameters -- nicer, traverse the AST to gather the function and all the @@ -743,13 +754,14 @@ ExplicitSum _ tag arity e -> p_unboxedSum N tag arity (located e p_hsExpr) HsCase _ e mgroup -> - p_case isApp exprPlacement p_hsExpr e mgroup + p_case isApp s exprPlacement p_hsExpr e mgroup HsIf anns if' then' else' -> p_if exprPlacement p_hsExpr anns if' then' else' HsMultiIf _ guards -> do txt "if" breakpoint - inciApplicand isApp $ sep breakpoint (located' (p_grhs RightArrow)) guards + inciApplicand isApp $ + sep breakpoint (located' (p_grhs RightArrow)) (NE.toList guards) HsLet (letToken, _) localBinds e -> p_let (s == S) p_hsExpr letToken localBinds e HsDo _ doFlavor es -> do @@ -775,7 +787,7 @@ dotdot = case rec_dotdot of Just {} -> [txt ".."] Nothing -> [] - inci . braces N $ + inci . recordBraces $ sep commaDel sitcc (fields <> dotdot) RecordUpd {..} -> do located rupd_expr p_hsExpr @@ -784,7 +796,7 @@ sep commaDel (sitcc . located' (p_hsFieldBind p_lbl)) p_fieldLabelStrings (FieldLabelStrings flss) = p_dotFieldOccs $ unLoc <$> flss - inci . braces N $ case rupd_flds of + inci . recordBraces $ case rupd_flds of RegularRecUpdFields {..} -> p_recFields (located' p_fieldOcc) recUpdFields OverloadedRecUpdFields {..} -> @@ -795,7 +807,7 @@ located gf_field p_dotFieldOcc HsProjection {..} -> parens N $ do txt "." - p_dotFieldOccs (NE.toList proj_flds) + p_dotFieldOccs proj_flds ExprWithTySig _ x HsWC {hswc_body} -> sitcc $ do located x p_hsExpr inci $ p_hsTypeAnnotation (hsSigTypeToType <$> hswc_body) @@ -828,7 +840,7 @@ breakpoint' txt "||]" HsUntypedBracket _ x -> p_hsQuote x - HsTypedSplice _ expr -> p_hsSpliceTH True expr DollarSplice + HsTypedSplice _ (HsTypedSpliceExpr _ expr) -> p_hsSpliceTH True expr DollarSplice HsUntypedSplice _ untySplice -> p_hsUntypedSplice DollarSplice untySplice HsProc _ p e -> do txt "proc" @@ -855,6 +867,9 @@ txt "type" space located hswc_body p_hsType + HsHole holeKind -> case holeKind of + HoleVar name -> p_rdrName name + HoleError -> error "parse error" -- similar to HsForAllTy expr@HsForAll {} -> p_hsFun expr @@ -962,7 +977,7 @@ -- will be ParStmt. [L _ (ParStmt _ blocks _ _)] -> [ concatMap collectNonParStmts stmts - | ParStmtBlock _ stmts _ _ <- blocks + | ParStmtBlock _ stmts _ _ <- NE.toList blocks ] -- Otherwise, list will not contain any ParStmt stmts -> @@ -998,12 +1013,17 @@ breakpoint located psb_def p_pat breakpoint - txt "where" + indentWhere <- getPrinterOpt poIndentWheres + let (inciWhere, inciBody) = + if indentWhere + then (id, inci) + else (inciByFrac (-1 / 2), id) + inciWhere $ txt "where" breakpoint - inci (p_matchGroup (Function psb_id) mgroup) + inciBody $ p_matchGroup (Function psb_id) mgroup txt "pattern" case psb_args of - PrefixCon [] xs -> do + PrefixCon xs -> do space p_rdrName psb_id inci $ do @@ -1012,7 +1032,6 @@ unless (null xs) breakpoint sitcc (sep breakpoint p_rdrName xs) rhs conSpans - PrefixCon (v : _) _ -> absurd v RecCon xs -> do space p_rdrName psb_id @@ -1020,7 +1039,7 @@ let conSpans = getLocA . recordPatSynPatVar <$> xs switchLayout conSpans $ do unless (null xs) breakpointPreRecordBrace - braces N $ + recordBraces $ sep commaDel (p_rdrName . recordPatSynPatVar) xs rhs conSpans InfixCon l r -> do @@ -1040,6 +1059,7 @@ Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => IsApplicand -> + BracketStyle -> -- | Placer (body -> Placement) -> -- | Render @@ -1049,20 +1069,23 @@ -- | Match group MatchGroup GhcPs (LocatedA body) -> R () -p_case isApp placer render e mgroup = do +p_case isApp s placer render e mgroup = do txt "case" space located e p_hsExpr space txt "of" breakpoint - inciApplicand isApp (p_matchGroup' placer render Case mgroup) + adjustBracing isApp s $ + inciApplicand isApp (p_matchGroup' placer render Case mgroup) p_lam :: ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => IsApplicand -> + -- | BracketStyle (S when inside a do block) + BracketStyle -> -- | Variant (@\\@ or @\\case@ or @\\cases@) HsLamVariant -> -- | Placer @@ -1072,7 +1095,7 @@ -- | Expression MatchGroup GhcPs (LocatedA body) -> R () -p_lam isApp variant placer render mgroup = do +p_lam isApp s variant placer render mgroup = do let mCaseTxt = case variant of LamSingle -> Nothing LamCase -> Just "\\case" @@ -1084,7 +1107,7 @@ Just caseTxt -> do txt caseTxt breakpoint - inciApplicand isApp pMatchGroup + adjustBracing isApp s (inciApplicand isApp pMatchGroup) p_if :: -- | Placer @@ -1243,65 +1266,66 @@ _ -> Nothing p_pat :: Pat GhcPs -> R () -p_pat = \case +p_pat = p_pat' False + +p_pat' :: Bool -> Pat GhcPs -> R () +p_pat' inAsPat = \case WildPat _ -> txt "_" VarPat _ name -> p_rdrName name LazyPat _ pat -> do txt "~" - located pat p_pat + located pat (p_pat' inAsPat) AsPat _ name pat -> do p_rdrName name txt "@" - located pat p_pat + located pat (p_pat' True) ParPat _ pat -> - located pat (parens S . sitcc . p_pat) + located pat (parens S . sitcc . p_pat' inAsPat) BangPat _ pat -> do txt "!" - located pat p_pat + located pat (p_pat' inAsPat) ListPat _ pats -> - brackets S $ sep commaDel (located' p_pat) pats + brackets S $ sep commaDel (located' (p_pat' inAsPat)) pats TuplePat _ pats boxing -> do let parens' = case boxing of Boxed -> parens S Unboxed -> parensHash S - parens' $ sep commaDel (sitcc . located' p_pat) pats - OrPat _ pats -> - sepSemi (located' p_pat) (NE.toList pats) + parens' $ sep commaDel (sitcc . located' (p_pat' inAsPat)) pats + OrPat _ pats -> do + sepSemi' inAsPat (located' (p_pat' inAsPat)) (NE.toList pats) SumPat _ pat tag arity -> - p_unboxedSum S tag arity (located pat p_pat) + p_unboxedSum S tag arity (located pat (p_pat' inAsPat)) ConPat _ pat details -> case details of - PrefixCon tys xs -> sitcc $ do + PrefixCon xs -> sitcc $ do p_rdrName pat - unless (null tys && null xs) breakpoint - inci . sitcc $ - sep breakpoint (sitcc . either p_hsConPatTyArg (located' p_pat)) $ - (Left <$> tys) <> (Right <$> xs) + unless (null xs) breakpoint + inci . sitcc $ sep breakpoint (sitcc . located' (p_pat' inAsPat)) xs RecCon (HsRecFields _ fields dotdot) -> do p_rdrName pat breakpointPreRecordBrace let f = \case Nothing -> txt ".." Just x -> located x p_pat_hsFieldBind - inci . braces N . sep commaDel f $ + inci . recordBraces . sep commaDel f $ case dotdot of Nothing -> Just <$> fields Just (L _ (RecFieldsDotDot n)) -> (Just <$> take n fields) ++ [Nothing] InfixCon l r -> do switchLayout [getLocA l, getLocA r] $ do - located l p_pat + located l (p_pat' inAsPat) breakpoint inci $ do p_rdrName pat space - located r p_pat + located r (p_pat' inAsPat) ViewPat _ expr pat -> sitcc $ do located expr p_hsExpr space token'rarrow breakpoint - inci (located pat p_pat) + inci (located pat (p_pat' inAsPat)) SplicePat _ splice -> p_hsUntypedSplice DollarSplice splice LitPat _ p -> atom p NPat _ v (isJust -> isNegated) _ -> do @@ -1318,7 +1342,7 @@ space located k (atom . ol_val) SigPat _ pat HsPS {..} -> do - located pat p_pat + located pat (p_pat' inAsPat) p_typeAscription (lhsTypeToSigType hsps_body) EmbTyPat _ (HsTP _ ty) -> do txt "type" @@ -1329,9 +1353,6 @@ p_tyPat :: HsTyPat GhcPs -> R () p_tyPat (HsTP _ ty) = txt "@" *> located ty p_hsType -p_hsConPatTyArg :: HsConPatTyArg GhcPs -> R () -p_hsConPatTyArg (HsConPatTyArg _ patSigTy) = p_tyPat patSigTy - p_pat_hsFieldBind :: HsRecField GhcPs (LPat GhcPs) -> R () p_pat_hsFieldBind HsFieldBind {..} = do located hfbLHS p_fieldOcc @@ -1361,7 +1382,7 @@ HsUntypedSpliceExpr _ expr -> p_hsSpliceTH False expr deco HsQuasiQuote _ quoterName str -> do txt "[" - p_rdrName (noLocA quoterName) + p_rdrName quoterName txt "|" -- QuasiQuoters often rely on precise custom strings. We cannot do any -- formatting here without potentially breaking someone's code. @@ -1428,21 +1449,31 @@ -- | Function types in expressions, e.g. with -XRequiredTypeArguments instance FunRepr (HsExpr GhcPs) where - renderFunItem = p_hsExpr parseFunRepr = \case -- `forall a. _` L ann (HsForAll _ tele expr) -> - ParsedFunForall (L ann tele) (parseFunRepr expr) + ParsedFunForall + { tele = L ann tele, + next = parseFunRepr expr + } -- `HasCallStack => _` expr@(L _ HsQual {}) -> let (ctxs, rest) = getContexts expr - in ParsedFunQuals ctxs (parseFunRepr rest) + in ParsedFunQuals + { ctxs, + next = parseFunRepr rest + } -- `Int -> _` - expr@(L _ HsFunArr {}) -> - let (args, ret) = getArgsAndReturn expr - in ParsedFunArgs args (parseFunRepr ret) + L ann (HsFunArr _ multAnn arg r) -> + ParsedFunArg + { span = ann, + arg, + doc = Nothing, + multAnn, + next = parseFunRepr r + } -- `_ -> Int` - expr -> ParsedFunReturn (expr, Nothing) + ret -> ParsedFunReturn {ret, doc = Nothing} where getContexts = let go ctxs = \case @@ -1451,14 +1482,12 @@ expr -> (reverse ctxs, expr) in go [] - getArgsAndReturn = - let go args = \case - L ann (HsFunArr _ arrow l r) -> - go (L ann (l, Nothing, arrow) : args) r - expr -> - (reverse args, expr) - in go [] + renderFunReprArg = p_hsExpr + renderFunReprCtx = p_hsExpr + renderFunReprMult = p_hsExpr + renderFunReprRet = p_hsExpr + ---------------------------------------------------------------------------- -- Helpers @@ -1476,9 +1505,9 @@ -- | Determine placement of a given block. blockPlacement :: (body -> Placement) -> - [LGRHS GhcPs (LocatedA body)] -> + NonEmpty (LGRHS GhcPs (LocatedA body)) -> Placement -blockPlacement placer [L _ (GRHS _ _ (L _ x))] = placer x +blockPlacement placer (L _ (GRHS _ _ (L _ x)) :| []) = placer x blockPlacement _ _ = Normal -- | Determine placement of a given command. @@ -1522,7 +1551,7 @@ _ -> Normal -- | Return 'True' if any of the RHS expressions has guards. -withGuards :: [LGRHS GhcPs body] -> Bool +withGuards :: NonEmpty (LGRHS GhcPs body) -> Bool withGuards = any (checkOne . unLoc) where checkOne (GRHS _ [] _) = False @@ -1531,10 +1560,12 @@ -- | For use before record braces. Collapse to empty if not 'poRecordBraceSpace'. breakpointPreRecordBrace :: R () breakpointPreRecordBrace = do + recordStyle <- getPrinterOpt poRecordStyle useSpace <- getPrinterOpt poRecordBraceSpace - if useSpace - then breakpoint - else breakpoint' + if + | recordStyle == RecordStyleKnr -> space + | useSpace -> breakpoint + | otherwise -> breakpoint' -- | For nested lists/tuples, pad with whitespace so that we always indent correctly, -- rather than sometimes indenting by 2 regardless of 'poIndentation'. diff --git a/src/Ormolu/Printer/Meat/ImportExport.hs b/src/Ormolu/Printer/Meat/ImportExport.hs --- a/src/Ormolu/Printer/Meat/ImportExport.hs +++ b/src/Ormolu/Printer/Meat/ImportExport.hs @@ -49,6 +49,10 @@ space when ideclSafe (txt "safe") space + case ideclLevelSpec of + LevelStylePre l -> p_declLevel l + _ -> return () + space when (isImportDeclQualified ideclQualified && not useQualifiedPost) (txt "qualified") @@ -59,6 +63,10 @@ space inci $ do located ideclName atom + space + case ideclLevelSpec of + LevelStylePost l -> p_declLevel l + _ -> return () when (isImportDeclQualified ideclQualified && useQualifiedPost) (space >> txt "qualified") @@ -84,6 +92,11 @@ (\(p, l) -> sitcc (located l (p_lie layout False p))) (attachRelativePos xs) newline + +p_declLevel :: ImportDeclLevel -> R () +p_declLevel = \case + ImportDeclSplice -> txt "splice" + ImportDeclQuote -> txt "quote" p_lie :: Layout -> Bool -> RelativePos -> IE GhcPs -> R () p_lie encLayout isAllPrevDoc relativePos = \case diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | Rendering of types. module Ormolu.Printer.Meat.Type @@ -16,42 +18,40 @@ p_hsTyVarBndr, ForAllVisibility (..), p_forallBndrs, - p_conDeclFields, + p_hsConDeclRecFields, + p_hsConDeclField, + p_hsConDeclFieldWithDoc, p_lhsTypeArg, p_hsSigType, - FunRepr (..), - ParsedFunRepr (..), - p_hsFun, - hsOuterTyVarBndrsToHsType, hsSigTypeToType, lhsTypeToSigType, + + -- * Re-exports from Ormolu.Printer.Meat.Type.Function + FunRepr (..), + ParsedFunRepr, + ParsedFunRepr' (..), + p_hsFun, ) where import Control.Monad -import Control.Monad.Cont qualified as Cont -import Control.Monad.State qualified as State -import Control.Monad.Trans qualified as Trans -import Data.Choice (Choice, pattern Is, pattern Isn't, pattern With, pattern Without) -import Data.Choice qualified as Choice -import Data.Foldable (traverse_) -import Data.Functor ((<&>)) -import Data.List (sortOn) -import Data.Maybe (isJust) +import Data.Choice (pattern Is, pattern With, pattern Without) +import Data.Maybe (fromMaybe) import GHC.Data.Strict qualified as Strict import GHC.Hs hiding (isPromoted) import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Var -import GHC.Utils.Outputable (Outputable) import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree (p_tyOpTree, tyOpTree) import Ormolu.Printer.Meat.Declaration.StringLiteral import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice) +import Ormolu.Printer.Meat.Type.Function import Ormolu.Printer.Operators import Ormolu.Utils +import Prelude hiding (span) p_hsType :: HsType GhcPs -> R () p_hsType = \case @@ -137,31 +137,8 @@ -- String -- -- | Age -- Int - usePipe <- - getPrinterOpt poFunctionArrows <&> \case - TrailingArrows -> True - LeadingArrows -> False - LeadingArgsArrows -> False - if usePipe - then do - p_hsDoc Pipe (With #endNewline) str - located t p_hsType - else do - located t p_hsType - newline - p_hsDoc Caret (Without #endNewline) str - HsBangTy _ (HsBang u s) t -> do - case u of - SrcUnpack -> txt "{-# UNPACK #-}" >> space - SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space - NoSrcUnpack -> return () - case s of - SrcLazy -> txt "~" - SrcStrict -> txt "!" - NoSrcStrict -> return () - located t p_hsType - HsRecTy _ fields -> - p_conDeclFields fields + withHaddocks (Is #end) (Just str) $ do + located t p_hsType HsExplicitListTy _ p xs -> do case p of IsPromoted -> txt "'" @@ -189,7 +166,20 @@ HsStrTy (SourceText s) _ -> p_stringLit s a -> atom a HsWildCardTy _ -> txt "_" - XHsType t -> atom t + XHsType ext -> case ext of + HsCoreTy t -> atom @HsCoreTy t + HsBangTy _ (HsSrcBang _ u s) t -> do + case u of + SrcUnpack -> txt "{-# UNPACK #-}" >> space + SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space + NoSrcUnpack -> return () + case s of + SrcLazy -> txt "~" + SrcStrict -> txt "!" + NoSrcStrict -> return () + located t p_hsType + HsRecTy _ fields -> + p_hsConDeclRecFields fields where startsWithSingleQuote = \case HsAppTy _ (L _ f) _ -> startsWithSingleQuote f @@ -200,7 +190,12 @@ _ -> False p_hsTypeAnnotation :: LHsType GhcPs -> R () -p_hsTypeAnnotation = p_hsFunParsed . ParsedFunSig . parseFunRepr +p_hsTypeAnnotation ty = + p_hsFunParsed @(HsType GhcPs) $ + ParsedFunSig + { sig = (), + next = parseFunRepr ty + } -- | Return 'True' if at least one argument in 'HsType' has a doc string -- attached to it. @@ -215,101 +210,47 @@ p_hsContext :: HsContext GhcPs -> R () p_hsContext = p_hsContext' p_hsType -p_hsContext' :: - (Outputable (GenLocated (Anno a) a), HasLoc (Anno a)) => - (a -> R ()) -> - [XRec GhcPs a] -> - R () -p_hsContext' f = \case - [] -> txt "()" - [x] -> located x f - xs -> do - shouldSort <- getPrinterOpt poSortConstraints - let sort = if shouldSort then sortOn showOutputable else id - parens N $ sep commaDel (sitcc . located' f) (sort xs) - -class IsTyVarBndrFlag flag where - isInferred :: flag -> Bool - p_tyVarBndrFlag :: flag -> R () - p_tyVarBndrFlag _ = pure () - -instance IsTyVarBndrFlag () where - isInferred () = False - -instance IsTyVarBndrFlag Specificity where - isInferred = \case - InferredSpec -> True - SpecifiedSpec -> False - -instance IsTyVarBndrFlag (HsBndrVis GhcPs) where - isInferred _ = False - p_tyVarBndrFlag = \case - HsBndrRequired NoExtField -> pure () - HsBndrInvisible _ -> txt "@" - -p_hsTyVarBndr :: (IsTyVarBndrFlag flag) => HsTyVarBndr flag GhcPs -> R () -p_hsTyVarBndr HsTvb {..} = do - p_tyVarBndrFlag tvb_flag - let wrap - | isInferred tvb_flag = braces N - | otherwise = case tvb_kind of - HsBndrKind {} -> parens N - HsBndrNoKind {} -> id - wrap $ do - case tvb_var of - HsBndrVar _ x -> p_rdrName x - HsBndrWildCard _ -> txt "_" - case tvb_kind of - HsBndrKind _ k -> inci $ p_hsTypeAnnotation k - HsBndrNoKind _ -> pure () - -data ForAllVisibility = ForAllInvis | ForAllVis - --- | Render several @forall@-ed variables. -p_forallBndrs :: - (HasLoc l) => - ForAllVisibility -> - (a -> R ()) -> - [GenLocated l a] -> - R () -p_forallBndrs vis p tyvars = do - p_forallBndrsStart p tyvars - p_forallBndrsEnd (Without #extraSpace) vis - -p_forallBndrsStart :: (HasLoc l) => (a -> R ()) -> [GenLocated l a] -> R () -p_forallBndrsStart _ [] = token'forall -p_forallBndrsStart p tyvars = do - switchLayout (locA <$> tyvars) $ do - token'forall - breakpoint - inci $ do - sitcc $ sep breakpoint (sitcc . located' p) tyvars - -p_forallBndrsEnd :: Choice "extraSpace" -> ForAllVisibility -> R () -p_forallBndrsEnd extraSpace = \case - ForAllInvis -> txt dot >> space - ForAllVis -> space >> token'rarrow - where - dot = if Choice.isTrue extraSpace then " ." else "." - -p_conDeclFields :: [LConDeclField GhcPs] -> R () -p_conDeclFields xs = - braces N $ sep commaDel (sitcc . located' p_conDeclField) xs +p_hsConDeclRecFields :: [LHsConDeclRecField GhcPs] -> R () +p_hsConDeclRecFields xs = + recordBraces $ sep commaDel (sitcc . located' p_hsConDeclRecField) xs -p_conDeclField :: ConDeclField GhcPs -> R () -p_conDeclField ConDeclField {..} = do - commaStyle <- getPrinterOpt poCommaStyle - when (commaStyle == Trailing) $ - mapM_ (p_hsDoc Pipe (With #endNewline)) cd_fld_doc +p_hsConDeclRecField :: HsConDeclRecField GhcPs -> R () +p_hsConDeclRecField field@HsConDeclRecField {..} = withFieldHaddocks $ do sitcc $ sep commaDel (located' (p_rdrName . foLabel)) - cd_fld_names - inci $ p_hsTypeAnnotation cd_fld_type - when (commaStyle == Leading) $ - mapM_ (inciByFrac (-1) . (newline >>) . p_hsDoc Caret (Without #endNewline)) cd_fld_doc + cdrf_names + inci $ p_hsFun field + where + withFieldHaddocks action = do + commaStyle <- getPrinterOpt poCommaStyle + let doc = cdf_doc cdrf_spec + when (commaStyle == Trailing) $ + mapM_ (p_hsDoc Pipe (With #endNewline)) doc + action + when (commaStyle == Leading) $ + mapM_ (inciByFrac (-1) . (newline >>) . p_hsDoc Caret (Without #endNewline)) doc +-- | This does not print 'cdf_doc' and 'cdf_multiplicity' as there is no single +-- strategy for where to print them (see call sites). +p_hsConDeclField :: HsConDeclField GhcPs -> R () +p_hsConDeclField CDF {..} = do + case cdf_unpack of + SrcUnpack -> txt "{-# UNPACK #-}" *> space + SrcNoUnpack -> txt "{-# NOUNPACK #-}" *> space + NoSrcUnpack -> pure () + located cdf_type $ \ty -> do + case cdf_bang of + SrcLazy -> txt "~" + SrcStrict -> txt "!" + NoSrcStrict -> pure () + p_hsType ty + +p_hsConDeclFieldWithDoc :: HsConDeclField GhcPs -> R () +p_hsConDeclFieldWithDoc cdf = withHaddocks (Is #end) cdf.cdf_doc $ do + p_hsConDeclField cdf + p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg = \case HsValArg NoExtField ty -> located ty p_hsType @@ -322,54 +263,37 @@ p_hsSigType :: HsSigType GhcPs -> R () p_hsSigType = p_hsType . hsSigTypeToType ----------------------------------------------------------------------------- --- Rendering function types - --- | The parsed representation of a function -data ParsedFunRepr a - = ParsedFunSig (ParsedFunRepr a) - | ParsedFunForall - (LocatedA (HsForAllTelescope GhcPs)) - (ParsedFunRepr a) - | ParsedFunQuals - [LocatedA (LocatedC [LocatedA a])] - (ParsedFunRepr a) - | -- | The argument, its optional docstring, and the arrow going to the next arg/return - ParsedFunArgs - [ LocatedA - ( LocatedA a, - Maybe (LHsDoc GhcPs), - HsArrowOf (LocatedA a) GhcPs - ) - ] - (ParsedFunRepr a) - | ParsedFunReturn - ( LocatedA a, - Maybe (LHsDoc GhcPs) - ) - -class (Anno a ~ SrcSpanAnnA, Outputable a) => FunRepr a where - renderFunItem :: a -> R () - - parseFunRepr :: LocatedA a -> ParsedFunRepr a - instance FunRepr (HsType GhcPs) where - renderFunItem = p_hsType parseFunRepr = \case -- `forall a. _` L ann (HsForAllTy _ tele ty) -> - ParsedFunForall (L ann tele) (parseFunRepr ty) + ParsedFunForall + { tele = L ann tele, + next = parseFunRepr ty + } -- `HasCallStack => _` ty@(L _ HsQualTy {}) -> let (ctxs, rest) = getContexts ty - in ParsedFunQuals ctxs (parseFunRepr rest) + in ParsedFunQuals + { ctxs, + next = parseFunRepr rest + } -- `Int -> _` - ty@(L _ HsFunTy {}) -> - let (args, ret) = getArgsAndReturn ty - in ParsedFunArgs args (parseFunRepr ret) + L ann (HsFunTy _ multAnn l r) -> + let (arg, doc) = + case l of + L _ (HsDocTy _ x doc_) -> (x, Just doc_) + _ -> (l, Nothing) + in ParsedFunArg + { span = ann, + arg, + doc, + multAnn, + next = parseFunRepr r + } -- `_ -> Int` - L _ (HsDocTy _ ty doc) -> ParsedFunReturn (ty, Just doc) - ty -> ParsedFunReturn (ty, Nothing) + L _ (HsDocTy _ ret doc) -> ParsedFunReturn {ret, doc = Just doc} + ret -> ParsedFunReturn {ret, doc = Nothing} where getContexts = let go ctxs = \case @@ -378,203 +302,106 @@ ty -> (reverse ctxs, ty) in go [] - getArgsAndReturn = - let go args = \case - L ann (HsFunTy _ arrow (L _ (HsDocTy _ l doc)) r) -> - go (L ann (l, Just doc, arrow) : args) r - L ann (HsFunTy _ arrow l r) -> - go (L ann (l, Nothing, arrow) : args) r - ty -> - (reverse args, ty) - in go [] --- | For implementing function-arrows and related configuration, we'll collect --- all the components of the function type first, then render as a block instead --- of rendering each part independently, which will let us track local state --- within a function type. --- --- This function should be passed the first function-related construct we find; --- see FunRepr for more details. -p_hsFun :: (FunRepr a) => a -> R () -p_hsFun = p_hsFunParsed . parseFunRepr . L (noAnn @SrcSpanAnnA) - -p_hsFunParsed :: (FunRepr a) => ParsedFunRepr a -> R () -p_hsFunParsed fun = do - arrowsStyle <- getPrinterOpt poFunctionArrows - p_hsFunParsed' arrowsStyle fun - -type PrintHsFun x = State.StateT PrintHsFunState (Cont.ContT () R) x - -type PrintHsFunState = - ( Maybe (R ()), -- The leading delimiter to output at the next line - Choice "forceMultiline" - ) - -p_hsFunParsed' :: - (FunRepr a) => - FunctionArrowsStyle -> - ParsedFunRepr a -> - R () -p_hsFunParsed' arrowsStyle fun0 = Cont.evalContT . (`State.evalStateT` initialState) . go $ fun0 - where - go = \case - ParsedFunSig fun' -> do - -- Should only happen at the very beginning, if at all - p_parsedFunSig - setMultilineContext fun' - go fun' - ParsedFunForall tele fun' -> do - p_parsedFunForall tele - setMultilineContext fun' - go fun' - ParsedFunQuals ctxs fun' -> do - p_parsedFunQuals ctxs - setMultilineContext fun' - go fun' - ParsedFunArgs args fun' -> do - p_parsedFunArgs args - go fun' - ParsedFunReturn ret -> do - p_parsedFunReturn ret - - liftR = Trans.lift . Trans.lift - initialState = (Nothing, Without #forceMultiline) - - withApplyLeadingDelim f = do - (leadingDelim, _) <- State.get - a <- f leadingDelim - State.modify $ \(_, x) -> (Nothing, x) - pure a - applyLeadingDelim = withApplyLeadingDelim (traverse_ liftR) - - setLeadingDelim delim = - State.modify $ \(_, x) -> (Just delim, x) - - getIsMultiline = do - (_, forceMultiline) <- State.get - layout <- liftR getLayout - pure $ Choice.toBool forceMultiline || layout == MultiLine - - setMultilineContext fun = - State.modify $ \(x, _) -> (x, Choice.fromBool $ hasDocs fun) - - -- Make everything afterwards occur within a located block, with the - -- magic of ContT. `item <- setLocated litem; ...` is equivalent to - -- `located litem $ \item -> ...`. - setLocated :: (HasLoc ann) => GenLocated ann x -> PrintHsFun x - setLocated litem = Trans.lift $ Cont.ContT (located litem) - - p_parsedFunSig = do - if isTrailing (Isn't #argDelim) - then liftR $ do - space >> token'dcolon - if hasDocs fun0 then newline else breakpoint - else do - liftR breakpoint - setLeadingDelim (token'dcolon >> space) - - p_parsedFunForall x@(L _ tele) = do - void $ setLocated x - applyLeadingDelim - vis <- - case tele of - HsForAllInvis _ bndrs -> do - liftR $ p_forallBndrsStart p_hsTyVarBndr bndrs - pure ForAllInvis - HsForAllVis _ bndrs -> do - liftR $ p_forallBndrsStart p_hsTyVarBndr bndrs - pure ForAllVis - isMultiline <- getIsMultiline - if isTrailing (Isn't #argDelim) || not isMultiline - then do - liftR $ p_forallBndrsEnd (Without #extraSpace) vis - interArgBreak - else do - interArgBreak - let extraSpace = if isMultiline then With #extraSpace else Without #extraSpace - setLeadingDelim (p_forallBndrsEnd extraSpace vis) - - p_parsedFunQuals ctxs = do - -- we only want to set located on the first context - case ctxs of - ctx : _ -> void $ setLocated ctx - _ -> pure () - - forM_ ctxs $ \(L _ lctx) -> do - applyLeadingDelim - liftR $ located lctx (p_hsContext' renderFunItem) - if isTrailing (Isn't #argDelim) - then do - liftR $ space >> token'darrow - interArgBreak - else do - interArgBreak - setLeadingDelim (token'darrow >> space) - - p_parsedFunArgs args = do - -- we only want to set located on the first arg - case args of - arg : _ -> void $ setLocated arg - _ -> pure () + renderFunReprCtx = p_hsType + renderFunReprArg = p_hsType + renderFunReprMult = p_hsType + renderFunReprRet = p_hsType - forM_ args $ \(L _ (larg, doc, arrow)) -> do - let renderArrow = p_arrow (located' renderFunItem) arrow - withHaddocks (Isn't #end) doc $ do - withApplyLeadingDelim $ \applyLeadingDelim' -> - liftR . located larg $ \arg -> do - traverse_ id applyLeadingDelim' - renderFunItem arg - if isTrailing (Is #argDelim) - then do - liftR $ space >> renderArrow - interArgBreak - else do - interArgBreak - setLeadingDelim (renderArrow >> space) +---------------------------------------------------------------------------- +-- FunRepr HsConDeclRecField - p_parsedFunReturn (ret, doc) = do - void $ setLocated ret - withHaddocks (Is #end) doc $ do - applyLeadingDelim - liftR $ located ret renderFunItem +-- | FunRepr HsConDeclRecField renders a record field type annotation. If the +-- record field has a function type, we want to render it as a function +-- respecting `function-arrows`. For the most part, it behaves like HsTypeSig; +-- however, record fields can have additional syntax not in normal function +-- types, like specifying the multiplicity for the `::` or specifying +-- UNPACK/strictness, so we need to handle this specially. +instance FunRepr (HsConDeclRecField GhcPs) where + parseFunRepr (L _ HsConDeclRecField {..}) = + ParsedFunSig + { sig = cdrf_spec.cdf_multiplicity, + next = toRecFieldRepr False $ parseFunRepr cdrf_spec.cdf_type + } + where + toRecFieldRepr :: Bool -> ParsedFunRepr (HsType GhcPs) -> ParsedFunRepr (HsConDeclRecField GhcPs) + toRecFieldRepr seenArg = \case + ParsedFunSig {} -> error "parseFunRepr @HsType unexpectedly returned ParsedFunSig" + ParsedFunForall {..} -> + ParsedFunForall + { tele, + next = toRecFieldRepr seenArg next + } + ParsedFunQuals {..} -> + ParsedFunQuals + { ctxs, + next = toRecFieldRepr seenArg next + } + ParsedFunArg {..} -> + ParsedFunArg + { span, + arg = + let mUnpack = + if not seenArg + then Just cdrf_spec.cdf_unpack + else Nothing + in L (getLoc arg) (mUnpack, arg), + doc, + multAnn, + next = toRecFieldRepr True next + } + ParsedFunReturn {..} -> + ParsedFunReturn + { ret = + let mAnn = + if not seenArg + then Just (cdrf_spec.cdf_unpack, cdrf_spec.cdf_bang) + else Nothing + in L (getLoc ret) (mAnn, ret), + doc + } - withHaddocks isEnd doc m = do - isLeadingHaddock <- - liftR $ - getPrinterOpt poHaddockLocSignature <&> \case - HaddockLocSigAuto -> - if isTrailing (Is #argDelim) then With #pipe else Without #pipe - HaddockLocSigLeading -> - With #pipe - HaddockLocSigTrailing -> - Without #pipe + type FunReprSig (HsConDeclRecField GhcPs) = HsMultAnnOf (LocatedA (HsType GhcPs)) GhcPs + renderFunReprSig multAnn = do + space + p_hsMultAnn (located' p_hsType) multAnn + space + token'dcolon - if Choice.isTrue isLeadingHaddock - then do - traverse (liftR . p_hsDoc Pipe (With #endNewline)) doc *> m - else do - let (pre, endNewline) = - if Choice.isTrue isEnd - then (when (isJust doc) (liftR newline), Without #endNewline) - else (pure (), With #endNewline) - m <* pre <* traverse (liftR . p_hsDoc Caret endNewline) doc + type FunReprCtx (HsConDeclRecField GhcPs) = HsType GhcPs + renderFunReprCtx = p_hsType - interArgBreak = do - isMultiline <- getIsMultiline - liftR $ if isMultiline then newline else breakpoint + -- Invariant: SrcUnpackedness should only be set for the first arg + type FunReprArg (HsConDeclRecField GhcPs) = (Maybe SrcUnpackedness, LocatedA (HsType GhcPs)) + renderFunReprArg (mUnpacked, ty) = + p_hsConDeclField + CDF + { cdf_ext = error "unused", + cdf_unpack = fromMaybe NoSrcUnpack mUnpacked, + cdf_bang = NoSrcStrict, + cdf_multiplicity = error "unused", + cdf_type = ty, + cdf_doc = error "unused" + } - hasDocs = \case - ParsedFunSig fun -> hasDocs fun - ParsedFunForall _ fun -> hasDocs fun - ParsedFunQuals _ fun -> hasDocs fun - ParsedFunArgs args fun -> or [isJust doc | L _ (_, doc, _) <- args] || hasDocs fun - ParsedFunReturn (_, doc) -> isJust doc + type FunReprMult (HsConDeclRecField GhcPs) = HsType GhcPs + renderFunReprMult = p_hsType - isTrailing isArgDelim = - case arrowsStyle of - TrailingArrows -> True - LeadingArgsArrows -> not $ Choice.isTrue isArgDelim - LeadingArrows -> False + -- Invariant: SrcUnpackedness/SrcStrictness should only be set if there are + -- no args + type FunReprRet (HsConDeclRecField GhcPs) = (Maybe (SrcUnpackedness, SrcStrictness), LocatedA (HsType GhcPs)) + renderFunReprRet (mAnn, ty) = + p_hsConDeclField + CDF + { cdf_ext = error "unused", + cdf_unpack = unpack, + cdf_bang = strictness, + cdf_multiplicity = error "unused", + cdf_type = ty, + cdf_doc = error "unused" + } + where + (unpack, strictness) = fromMaybe (NoSrcUnpack, NoSrcStrict) mAnn ---------------------------------------------------------------------------- -- Conversion functions diff --git a/src/Ormolu/Printer/Meat/Type/Function.hs b/src/Ormolu/Printer/Meat/Type/Function.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Printer/Meat/Type/Function.hs @@ -0,0 +1,493 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +-- | A Fourmolu-specific module for rendering function-like type signatures. +module Ormolu.Printer.Meat.Type.Function + ( -- * PrintHsFun + PrintHsFun, + MonadR, + + -- * ParsedFunRepr + ParsedFunRepr, + ParsedFunRepr' (..), + FunRepr (..), + p_hsFun, + p_hsFunParsed, + + -- * forall + ForAllVisibility (..), + p_forallBndrs, + + -- * TyVarBndr + p_hsTyVarBndr, + + -- * Contexts + p_hsContext', + + -- * Haddocks + withHaddocks, + ) +where + +import Control.Monad (forM_, void, when) +import Control.Monad.Cont qualified as Cont +import Control.Monad.State qualified as State +import Control.Monad.Trans qualified as Trans +import Data.Choice (Choice, pattern Is, pattern Isn't, pattern With, pattern Without) +import Data.Choice qualified as Choice +import Data.Foldable (traverse_) +import Data.Functor ((<&>)) +import Data.List (sortOn) +import Data.Maybe (isJust) +import GHC.Hs +import GHC.Types.SrcLoc (GenLocated (..)) +import GHC.Types.Var (Specificity (..)) +import GHC.Utils.Outputable (Outputable) +import Ormolu.Config +import Ormolu.Printer.Combinators +import Ormolu.Printer.Meat.Common (p_arrow, p_hsDoc, p_rdrName) +import Ormolu.Utils (showOutputable) +import Prelude hiding (span) + +{----- PrintHsFun -----} + +newtype PrintHsFun a = PrintHsFun (State.StateT PrintHsFunState (Cont.ContT () R) a) + deriving newtype (Functor, Applicative, Monad) + +data PrintHsFunState = PrintHsFunState + { -- | The leading delimiter to output at the next line + leadingDelim :: Maybe (R ()), + forceMultiline :: Bool, + -- | Whether we're currently printing args + inArgList :: Bool + } + +runPrintHsFun :: PrintHsFun () -> R () +runPrintHsFun (PrintHsFun m) = Cont.evalContT . (`State.evalStateT` initialState) $ m + where + initialState = + PrintHsFunState + { leadingDelim = Nothing, + forceMultiline = False, + inArgList = False + } + +class (Monad m) => MonadR m where + liftR :: R a -> m a + +instance MonadR R where + liftR = id + +instance MonadR PrintHsFun where + liftR = PrintHsFun . Trans.lift . Trans.lift + +withApplyLeadingDelim :: (Maybe (R ()) -> PrintHsFun a) -> PrintHsFun a +withApplyLeadingDelim f = do + state <- PrintHsFun State.get + a <- f state.leadingDelim + PrintHsFun . State.put $ state {leadingDelim = Nothing} + pure a + +applyLeadingDelim :: PrintHsFun () +applyLeadingDelim = withApplyLeadingDelim (traverse_ liftR) + +setLeadingDelim :: R () -> PrintHsFun () +setLeadingDelim delim = + PrintHsFun . State.modify $ \state -> state {leadingDelim = Just delim} + +getIsMultiline :: PrintHsFun Bool +getIsMultiline = do + state <- PrintHsFun State.get + layout <- liftR getLayout + pure $ state.forceMultiline || layout == MultiLine + +setMultilineContext :: ParsedFunRepr' sig ctx arg mult ret -> PrintHsFun () +setMultilineContext fun = + PrintHsFun . State.modify $ \state -> state {forceMultiline = hasDocs fun} + +getIsTrailing :: (MonadR m) => m (Choice "argDelim" -> Bool) +getIsTrailing = do + arrowsStyle <- liftR $ getPrinterOpt poFunctionArrows + pure $ \isArgDelim -> + case arrowsStyle of + TrailingArrows -> True + LeadingArgsArrows -> not $ Choice.isTrue isArgDelim + LeadingArrows -> False + +getInArgList :: PrintHsFun Bool +getInArgList = PrintHsFun . State.gets $ (.inArgList) + +setInArgList :: Bool -> PrintHsFun () +setInArgList x = PrintHsFun . State.modify $ \state -> state {inArgList = x} + +-- Make everything afterwards occur within a located block, with the +-- magic of ContT. `item <- setLocated litem; ...` is equivalent to +-- `located litem $ \item -> ...`. +setLocated :: (HasLoc ann) => GenLocated ann x -> PrintHsFun x +setLocated litem = PrintHsFun . Trans.lift $ Cont.ContT (located litem) + +setLocated_ :: (HasLoc ann) => GenLocated ann x -> PrintHsFun () +setLocated_ = void . setLocated + +{----- ParsedFunRepr -----} + +type ParsedFunRepr a = + ParsedFunRepr' + (FunReprSig a) + (FunReprCtx a) + (FunReprArg a) + (FunReprMult a) + (FunReprRet a) + +-- | The parsed representation of a function +data ParsedFunRepr' sig ctx arg mult ret + = -- | The "::" delimiter. Invariant: must be first. + ParsedFunSig + { sig :: sig, + next :: ParsedFunRepr' sig ctx arg mult ret + } + | -- | The "forall a b." or "forall a b ->" construct. + ParsedFunForall + { tele :: LocatedA (HsForAllTelescope GhcPs), + next :: ParsedFunRepr' sig ctx arg mult ret + } + | -- | The "(A, B) =>" construct. + ParsedFunQuals + { ctxs :: [LocatedA (LocatedC [LocatedA ctx])], + next :: ParsedFunRepr' sig ctx arg mult ret + } + | ParsedFunArg + { span :: SrcSpanAnnA, + arg :: LocatedA arg, + doc :: Maybe (LHsDoc GhcPs), + multAnn :: HsMultAnnOf (LocatedA mult) GhcPs, + next :: ParsedFunRepr' sig ctx arg mult ret + } + | ParsedFunReturn + { ret :: LocatedA ret, + doc :: Maybe (LHsDoc GhcPs) + } + +class + ( Anno (FunReprCtx a) ~ SrcSpanAnnA, + Outputable (FunReprCtx a) + ) => + FunRepr a + where + parseFunRepr :: LocatedA a -> ParsedFunRepr a + + type FunReprSig a + type FunReprSig a = () + renderFunReprSig :: FunReprSig a -> R () + default renderFunReprSig :: (FunReprSig a ~ ()) => FunReprSig a -> R () + renderFunReprSig () = space *> token'dcolon + + type FunReprCtx a + type FunReprCtx a = a + renderFunReprCtx :: FunReprCtx a -> R () + + type FunReprArg a + type FunReprArg a = a + renderFunReprArg :: FunReprArg a -> R () + + type FunReprMult a + type FunReprMult a = a + renderFunReprMult :: FunReprMult a -> R () + + type FunReprRet a + type FunReprRet a = a + renderFunReprRet :: FunReprRet a -> R () + +-- | Some functions rely on HsType having a FunRepr instance, but the instance +-- can't be implemented here, since p_hsType is implemented in Type.hs, which +-- would cause a circular dependency. So we'll add it as an explicit constraint +-- and the call-site should bring the FunRepr instance for HsType in scope. +type FunReprHsType = + ( FunRepr (HsType GhcPs), + FunReprSig (HsType GhcPs) ~ (), + FunReprCtx (HsType GhcPs) ~ HsType GhcPs, + FunReprArg (HsType GhcPs) ~ HsType GhcPs, + FunReprMult (HsType GhcPs) ~ HsType GhcPs, + FunReprRet (HsType GhcPs) ~ HsType GhcPs + ) + +hasDocs :: ParsedFunRepr' ig ctx arg mult ret -> Bool +hasDocs = \case + ParsedFunSig {next} -> hasDocs next + ParsedFunForall {next} -> hasDocs next + ParsedFunQuals {next} -> hasDocs next + ParsedFunArg {doc, next} -> isJust doc || hasDocs next + ParsedFunReturn {doc} -> isJust doc + +{----- Rendering ParsedFunRepr -----} + +-- | For implementing function-arrows and related configuration, we'll collect +-- all the components of the function type first, then render as a block instead +-- of rendering each part independently, which will let us track local state +-- within a function type. +-- +-- This function should be passed the first function-related construct we find; +-- see FunRepr for more details. +p_hsFun :: forall a. (FunRepr a, FunReprHsType) => a -> R () +p_hsFun = p_hsFunParsed @a . parseFunRepr . L (noAnn @SrcSpanAnnA) + +p_hsFunParsed :: forall a. (FunRepr a, FunReprHsType) => ParsedFunRepr a -> R () +p_hsFunParsed = runPrintHsFun . p_hsFunParsed' @a + +p_hsFunParsed' :: forall a. (FunRepr a, FunReprHsType) => ParsedFunRepr a -> PrintHsFun () +p_hsFunParsed' = \case + ParsedFunSig {sig, next} -> do + -- Should only happen at the very beginning, if at all + p_parsedFunSig @a sig next + setMultilineContext next + p_hsFunParsed' @a next + ParsedFunForall {tele, next} -> do + p_parsedFunForall tele + setMultilineContext next + p_hsFunParsed' @a next + ParsedFunQuals {ctxs, next} -> do + p_parsedFunQuals @a ctxs + setMultilineContext next + p_hsFunParsed' @a next + ParsedFunArg {span, arg, doc, multAnn, next} -> do + p_parsedFunArg @a span arg doc multAnn + case next of + ParsedFunArg {} -> pure () + _ -> do + -- Don't reset multiline context within args; all args should be on + -- one line together, or all on separate lines + setMultilineContext next + -- Reset inArgList, needed if there are multiple arg lists in one + -- function type (e.g. `a -> Show a => b -> c`) + setInArgList False + p_hsFunParsed' @a next + ParsedFunReturn {ret, doc} -> do + p_parsedFunReturn @a ret doc + +p_parsedFunSig :: forall a. (FunRepr a) => FunReprSig a -> ParsedFunRepr a -> PrintHsFun () +p_parsedFunSig sig fun = do + isTrailing <- getIsTrailing + if isTrailing (Isn't #argDelim) + then liftR $ do + renderFunReprSig @a sig + if hasDocs fun then newline else breakpoint + else do + liftR breakpoint + setLeadingDelim (token'dcolon >> space) + +p_parsedFunForall :: (FunReprHsType) => LocatedA (HsForAllTelescope GhcPs) -> PrintHsFun () +p_parsedFunForall x@(L _ tele) = do + setLocated_ x + applyLeadingDelim + vis <- + case tele of + HsForAllInvis _ bndrs -> do + liftR $ p_forallBndrsStart p_hsTyVarBndr bndrs + pure ForAllInvis + HsForAllVis _ bndrs -> do + liftR $ p_forallBndrsStart p_hsTyVarBndr bndrs + pure ForAllVis + + isTrailing <- getIsTrailing + isMultiline <- getIsMultiline + if isTrailing (Isn't #argDelim) || not isMultiline + then do + liftR $ p_forallBndrsEnd (Without #extraSpace) vis + interArgBreak + else do + interArgBreak + let extraSpace = if isMultiline then With #extraSpace else Without #extraSpace + setLeadingDelim (p_forallBndrsEnd extraSpace vis) + +p_parsedFunQuals :: forall a. (FunRepr a) => [LocatedA (LocatedC [LocatedA (FunReprCtx a)])] -> PrintHsFun () +p_parsedFunQuals ctxs = do + isTrailing <- getIsTrailing + -- we only want to set located on the first context + case ctxs of + ctx : _ -> setLocated_ ctx + _ -> pure () + + forM_ ctxs $ \(L _ lctx) -> do + applyLeadingDelim + liftR $ located lctx (p_hsContext' (renderFunReprCtx @a)) + if isTrailing (Isn't #argDelim) + then do + liftR $ space >> token'darrow + interArgBreak + else do + interArgBreak + setLeadingDelim (token'darrow >> space) + +p_parsedFunArg :: + forall a. + (FunRepr a) => + SrcSpanAnnA -> + LocatedA (FunReprArg a) -> + Maybe (LHsDoc GhcPs) -> + HsMultAnnOf (LocatedA (FunReprMult a)) GhcPs -> + PrintHsFun () +p_parsedFunArg span item doc multAnn = do + isTrailing <- getIsTrailing + + -- We only want to set located on the first arg + inArgList <- getInArgList + when (not inArgList) $ do + setLocated_ (L span item) + setInArgList True + + let renderArrow = p_arrow (located' (renderFunReprMult @a)) multAnn + withHaddocks (Isn't #end) doc $ do + withApplyLeadingDelim $ \applyLeadingDelim' -> + liftR . located item $ \arg -> do + traverse_ id applyLeadingDelim' + renderFunReprArg @a arg + if isTrailing (Is #argDelim) + then do + liftR $ space >> renderArrow + interArgBreak + else do + interArgBreak + setLeadingDelim (renderArrow >> space) + +p_parsedFunReturn :: + forall a. + (FunRepr a) => + LocatedA (FunReprRet a) -> + Maybe (LHsDoc GhcPs) -> + PrintHsFun () +p_parsedFunReturn item doc = do + setLocated_ item + withHaddocks (Is #end) doc $ do + applyLeadingDelim + liftR $ located item (renderFunReprRet @a) + +{----- forall -----} + +data ForAllVisibility = ForAllInvis | ForAllVis + +-- | Render several @forall@-ed variables. +p_forallBndrs :: + (HasLoc l) => + ForAllVisibility -> + (a -> R ()) -> + [GenLocated l a] -> + R () +p_forallBndrs vis p tyvars = do + p_forallBndrsStart p tyvars + p_forallBndrsEnd (Without #extraSpace) vis + +p_forallBndrsStart :: (HasLoc l) => (a -> R ()) -> [GenLocated l a] -> R () +p_forallBndrsStart _ [] = token'forall +p_forallBndrsStart p tyvars = do + switchLayout (locA <$> tyvars) $ do + token'forall + breakpoint + inci $ do + sitcc $ sep breakpoint (sitcc . located' p) tyvars + +p_forallBndrsEnd :: Choice "extraSpace" -> ForAllVisibility -> R () +p_forallBndrsEnd extraSpace = \case + ForAllInvis -> txt dot >> space + ForAllVis -> space >> token'rarrow + where + dot = if Choice.isTrue extraSpace then " ." else "." + +{----- HsTyVarBndr -----} + +class IsTyVarBndrFlag flag where + isInferred :: flag -> Bool + p_tyVarBndrFlag :: flag -> R () + p_tyVarBndrFlag _ = pure () + +instance IsTyVarBndrFlag () where + isInferred () = False + +instance IsTyVarBndrFlag Specificity where + isInferred = \case + InferredSpec -> True + SpecifiedSpec -> False + +instance IsTyVarBndrFlag (HsBndrVis GhcPs) where + isInferred _ = False + p_tyVarBndrFlag = \case + HsBndrRequired NoExtField -> pure () + HsBndrInvisible _ -> txt "@" + +p_hsTyVarBndr :: + (IsTyVarBndrFlag flag, FunReprHsType) => + HsTyVarBndr flag GhcPs -> R () +p_hsTyVarBndr HsTvb {..} = do + p_tyVarBndrFlag tvb_flag + let wrap + | isInferred tvb_flag = braces N + | otherwise = case tvb_kind of + HsBndrKind {} -> parens N + HsBndrNoKind {} -> id + wrap $ do + case tvb_var of + HsBndrVar _ x -> p_rdrName x + HsBndrWildCard _ -> txt "_" + case tvb_kind of + HsBndrKind _ k -> inci $ do + p_hsFunParsed @(HsType GhcPs) $ + ParsedFunSig + { sig = (), + next = parseFunRepr k + } + HsBndrNoKind _ -> pure () + +{----- Contexts -----} + +p_hsContext' :: + (Outputable (GenLocated (Anno a) a), HasLoc (Anno a)) => + (a -> R ()) -> + [XRec GhcPs a] -> + R () +p_hsContext' f = \case + [] -> txt "()" + [x] -> located x f + xs -> do + shouldSort <- getPrinterOpt poSortConstraints + let sort = if shouldSort then sortOn showOutputable else id + parens N $ sep commaDel (sitcc . located' f) (sort xs) + +{----- Helpers -----} + +withHaddocks :: (MonadR m) => Choice "end" -> Maybe (LHsDoc GhcPs) -> m a -> m a +withHaddocks isEnd doc m = do + isTrailing <- getIsTrailing + isLeadingHaddock <- + liftR $ + getPrinterOpt poHaddockLocSignature <&> \case + HaddockLocSigAuto -> + if isTrailing (Is #argDelim) then With #pipe else Without #pipe + HaddockLocSigLeading -> + With #pipe + HaddockLocSigTrailing -> + Without #pipe + + if Choice.isTrue isLeadingHaddock + then do + traverse (liftR . p_hsDoc Pipe (With #endNewline)) doc *> m + else do + let (pre, endNewline) = + if Choice.isTrue isEnd + then (when (isJust doc) (liftR newline), Without #endNewline) + else (pure (), With #endNewline) + m <* pre <* traverse (liftR . p_hsDoc Caret endNewline) doc + +interArgBreak :: PrintHsFun () +interArgBreak = do + isMultiline <- getIsMultiline + liftR $ if isMultiline then newline else breakpoint diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -73,14 +73,14 @@ -- | Split and normalize a doc string. The result is a list of lines that -- make up the comment. -splitDocString :: Bool -> HsDocString -> [Text] -splitDocString shouldEscapeCommentBraces docStr = +splitDocString :: HsDocString -> [Text] +splitDocString docStr = case r of [] -> [""] _ -> r where r = - fmap (escapeLeadingDollar . escapeCommentBraces) + fmap escapeLeadingDollar . dropPaddingSpace' . dropWhileEnd T.null . fmap (T.stripEnd . T.pack) @@ -117,10 +117,6 @@ in if leadingSpace x then dropSpace <$> xs else xs - escapeCommentBraces = - if shouldEscapeCommentBraces - then T.replace "{-" "{\\-" . T.replace "-}" "-\\}" - else id -- | Increment line number in a 'SrcSpan'. incSpanLine :: Int -> SrcSpan -> SrcSpan diff --git a/src/Ormolu/Utils/Glob.hs b/src/Ormolu/Utils/Glob.hs --- a/src/Ormolu/Utils/Glob.hs +++ b/src/Ormolu/Utils/Glob.hs @@ -1,6 +1,7 @@ module Ormolu.Utils.Glob ( Glob, mkGlob, + matchAllGlob, matchesGlob, ) where @@ -31,6 +32,9 @@ t -> let (m, t') = break (== '*') t in MatchExactly m : parsePart t' + +matchAllGlob :: Glob +matchAllGlob = Glob [DoubleWildcard] matchesGlob :: String -> Glob -> Bool matchesGlob s (Glob ps) = s `matchesGlobParts` ps diff --git a/tests/Ormolu/Config/PrinterOptsSpec.hs b/tests/Ormolu/Config/PrinterOptsSpec.hs --- a/tests/Ormolu/Config/PrinterOptsSpec.hs +++ b/tests/Ormolu/Config/PrinterOptsSpec.hs @@ -13,6 +13,7 @@ import Control.Monad (forM_, when) import Data.Algorithm.DiffContext qualified as Diff import Data.Char (isSpace) +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (isJust) import Data.Set qualified as S @@ -26,7 +27,7 @@ import Ormolu.Config import Ormolu.Exception (OrmoluException, printOrmoluException) import Ormolu.Terminal (runTerm) -import Ormolu.Utils.Glob (mkGlob) +import Ormolu.Utils.Glob (matchAllGlob, mkGlob) import Path ( File, Path, @@ -111,6 +112,24 @@ checkIdempotence = True }, TestGroup + { label = "record-style", + isMulti = False, + testCases = liftA2 (,) allOptions allOptions, + updateConfig = \(recordStyle, commaStyle) opts -> + opts + { poRecordStyle = pure recordStyle, + -- Test record style in combination with comma style + poCommaStyle = pure commaStyle, + -- Makes the indentation more visible + poIndentation = pure 4 + }, + showTestCase = \(recordStyle, commaStyle) -> + [ renderPrinterOpt recordStyle, + renderPrinterOpt commaStyle + ], + checkIdempotence = True + }, + TestGroup { label = "import-export", isMulti = True, testCases = allOptions, @@ -130,62 +149,7 @@ ImportGroupByQualified, ImportGroupByScope, ImportGroupByScopeThenQualified, - ImportGroupCustom . NonEmpty.fromList $ - [ ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "Data.Text"), - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = defaultImportRulePriority - } - ] - }, - ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchAllModules, - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = ImportRulePriority 100 - } - ] - }, - ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "SomeInternal.**"), - igrQualifiedMatcher = MatchQualifiedOnly, - igrPriority = defaultImportRulePriority - }, - ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "Unknown.**"), - igrQualifiedMatcher = MatchUnqualifiedOnly, - igrPriority = defaultImportRulePriority - } - ] - }, - ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchLocalModules, - igrQualifiedMatcher = MatchUnqualifiedOnly, - igrPriority = defaultImportRulePriority - }, - ImportGroupRule - { igrModuleMatcher = MatchAllModules, - igrQualifiedMatcher = MatchQualifiedOnly, - igrPriority = defaultImportRulePriority - } - ] - } - ] + ImportGroupCustom importGroupCustomRules ], updateConfig = \igs opts -> opts @@ -525,3 +489,58 @@ spanEnd f xs = let xs' = reverse xs in (reverse $ dropWhile f xs', reverse $ takeWhile f xs') + +importGroupCustomRules :: NonEmpty ImportGroup +importGroupCustomRules = + NonEmpty.fromList + [ defaultImportGroup . NonEmpty.fromList $ + [ defaultImportGroupRule + { igrImportListMatcher = MatchWholeModuleImport, + igrQualifiedMatcher = MatchUnqualifiedOnly + } + ], + defaultImportGroup . NonEmpty.fromList $ + [ defaultImportGroupRule {igrGlob = mkGlob "Data.Text"} + ], + defaultImportGroup . NonEmpty.fromList $ + [ defaultImportGroupRule + { igrPriority = ImportRulePriority 100 + } + ], + defaultImportGroup . NonEmpty.fromList $ + [ defaultImportGroupRule + { igrGlob = mkGlob "SomeInternal.**", + igrQualifiedMatcher = MatchQualifiedOnly + }, + defaultImportGroupRule + { igrGlob = mkGlob "Unknown.**", + igrQualifiedMatcher = MatchUnqualifiedOnly + } + ], + defaultImportGroup . NonEmpty.fromList $ + [ defaultImportGroupRule + { igrQualifiedMatcher = MatchUnqualifiedOnly, + igrScopeMatcher = MatchLocalModules + }, + defaultImportGroupRule + { igrQualifiedMatcher = MatchQualifiedOnly + } + ] + ] + where + defaultImportGroup :: NonEmpty ImportGroupRule -> ImportGroup + defaultImportGroup rules = + ImportGroup + { igName = Nothing, + igRules = rules + } + + defaultImportGroupRule :: ImportGroupRule + defaultImportGroupRule = + ImportGroupRule + { igrGlob = matchAllGlob, + igrImportListMatcher = MatchAnyImportDeclaration, + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrScopeMatcher = MatchAllModules, + igrPriority = defaultImportRulePriority + } diff --git a/tests/Ormolu/ConfigSpec.hs b/tests/Ormolu/ConfigSpec.hs --- a/tests/Ormolu/ConfigSpec.hs +++ b/tests/Ormolu/ConfigSpec.hs @@ -3,14 +3,16 @@ -- | Tests for Fourmolu file configuration. module Ormolu.ConfigSpec (spec) where +import Control.Monad ((>=>)) import Data.ByteString.Char8 qualified as Char8 import Data.List (isInfixOf) +import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.Yaml qualified as Yaml -import Ormolu.Config (FourmoluConfig (..), ImportGroup (..), ImportGroupRule (..), ImportGrouping (..), ImportModuleMatcher (..), ImportRulePriority (ImportRulePriority), PrinterOpts (..), QualifiedImportMatcher (MatchBothQualifiedAndUnqualified, MatchQualifiedOnly, MatchUnqualifiedOnly), defaultImportRulePriority, matchAllRulePriority, resolvePrinterOpts) +import Ormolu.Config import Ormolu.Fixity (ModuleReexports (..)) -import Ormolu.Utils.Glob (mkGlob) +import Ormolu.Utils.Glob (matchAllGlob, mkGlob) import Test.Hspec spec :: Spec @@ -71,165 +73,84 @@ [ "import-grouping:", " - name: Some name", " rules:", - " - match: all" + " - {}" ] let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) expectedRules = NonEmpty.fromList [ ImportGroup { igName = Just "Some name", - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchAllModules, - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = matchAllRulePriority - } - ] - } - ] - actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) - it "enables the 'qualified' rule option" $ do - config <- - Yaml.decodeThrow . Char8.pack . unlines $ - [ "import-grouping:", - " - rules:", - " - glob: \"**\"", - " qualified: yes" - ] - let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) - expectedRules = - NonEmpty.fromList - [ ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "**"), - igrQualifiedMatcher = MatchQualifiedOnly, - igrPriority = defaultImportRulePriority - } - ] - } - ] - actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) - it "disables the 'qualified' rule option" $ do - config <- - Yaml.decodeThrow . Char8.pack . unlines $ - [ "import-grouping:", - " - rules:", - " - glob: \"**\"", - " qualified: no" - ] - let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) - expectedRules = - NonEmpty.fromList - [ ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "**"), - igrQualifiedMatcher = MatchUnqualifiedOnly, - igrPriority = defaultImportRulePriority - } - ] - } - ] - actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) - it "decodes the 'priority' rule option" $ do - config <- - Yaml.decodeThrow . Char8.pack . unlines $ - [ "import-grouping:", - " - rules:", - " - match: all", - " priority: 55" - ] - let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) - expectedRules = - NonEmpty.fromList - [ ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchAllModules, - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = ImportRulePriority 55 - } - ] - } - ] - actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) - it "parses a 'glob' rule" $ do - config <- - Yaml.decodeThrow . Char8.pack . unlines $ - [ "import-grouping:", - " - rules:", - " - glob: Data.Text.**" - ] - let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) - expectedRules = - NonEmpty.fromList - [ ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "Data.Text.**"), - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = defaultImportRulePriority - } - ] - } - ] - actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) - it "parses a 'match' rule for local modules" $ do - config <- - Yaml.decodeThrow . Char8.pack . unlines $ - [ "import-grouping:", - " - rules:", - " - match: local-modules" - ] - let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) - expectedRules = - NonEmpty.fromList - [ ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchLocalModules, - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = defaultImportRulePriority - } - ] - } - ] - actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) - it "parses a 'match' rule for all modules" $ do - config <- - Yaml.decodeThrow . Char8.pack . unlines $ - [ "import-grouping:", - " - rules:", - " - match: all" - ] - let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) - expectedRules = - NonEmpty.fromList - [ ImportGroup - { igName = Nothing, - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchAllModules, - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = matchAllRulePriority - } - ] + igRules = NonEmpty.fromList [defaultImportGroupRule] } ] actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) + + let checkRule :: (HasCallStack) => String -> String -> ImportGroupRule -> SpecWith () + checkRule desc yamlRuleConfig expectedRuleConfig = + it ("parses " ++ desc) $ do + let yamlConfig = + unlines + [ "import-grouping:", + " - rules:", + " - " ++ yamlRuleConfig + ] + + downCustomRules (ImportGroupCustom customRules) = Just customRules + downCustomRules _ = Nothing + downSingleton (a :| []) = Just a + downSingleton _ = Nothing + accessTestedRule = downCustomRules >=> downSingleton >=> downSingleton . igRules + + config <- Yaml.decodeThrow (Char8.pack yamlConfig) + + let actualStrategy = poImportGrouping (cfgFilePrinterOpts config) + case actualStrategy >>= accessTestedRule of + Nothing -> expectationFailure "A single tested rule change was expected" + Just actualRule -> actualRule `shouldBe` expectedRuleConfig + + checkRuleAttribute :: (HasCallStack) => String -> String -> (ImportGroupRule -> ImportGroupRule) -> SpecWith () + checkRuleAttribute desc yamlRuleConfig applyExpectedChange = do + let baseArbitraryYamlConfig = "glob: \"**\"" + yamlConfig = "{ " ++ baseArbitraryYamlConfig ++ ", " ++ yamlRuleConfig ++ "}" + + baseArbitraryConfig = defaultImportGroupRule {igrGlob = matchAllGlob} + expectedRuleConfig = applyExpectedChange baseArbitraryConfig + checkRule + ("rules with the " ++ desc ++ " rule option") + yamlConfig + expectedRuleConfig + + checkRule "the 'glob' rule" "glob: Data.Text.**" defaultImportGroupRule {igrGlob = mkGlob "Data.Text.**"} + checkRule "the default 'glob' rule (match all modules)" "{}" defaultImportGroupRule {igrGlob = mkGlob "**"} + + checkRuleAttribute "'any' import list" "import-list: any" $ \config -> config {igrImportListMatcher = MatchAnyImportDeclaration} + checkRuleAttribute "'explicit' import list" "import-list: explicit" $ \config -> config {igrImportListMatcher = MatchExplicitImportList} + checkRuleAttribute "'hiding' import list" "import-list: hiding" $ \config -> config {igrImportListMatcher = MatchHidingImportClause} + checkRuleAttribute "'none' import list" "import-list: none" $ \config -> config {igrImportListMatcher = MatchWholeModuleImport} + checkRuleAttribute "default import list" "" $ \config -> config {igrImportListMatcher = MatchAnyImportDeclaration} + + checkRuleAttribute "'qualified: yes'" "qualified: yes" $ \config -> config {igrQualifiedMatcher = MatchQualifiedOnly} + checkRuleAttribute "'qualified: no'" "qualified: no" $ \config -> config {igrQualifiedMatcher = MatchUnqualifiedOnly} + checkRuleAttribute "default 'qualified' (match any)" "" $ \config -> config {igrQualifiedMatcher = MatchBothQualifiedAndUnqualified} + + checkRuleAttribute "'scope: any'" "scope: any" $ \config -> config {igrScopeMatcher = MatchAllModules} + checkRuleAttribute "'scope: local'" "scope: local" $ \config -> config {igrScopeMatcher = MatchLocalModules} + checkRuleAttribute "'scope: external'" "scope: external" $ \config -> config {igrScopeMatcher = MatchExternalModules} + checkRuleAttribute "default 'scope' (match all)" "" $ \config -> config {igrScopeMatcher = MatchAllModules} + + checkRuleAttribute "'priority' (55 priority example)" "priority: 55" $ \config -> config {igrPriority = ImportRulePriority 55} + checkRuleAttribute "'priority' (80 priority example)" "priority: 80" $ \config -> config {igrPriority = ImportRulePriority 80} + checkRuleAttribute "default 'priority' (50)" "" $ \config -> config {igrPriority = ImportRulePriority 50} + + checkRule + "the legacy 'match' rule for all modules (with a 100 priority)" + "match: all" + defaultImportGroupRule {igrGlob = mkGlob "**", igrScopeMatcher = MatchAllModules, igrPriority = ImportRulePriority 100} + checkRule + "the legacy 'match' rule for local modules" + "match: local-modules" + defaultImportGroupRule {igrGlob = mkGlob "**", igrScopeMatcher = MatchLocalModules, igrPriority = ImportRulePriority 60} + it "parses multiple group configurations and rules in their order of appearance in the configuration" $ do config <- Yaml.decodeThrow . Char8.pack . unlines $ @@ -240,7 +161,6 @@ " - name: The rest", " rules:", " - match: all", - " priority: 100", " - name: My internals and monads unqualified", " rules:", " - match: local-modules", @@ -262,68 +182,31 @@ NonEmpty.fromList [ ImportGroup { igName = Just "Text modules", - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "Data.Text"), - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = defaultImportRulePriority - } - ] + igRules = NonEmpty.fromList [defaultImportGroupRule {igrGlob = mkGlob "Data.Text"}] }, ImportGroup { igName = Just "The rest", - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchAllModules, - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = ImportRulePriority 100 - } - ] + igRules = NonEmpty.fromList [defaultImportGroupRule {igrGlob = matchAllGlob, igrPriority = ImportRulePriority 100}] }, ImportGroup { igName = Just "My internals and monads unqualified", igRules = NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchLocalModules, - igrQualifiedMatcher = MatchUnqualifiedOnly, - igrPriority = defaultImportRulePriority - }, - ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "Control.Monad"), - igrQualifiedMatcher = MatchUnqualifiedOnly, - igrPriority = defaultImportRulePriority - } + [ defaultImportGroupRule {igrQualifiedMatcher = MatchUnqualifiedOnly, igrScopeMatcher = MatchLocalModules, igrPriority = ImportRulePriority 60}, + defaultImportGroupRule {igrGlob = mkGlob "Control.Monad", igrQualifiedMatcher = MatchUnqualifiedOnly} ] }, ImportGroup { igName = Just "My internals and monads qualified", igRules = NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchLocalModules, - igrQualifiedMatcher = MatchQualifiedOnly, - igrPriority = defaultImportRulePriority - }, - ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "Control.Monad"), - igrQualifiedMatcher = MatchQualifiedOnly, - igrPriority = defaultImportRulePriority - } + [ defaultImportGroupRule {igrQualifiedMatcher = MatchQualifiedOnly, igrScopeMatcher = MatchLocalModules, igrPriority = ImportRulePriority 60}, + defaultImportGroupRule {igrGlob = mkGlob "Control.Monad", igrQualifiedMatcher = MatchQualifiedOnly} ] }, ImportGroup { igName = Just "Specific monads", - igRules = - NonEmpty.fromList - [ ImportGroupRule - { igrModuleMatcher = MatchGlob (mkGlob "Control.Monad.**"), - igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, - igrPriority = defaultImportRulePriority - } - ] + igRules = NonEmpty.fromList [defaultImportGroupRule {igrGlob = mkGlob "Control.Monad.**"}] } ] actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules) @@ -332,9 +215,19 @@ Yaml.decodeEither' @FourmoluConfig . Char8.pack . unlines $ [ "import-grouping:", " - rules:", - " - some-unknown-rule-type: whatever" + " - match: whatever" ] isAnUnknownModuleMatcher e = case e of - Left (Yaml.AesonException msg) -> "Unknown or invalid module matcher" `isInfixOf` msg + Left (Yaml.AesonException msg) -> "Unknown legacy match value" `isInfixOf` msg _ -> False decodeResult `shouldSatisfy` isAnUnknownModuleMatcher + +defaultImportGroupRule :: ImportGroupRule +defaultImportGroupRule = + ImportGroupRule + { igrGlob = matchAllGlob, + igrImportListMatcher = MatchAnyImportDeclaration, + igrQualifiedMatcher = MatchBothQualifiedAndUnqualified, + igrScopeMatcher = MatchAllModules, + igrPriority = defaultImportRulePriority + } diff --git a/tests/Ormolu/Fixity/ParserSpec.hs b/tests/Ormolu/Fixity/ParserSpec.hs --- a/tests/Ormolu/Fixity/ParserSpec.hs +++ b/tests/Ormolu/Fixity/ParserSpec.hs @@ -214,7 +214,7 @@ elabel "module name" ] ) - it "fails with correct parse error (typo: export intead exports)" $ + it "fails with correct parse error (typo: export instead exports)" $ parseModuleReexportDeclaration "module Control.Lens export Control.Lens.Lens" `shouldFailWith` err 20 diff --git a/tests/Ormolu/Integration/Utils.hs b/tests/Ormolu/Integration/Utils.hs --- a/tests/Ormolu/Integration/Utils.hs +++ b/tests/Ormolu/Integration/Utils.hs @@ -10,15 +10,16 @@ where import Control.Monad (when) -import System.Directory (findExecutable) +import System.Directory (findExecutable, makeAbsolute) import System.Environment (getEnvironment) import System.Exit (ExitCode (..)) import System.Process (CreateProcess (..), readCreateProcessWithExitCode) import System.Process qualified as Process -- | Find a `fourmolu` executable on PATH. +-- Needs to be absolute to work around https://github.com/haskell/cabal/issues/11598 getFourmoluExe :: IO FilePath -getFourmoluExe = findExecutable "fourmolu" >>= maybe (fail "Could not find fourmolu executable") return +getFourmoluExe = findExecutable "fourmolu" >>= maybe (fail "Could not find fourmolu executable") makeAbsolute -- | Like 'System.Process.readProcess', except without specifying stdin and -- with better failure messages.