diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 04626433..8c07b35a 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/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) diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs index 788e8a92..fae1986f 100644 --- a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs +++ b/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" + ]