module Language.Haskell.Stylish.Step.UnicodeSyntax
( step
) where
import qualified Data.Map as M
import qualified GHC.Hs as GHC
import qualified GHC.Types.SrcLoc as GHC
import Language.Haskell.Stylish.Editor
import Language.Haskell.Stylish.Module
import Language.Haskell.Stylish.Step
import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma)
import Language.Haskell.Stylish.Util (everything)
newtype Replacement = Replacement
{ Replacement -> Map Int [(Int, Int, String)]
unReplacement :: M.Map Int [(Int, Int, String)]
} deriving (Int -> Replacement -> ShowS
[Replacement] -> ShowS
Replacement -> String
(Int -> Replacement -> ShowS)
-> (Replacement -> String)
-> ([Replacement] -> ShowS)
-> Show Replacement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Replacement] -> ShowS
$cshowList :: [Replacement] -> ShowS
show :: Replacement -> String
$cshow :: Replacement -> String
showsPrec :: Int -> Replacement -> ShowS
$cshowsPrec :: Int -> Replacement -> ShowS
Show)
instance Semigroup Replacement where
Replacement Map Int [(Int, Int, String)]
l <> :: Replacement -> Replacement -> Replacement
<> Replacement Map Int [(Int, Int, String)]
r = Map Int [(Int, Int, String)] -> Replacement
Replacement (Map Int [(Int, Int, String)] -> Replacement)
-> Map Int [(Int, Int, String)] -> Replacement
forall a b. (a -> b) -> a -> b
$ ([(Int, Int, String)]
-> [(Int, Int, String)] -> [(Int, Int, String)])
-> Map Int [(Int, Int, String)]
-> Map Int [(Int, Int, String)]
-> Map Int [(Int, Int, String)]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith [(Int, Int, String)]
-> [(Int, Int, String)] -> [(Int, Int, String)]
forall a. [a] -> [a] -> [a]
(++) Map Int [(Int, Int, String)]
l Map Int [(Int, Int, String)]
r
instance Monoid Replacement where
mempty :: Replacement
mempty = Map Int [(Int, Int, String)] -> Replacement
Replacement Map Int [(Int, Int, String)]
forall a. Monoid a => a
mempty
mkReplacement :: GHC.RealSrcSpan -> String -> Replacement
mkReplacement :: RealSrcSpan -> String -> Replacement
mkReplacement RealSrcSpan
rss String
repl
| RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
rss Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
rss = Map Int [(Int, Int, String)] -> Replacement
Replacement Map Int [(Int, Int, String)]
forall a. Monoid a => a
mempty
| Bool
otherwise = Map Int [(Int, Int, String)] -> Replacement
Replacement (Map Int [(Int, Int, String)] -> Replacement)
-> Map Int [(Int, Int, String)] -> Replacement
forall a b. (a -> b) -> a -> b
$
Int -> [(Int, Int, String)] -> Map Int [(Int, Int, String)]
forall k a. k -> a -> Map k a
M.singleton
(RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
rss)
[(RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
rss, RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
rss, String
repl)]
applyReplacement :: Replacement -> [String] -> [String]
applyReplacement :: Replacement -> [String] -> [String]
applyReplacement (Replacement Map Int [(Int, Int, String)]
repl) [String]
ls = do
(Int
i, String
l) <- [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [String]
ls
case Int -> Map Int [(Int, Int, String)] -> Maybe [(Int, Int, String)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
i Map Int [(Int, Int, String)]
repl of
Maybe [(Int, Int, String)]
Nothing -> String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
l
Just [(Int, Int, String)]
repls -> String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ [(Int, Int, String)] -> ShowS
forall a. [(Int, Int, [a])] -> [a] -> [a]
go [(Int, Int, String)]
repls String
l
where
go :: [(Int, Int, [a])] -> [a] -> [a]
go [] [a]
l = [a]
l
go ((Int
xstart, Int
xend, [a]
x) : [(Int, Int, [a])]
repls) [a]
l =
let l' :: [a]
l' = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
xstart Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
xend Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
l in
[(Int, Int, [a])] -> [a] -> [a]
go ((Int, Int, [a]) -> (Int, Int, [a]) -> (Int, Int, [a])
forall (t :: * -> *) a c.
Foldable t =>
(Int, Int, t a) -> (Int, Int, c) -> (Int, Int, c)
adjust (Int
xstart, Int
xend, [a]
x) ((Int, Int, [a]) -> (Int, Int, [a]))
-> [(Int, Int, [a])] -> [(Int, Int, [a])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Int, [a])]
repls) [a]
l'
adjust :: (Int, Int, t a) -> (Int, Int, c) -> (Int, Int, c)
adjust (Int
xstart, Int
xend, t a
x) (Int
ystart, Int
yend, c
y)
| Int
ystart Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
xend =
let offset :: Int
offset = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
xend Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xstart) in
(Int
ystart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset, Int
yend Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset, c
y)
| Bool
otherwise = (Int
ystart, Int
yend, c
y)
hsTyReplacements :: GHC.HsType GHC.GhcPs -> Replacement
hsTyReplacements :: HsType GhcPs -> Replacement
hsTyReplacements (GHC.HsFunTy XFunTy GhcPs
xann HsArrow GhcPs
arr LHsType GhcPs
_ LHsType GhcPs
_)
| GHC.HsUnrestrictedArrow IsUnicodeSyntax
GHC.NormalSyntax <- HsArrow GhcPs
arr
, GHC.AddRarrowAnn (GHC.EpaSpan RealSrcSpan
loc) <- EpAnn TrailingAnn -> TrailingAnn
forall ann. EpAnn ann -> ann
GHC.anns XFunTy GhcPs
EpAnn TrailingAnn
xann =
RealSrcSpan -> String -> Replacement
mkReplacement RealSrcSpan
loc String
"→"
hsTyReplacements (GHC.HsQualTy XQualTy GhcPs
_ (Just LHsContext GhcPs
ctx) LHsType GhcPs
_)
| Just (IsUnicodeSyntax, EpaLocation)
arrow <- AnnContext -> Maybe (IsUnicodeSyntax, EpaLocation)
GHC.ac_darrow (AnnContext -> Maybe (IsUnicodeSyntax, EpaLocation))
-> (SrcSpanAnn' (EpAnn AnnContext) -> AnnContext)
-> SrcSpanAnn' (EpAnn AnnContext)
-> Maybe (IsUnicodeSyntax, EpaLocation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAnn AnnContext -> AnnContext
forall ann. EpAnn ann -> ann
GHC.anns (EpAnn AnnContext -> AnnContext)
-> (SrcSpanAnn' (EpAnn AnnContext) -> EpAnn AnnContext)
-> SrcSpanAnn' (EpAnn AnnContext)
-> AnnContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnn' (EpAnn AnnContext) -> EpAnn AnnContext
forall a. SrcSpanAnn' a -> a
GHC.ann (SrcSpanAnn' (EpAnn AnnContext)
-> Maybe (IsUnicodeSyntax, EpaLocation))
-> SrcSpanAnn' (EpAnn AnnContext)
-> Maybe (IsUnicodeSyntax, EpaLocation)
forall a b. (a -> b) -> a -> b
$ GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)]
-> SrcSpanAnn' (EpAnn AnnContext)
forall l e. GenLocated l e -> l
GHC.getLoc LHsContext GhcPs
GenLocated
(SrcSpanAnn' (EpAnn AnnContext))
[GenLocated SrcSpanAnnA (HsType GhcPs)]
ctx
, (IsUnicodeSyntax
GHC.NormalSyntax, GHC.EpaSpan RealSrcSpan
loc) <- (IsUnicodeSyntax, EpaLocation)
arrow =
RealSrcSpan -> String -> Replacement
mkReplacement RealSrcSpan
loc String
"⇒"
hsTyReplacements HsType GhcPs
_ = Replacement
forall a. Monoid a => a
mempty
hsSigReplacements :: GHC.Sig GHC.GhcPs -> Replacement
hsSigReplacements :: Sig GhcPs -> Replacement
hsSigReplacements (GHC.TypeSig XTypeSig GhcPs
ann [LIdP GhcPs]
_ LHsSigWcType GhcPs
_)
| GHC.AddEpAnn AnnKeywordId
GHC.AnnDcolon EpaLocation
epaLoc <- AnnSig -> AddEpAnn
GHC.asDcolon (AnnSig -> AddEpAnn) -> AnnSig -> AddEpAnn
forall a b. (a -> b) -> a -> b
$ EpAnn AnnSig -> AnnSig
forall ann. EpAnn ann -> ann
GHC.anns XTypeSig GhcPs
EpAnn AnnSig
ann
, GHC.EpaSpan RealSrcSpan
loc <- EpaLocation
epaLoc =
RealSrcSpan -> String -> Replacement
mkReplacement RealSrcSpan
loc String
"∷"
hsSigReplacements Sig GhcPs
_ = Replacement
forall a. Monoid a => a
mempty
step :: Bool -> String -> Step
step :: Bool -> String -> Step
step = (String -> ([String] -> Module -> [String]) -> Step
makeStep String
"UnicodeSyntax" (([String] -> Module -> [String]) -> Step)
-> (String -> [String] -> Module -> [String]) -> String -> Step
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((String -> [String] -> Module -> [String]) -> String -> Step)
-> (Bool -> String -> [String] -> Module -> [String])
-> Bool
-> String
-> Step
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String -> [String] -> Module -> [String]
step'
step' :: Bool -> String -> Lines -> Module -> Lines
step' :: Bool -> String -> [String] -> Module -> [String]
step' Bool
alp String
lg [String]
ls Module
modu =
[Change String] -> [String] -> [String]
forall a. [Change a] -> [a] -> [a]
applyChanges
(if Bool
alp then String -> String -> Module -> [Change String]
addLanguagePragma String
lg String
"UnicodeSyntax" Module
modu else []) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
Replacement -> [String] -> [String]
applyReplacement Replacement
replacement [String]
ls
where
replacement :: Replacement
replacement =
(HsType GhcPs -> Replacement) -> [HsType GhcPs] -> Replacement
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap HsType GhcPs -> Replacement
hsTyReplacements (Module -> [HsType GhcPs]
forall a b. (Data a, Data b) => a -> [b]
everything Module
modu) Replacement -> Replacement -> Replacement
forall a. Semigroup a => a -> a -> a
<>
(Sig GhcPs -> Replacement) -> [Sig GhcPs] -> Replacement
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Sig GhcPs -> Replacement
hsSigReplacements (Module -> [Sig GhcPs]
forall a b. (Data a, Data b) => a -> [b]
everything Module
modu)