1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
|
--------------------------------------------------------------------------------
module Language.Haskell.Stylish.Step.UnicodeSyntax
( step
) where
--------------------------------------------------------------------------------
import qualified GHC.Hs as GHC
import qualified GHC.Types.SrcLoc as GHC
--------------------------------------------------------------------------------
import qualified Language.Haskell.Stylish.Editor as Editor
import Language.Haskell.Stylish.Module
import Language.Haskell.Stylish.Step
import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma)
import Language.Haskell.Stylish.Util (everything)
--------------------------------------------------------------------------------
hsTyReplacements :: GHC.HsType GHC.GhcPs -> Editor.Edits
hsTyReplacements (GHC.HsFunTy _ arr _ _)
| GHC.HsUnrestrictedArrow (GHC.EpUniTok epaLoc GHC.NormalSyntax) <- arr =
Editor.replaceRealSrcSpan (GHC.epaLocationRealSrcSpan epaLoc) "→"
hsTyReplacements (GHC.HsQualTy _ ctx _)
| Just arrow <- GHC.ac_darrow . GHC.anns $ GHC.getLoc ctx
, (GHC.EpUniTok (GHC.EpaSpan (GHC.RealSrcSpan loc _)) GHC.NormalSyntax) <- arrow =
Editor.replaceRealSrcSpan loc "⇒"
hsTyReplacements _ = mempty
--------------------------------------------------------------------------------
hsSigReplacements :: GHC.Sig GHC.GhcPs -> Editor.Edits
hsSigReplacements (GHC.TypeSig ann _ _)
| GHC.EpUniTok epaLoc _ <- GHC.asDcolon ann
, GHC.EpaSpan (GHC.RealSrcSpan loc _) <- epaLoc =
Editor.replaceRealSrcSpan loc "∷"
hsSigReplacements _ = mempty
--------------------------------------------------------------------------------
step :: Bool -> String -> Step
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) <>
(if alp then addLanguagePragma lg "UnicodeSyntax" modu else mempty)
|
