--------------------------------------------------------------------------------
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)


{-
--------------------------------------------------------------------------------
unicodeReplacements :: Map String String
unicodeReplacements = M.fromList
    [ ("::", "∷")
    , ("=>", "⇒")
    , ("->", "→")
    , ("<-", "←")
    , ("forall", "∀")
    , ("-<", "↢")
    , (">-", "↣")
    ]
-}

--------------------------------------------------------------------------------
-- Simple type that can do replacments on single lines (not spanning, removing
-- or adding lines).
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)