More unicode syntax replacements

lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs

@@ -1,4 +1,8 @@
 --------------------------------------------------------------------------------
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 module Language.Haskell.Stylish.Step.UnicodeSyntax
     ( step
     ) where
@@ -16,25 +20,56 @@ 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
+
+
+--------------------------------------------------------------------------------
+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 "←"
+    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
+
 
 --------------------------------------------------------------------------------
-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 =
-        Editor.replaceRealSrcSpan loc "∷"
-hsSigReplacements _ = 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
+
 
 
 --------------------------------------------------------------------------------
@@ -47,6 +82,8 @@ 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) <>
+        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)

tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs

@@ -22,6 +22,13 @@ 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
+    , testCase "case 06 (Forall)" case06
+    , testCase "case 07 (do notation)" case07
+    , testCase "case 08 (arrow syntax)" case08
+    , testCase "case 09 (TH quotes)" case09
+    , testCase "case 10 (Star type)" case10
     ]
 
 
@@ -58,3 +65,116 @@ 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"
+    ]
+
+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"
+    ]
+
+case07 :: Assertion
+case07 = assertSnippet (step False "LANGUAGE")
+    [ "main :: IO ()"
+    , "  main = do"
+    , "  s <- getLine"
+    , "  putStrLn s"
+    ]
+    [ "main ∷ IO ()"
+    , "  main = do"
+    , "  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 ⟧"
+    ]
+
+case10 :: Assertion
+case10 = assertSnippet (step False "LANGUAGE")
+    [ "{-# LANGUAGE KindSignatures #-}"
+    , ""
+    , "data A (a :: *) = A a"
+    ]
+    [ "{-# LANGUAGE KindSignatures #-}"
+    , ""
+    , "data A (a ∷ ★) = A a"
+    ]