From 9205a56612e00e9182c811bf9fa65d63ec11d8b5 Mon Sep 17 00:00:00 2001 From: Lev Dvorkin Date: Tue, 27 Dec 2022 21:40:37 +0300 Subject: [PATCH 1/5] Unicode arrows in GADTs & linear arrows implemented --- .../Haskell/Stylish/Step/UnicodeSyntax.hs | 42 ++++++++++++------- .../Stylish/Step/UnicodeSyntax/Tests.hs | 36 ++++++++++++++++ 2 files changed, 62 insertions(+), 16 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 04626433..438f1066 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -1,4 +1,7 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} module Language.Haskell.Stylish.Step.UnicodeSyntax ( step ) where @@ -16,25 +19,32 @@ import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) import Language.Haskell.Stylish.Util (everything) +-------------------------------------------------------------------------------- +hsArrowReplacements :: GHC.HsArrow GHC.GhcPs -> Editor.Edits +hsArrowReplacements = \case + GHC.HsUnrestrictedArrow (GHC.L (GHC.TokenLoc l) GHC.HsNormalTok) -> + Editor.replaceRealSrcSpan (GHC.epaLocationRealSrcSpan l) "→" + GHC.HsLinearArrow (GHC.HsPct1 _ (GHC.L (GHC.TokenLoc l) GHC.HsNormalTok)) -> + Editor.replaceRealSrcSpan (GHC.epaLocationRealSrcSpan l) "→" + GHC.HsExplicitMult _ _ (GHC.L (GHC.TokenLoc l) GHC.HsNormalTok) -> + Editor.replaceRealSrcSpan (GHC.epaLocationRealSrcSpan l) "→" + _ -> mempty + -------------------------------------------------------------------------------- -hsTyReplacements :: GHC.HsType GHC.GhcPs -> Editor.Edits -hsTyReplacements (GHC.HsFunTy _ arr _ _) - | GHC.HsUnrestrictedArrow (GHC.L (GHC.TokenLoc epaLoc) GHC.HsNormalTok) <- arr= - Editor.replaceRealSrcSpan (GHC.epaLocationRealSrcSpan epaLoc) "→" -hsTyReplacements (GHC.HsQualTy _ ctx _) - | Just arrow <- GHC.ac_darrow . GHC.anns . GHC.ann $ GHC.getLoc ctx - , (GHC.NormalSyntax, GHC.EpaSpan loc) <- arrow = +hsAnnContextReplacements :: GHC.AnnContext -> Editor.Edits +hsAnnContextReplacements (GHC.AnnContext{GHC.ac_darrow}) + | Just (GHC.NormalSyntax, GHC.EpaSpan loc) <- ac_darrow = Editor.replaceRealSrcSpan loc "⇒" -hsTyReplacements _ = mempty + | otherwise = mempty + -------------------------------------------------------------------------------- -hsSigReplacements :: GHC.Sig GHC.GhcPs -> Editor.Edits -hsSigReplacements (GHC.TypeSig ann _ _) - | GHC.AddEpAnn GHC.AnnDcolon epaLoc <- GHC.asDcolon $ GHC.anns ann - , GHC.EpaSpan loc <- epaLoc = +hsAddEpAnnReplacements :: GHC.AddEpAnn -> Editor.Edits +hsAddEpAnnReplacements (GHC.AddEpAnn GHC.AnnDcolon epaLoc) + | GHC.EpaSpan loc <- epaLoc = Editor.replaceRealSrcSpan loc "∷" -hsSigReplacements _ = mempty +hsAddEpAnnReplacements _ = mempty -------------------------------------------------------------------------------- @@ -46,7 +56,7 @@ step = (makeStep "UnicodeSyntax" .) . step' step' :: Bool -> String -> Lines -> Module -> Lines step' alp lg ls modu = Editor.apply edits ls where - edits = - foldMap hsTyReplacements (everything modu) <> - foldMap hsSigReplacements (everything modu) <> + edits = foldMap hsArrowReplacements (everything modu) <> + foldMap hsAnnContextReplacements (everything modu) <> + foldMap hsAddEpAnnReplacements (everything modu) <> (if alp then addLanguagePragma lg "UnicodeSyntax" modu else mempty) diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs index 788e8a92..f2dd6ff1 100644 --- a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -22,6 +22,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" [ testCase "case 01" case01 , testCase "case 02" case02 , testCase "case 03" case03 + , testCase "case 04 (GADTs)" case04 + , testCase "case 05 (Linear types)" case05 ] @@ -58,3 +60,37 @@ case03 = assertSnippet (step False "LANGUAGE") [ "x ∷ Int → Int → Int" , "x = undefined" ] + +case04 :: Assertion +case04 = assertSnippet (step False "LANGUAGE") + [ "data Foo where" + , " Foo0 :: Foo" + , " Foo1 :: Int -> Foo" + , " Foo2 :: Int -> Bool -> Foo" + , " FooC :: Show a => a -> Foo" + ] + [ "data Foo where" + , " Foo0 ∷ Foo" + , " Foo1 ∷ Int → Foo" + , " Foo2 ∷ Int → Bool → Foo" + , " FooC ∷ Show a ⇒ a → Foo" + ] + +case05 :: Assertion +case05 = assertSnippet (step False "LANGUAGE") + [ "{-# LANGUAGE LinearTypes #-}" + , "" + , "construct :: Int -> a %1 -> T1 a" + , "construct _ x = MkT1 x" + , "" + , "data T3 a m where" + , " MkT3 :: a %m -> T3 a m" + ] + [ "{-# LANGUAGE LinearTypes #-}" + , "" + , "construct ∷ Int → a %1 → T1 a" + , "construct _ x = MkT1 x" + , "" + , "data T3 a m where" + , " MkT3 ∷ a %m → T3 a m" + ] From 1a28c6b9d6314b1a2d7106d75e5781e55933e528 Mon Sep 17 00:00:00 2001 From: Lev Dvorkin Date: Tue, 27 Dec 2022 21:57:18 +0300 Subject: [PATCH 2/5] Unicode forall symbol replacement --- .../Haskell/Stylish/Step/UnicodeSyntax.hs | 7 ++--- .../Stylish/Step/UnicodeSyntax/Tests.hs | 26 +++++++++++++++++++ 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 438f1066..77ab665c 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -41,9 +41,10 @@ hsAnnContextReplacements (GHC.AnnContext{GHC.ac_darrow}) -------------------------------------------------------------------------------- hsAddEpAnnReplacements :: GHC.AddEpAnn -> Editor.Edits -hsAddEpAnnReplacements (GHC.AddEpAnn GHC.AnnDcolon epaLoc) - | GHC.EpaSpan loc <- epaLoc = - Editor.replaceRealSrcSpan loc "∷" +hsAddEpAnnReplacements (GHC.AddEpAnn el (GHC.EpaSpan loc)) = case el of + GHC.AnnDcolon -> Editor.replaceRealSrcSpan loc "∷" + GHC.AnnForall -> Editor.replaceRealSrcSpan loc "∀" + _ -> mempty hsAddEpAnnReplacements _ = mempty diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs index f2dd6ff1..4824dfa8 100644 --- a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -24,6 +24,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" , testCase "case 03" case03 , testCase "case 04 (GADTs)" case04 , testCase "case 05 (Linear types)" case05 + , testCase "case 06 (Forall)" case06 ] @@ -94,3 +95,28 @@ case05 = assertSnippet (step False "LANGUAGE") , "data T3 a m where" , " MkT3 ∷ a %m → T3 a m" ] + +case06 :: Assertion +case06 = assertSnippet (step False "LANGUAGE") + [ "{-# LANGUAGE ScopedTypeVariables #-}" + , "" + , "err :: forall a. a" + , "err = undefined" + , "" + , "foo :: forall a. Int -> (forall b. Show b => b -> a) -> Bool" + , "foo = undefined" + , "" + , "data Foo where" + , " Foo :: forall a. Show a => a -> Foo" + ] + [ "{-# LANGUAGE ScopedTypeVariables #-}" + , "" + , "err ∷ ∀ a. a" + , "err = undefined" + , "" + , "foo ∷ ∀ a. Int → (∀ b. Show b ⇒ b → a) → Bool" + , "foo = undefined" + , "" + , "data Foo where" + , " Foo ∷ ∀ a. Show a ⇒ a → Foo" + ] From 3feaa6258d3f2304a0184b9c0a1326949c0f0ef2 Mon Sep 17 00:00:00 2001 From: Lev Dvorkin Date: Tue, 27 Dec 2022 22:20:32 +0300 Subject: [PATCH 3/5] do-notation <- replacement --- lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs | 1 + .../Haskell/Stylish/Step/UnicodeSyntax/Tests.hs | 14 ++++++++++++++ 2 files changed, 15 insertions(+) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 77ab665c..722ac86b 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -44,6 +44,7 @@ hsAddEpAnnReplacements :: GHC.AddEpAnn -> Editor.Edits hsAddEpAnnReplacements (GHC.AddEpAnn el (GHC.EpaSpan loc)) = case el of GHC.AnnDcolon -> Editor.replaceRealSrcSpan loc "∷" GHC.AnnForall -> Editor.replaceRealSrcSpan loc "∀" + GHC.AnnLarrow -> Editor.replaceRealSrcSpan loc "←" _ -> mempty hsAddEpAnnReplacements _ = mempty diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs index 4824dfa8..7a9e9c7f 100644 --- a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -25,6 +25,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" , testCase "case 04 (GADTs)" case04 , testCase "case 05 (Linear types)" case05 , testCase "case 06 (Forall)" case06 + , testCase "case 07 (do notation)" case07 ] @@ -120,3 +121,16 @@ case06 = assertSnippet (step False "LANGUAGE") , "data Foo where" , " Foo ∷ ∀ a. Show a ⇒ a → Foo" ] + +case07 :: Assertion +case07 = assertSnippet (step False "LANGUAGE") + [ "main :: IO ()" + , " main = do" + , " s <- getLine" + , " putStrLn s" + ] + [ "main ∷ IO ()" + , " main = do" + , " s ← getLine" + , " putStrLn s" + ] From 0b4af856c19e84f29ca35b90d5d58aebe147ca0c Mon Sep 17 00:00:00 2001 From: Lev Dvorkin Date: Tue, 27 Dec 2022 23:32:20 +0300 Subject: [PATCH 4/5] All other unicode symbols are added to replace list --- .../Haskell/Stylish/Step/UnicodeSyntax.hs | 13 ++++++++ .../Stylish/Step/UnicodeSyntax/Tests.hs | 32 +++++++++++++++++++ 2 files changed, 45 insertions(+) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 722ac86b..2846a263 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -45,6 +45,19 @@ hsAddEpAnnReplacements (GHC.AddEpAnn el (GHC.EpaSpan loc)) = case el of GHC.AnnDcolon -> Editor.replaceRealSrcSpan loc "∷" GHC.AnnForall -> Editor.replaceRealSrcSpan loc "∀" GHC.AnnLarrow -> Editor.replaceRealSrcSpan loc "←" + GHC.Annlarrowtail -> Editor.replaceRealSrcSpan loc "⤙" + GHC.Annrarrowtail -> Editor.replaceRealSrcSpan loc "→" + GHC.AnnLarrowtail -> Editor.replaceRealSrcSpan loc "⤛" + GHC.AnnRarrowtail -> Editor.replaceRealSrcSpan loc "⤜" + GHC.AnnOpenB -> Editor.replaceRealSrcSpan loc "⦇" + GHC.AnnCloseB -> Editor.replaceRealSrcSpan loc "⦈" + GHC.AnnOpenEQ -> Editor.replaceRealSrcSpan loc "⟦" + GHC.AnnCloseQ -> Editor.replaceRealSrcSpan loc "⟧" + -- doesn't work here, as far as I can see, so implemented + -- in separate functions: + GHC.AnnDarrow -> Editor.replaceRealSrcSpan loc "⇒" + GHC.AnnRarrow -> Editor.replaceRealSrcSpan loc "→" + _ -> mempty hsAddEpAnnReplacements _ = mempty diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs index 7a9e9c7f..74bee90a 100644 --- a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -26,6 +26,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" , testCase "case 05 (Linear types)" case05 , testCase "case 06 (Forall)" case06 , testCase "case 07 (do notation)" case07 + , testCase "case 08 (arrow syntax)" case08 + , testCase "case 09 (TH quotes)" case09 ] @@ -134,3 +136,33 @@ case07 = assertSnippet (step False "LANGUAGE") , " s ← getLine" , " putStrLn s" ] + +case08 :: Assertion +case08 = assertSnippet (step False "LANGUAGE") + [ "{-# LANGUAGE Arrows #-}" + , "" + , "a = proc x -> do" + , " y <- f -< x+1" + , " (|untilA (increment -< x+y) (within 0.5 -< x)|)" + , "" + , "b = proc x -> f x -<< x+1" + ] + [ "{-# LANGUAGE Arrows #-}" + , "" + , "a = proc x → do" + , " y ← f ⤙ x+1" + , " ⦇untilA (increment ⤙ x+y) (within 0.5 ⤙ x)⦈" + , "" + , "b = proc x → f x ⤛ x+1" + ] + +case09 :: Assertion +case09 = assertSnippet (step False "LANGUAGE") + [ "{-# LANGUAGE QuasiQuotes #-}" + , "" + , "exp = [| 2 + 2 |]" + ] + [ "{-# LANGUAGE QuasiQuotes #-}" + , "" + , "exp = ⟦ 2 + 2 ⟧" + ] From dfd4d72da228c00585011ad12702017f277e15d6 Mon Sep 17 00:00:00 2001 From: Lev Dvorkin Date: Wed, 28 Dec 2022 00:35:47 +0300 Subject: [PATCH 5/5] Star type replacement added --- lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs | 14 +++++++++++++- .../Haskell/Stylish/Step/UnicodeSyntax/Tests.hs | 12 ++++++++++++ 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 2846a263..8c07b35a 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -2,6 +2,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PartialTypeSignatures #-} module Language.Haskell.Stylish.Step.UnicodeSyntax ( step ) where @@ -62,6 +63,15 @@ hsAddEpAnnReplacements (GHC.AddEpAnn el (GHC.EpaSpan loc)) = case el of hsAddEpAnnReplacements _ = mempty +-------------------------------------------------------------------------------- +hsStarTyReplacements :: GHC.LHsKind GHC.GhcPs -> Editor.Edits +hsStarTyReplacements (GHC.L loc (GHC.HsStarTy _ False)) + | (GHC.SrcSpanAnn _ (GHC.RealSrcSpan l _)) <- loc = + Editor.replaceRealSrcSpan l "★" +hsStarTyReplacements _ = mempty + + + -------------------------------------------------------------------------------- step :: Bool -> String -> Step step = (makeStep "UnicodeSyntax" .) . step' @@ -71,7 +81,9 @@ step = (makeStep "UnicodeSyntax" .) . step' step' :: Bool -> String -> Lines -> Module -> Lines step' alp lg ls modu = Editor.apply edits ls where - edits = foldMap hsArrowReplacements (everything modu) <> + edits = + foldMap hsArrowReplacements (everything modu) <> foldMap hsAnnContextReplacements (everything modu) <> foldMap hsAddEpAnnReplacements (everything modu) <> + foldMap hsStarTyReplacements (everything modu) <> (if alp then addLanguagePragma lg "UnicodeSyntax" modu else mempty) diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs index 74bee90a..fae1986f 100644 --- a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -28,6 +28,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" , testCase "case 07 (do notation)" case07 , testCase "case 08 (arrow syntax)" case08 , testCase "case 09 (TH quotes)" case09 + , testCase "case 10 (Star type)" case10 ] @@ -166,3 +167,14 @@ case09 = assertSnippet (step False "LANGUAGE") , "" , "exp = ⟦ 2 + 2 ⟧" ] + +case10 :: Assertion +case10 = assertSnippet (step False "LANGUAGE") + [ "{-# LANGUAGE KindSignatures #-}" + , "" + , "data A (a :: *) = A a" + ] + [ "{-# LANGUAGE KindSignatures #-}" + , "" + , "data A (a ∷ ★) = A a" + ]