{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Refact.Fixity (applyFixities) where
import Control.Monad.Trans.State
import Data.Generics hiding (Fixity)
import Data.Maybe
import qualified GHC
import Language.Haskell.GHC.ExactPrint hiding (transferEntryDP)
import Refact.Compat (Fixity (..), SourceText (..), occNameString, rdrNameOcc,transferEntryDP)
import Refact.Utils
applyFixities :: Module -> IO Module
applyFixities :: Module -> IO Module
applyFixities Module
m = (Module, ()) -> Module
forall a b. (a, b) -> a
fst ((Module, ()) -> Module) -> IO (Module, ()) -> IO Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT () IO Module -> () -> IO (Module, ())
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (GenericM (StateT () IO) -> GenericM (StateT () IO)
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM ((GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> a -> StateT () IO a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM Expr -> StateT () IO Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
expFix) Module
m) ()
expFix :: Expr -> StateT () IO Expr
expFix :: Expr -> StateT () IO Expr
expFix (GHC.L SrcSpanAnnA
loc (GHC.OpApp XOpApp GhcPs
an Expr
l Expr
op Expr
r)) =
[(String, Fixity)]
-> SrcSpanAnnA
-> EpAnn [AddEpAnn]
-> Expr
-> Expr
-> Fixity
-> Expr
-> StateT () IO Expr
mkOpAppRn [(String, Fixity)]
baseFixities SrcSpanAnnA
loc XOpApp GhcPs
EpAnn [AddEpAnn]
an Expr
l Expr
op ([(String, Fixity)] -> Expr -> Fixity
findFixity [(String, Fixity)]
baseFixities Expr
op) Expr
r
expFix Expr
e = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT () IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e
getIdent :: Expr -> String
getIdent :: Expr -> String
getIdent (Expr -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
GHC.unLoc -> GHC.HsVar XVar GhcPs
_ (GHC.L SrcSpanAnnN
_ RdrName
n)) = OccName -> String
occNameString (OccName -> String) -> (RdrName -> OccName) -> RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> String) -> RdrName -> String
forall a b. (a -> b) -> a -> b
$ RdrName
n
getIdent Expr
_ = String -> String
forall a. HasCallStack => String -> a
error String
"Must be HsVar"
mkOpAppRn ::
[(String, GHC.Fixity)] ->
GHC.SrcSpanAnnA ->
#if MIN_VERSION_ghc(9,12,0)
GHC.NoExtField ->
#else
GHC.EpAnn [GHC.AddEpAnn] ->
#endif
Expr ->
Expr -> GHC.Fixity ->
Expr ->
StateT () IO Expr
mkOpAppRn :: [(String, Fixity)]
-> SrcSpanAnnA
-> EpAnn [AddEpAnn]
-> Expr
-> Expr
-> Fixity
-> Expr
-> StateT () IO Expr
mkOpAppRn [(String, Fixity)]
fs SrcSpanAnnA
loc EpAnn [AddEpAnn]
an e1 :: Expr
e1@(GHC.L SrcSpanAnnA
_ (GHC.OpApp XOpApp GhcPs
x1 Expr
e11 Expr
op1 Expr
e12)) Expr
op2 Fixity
fix2 Expr
e2
| Bool
nofix_error =
Expr -> StateT () IO Expr
forall a. a -> StateT () IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> StateT () IO Expr) -> Expr -> StateT () IO Expr
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
loc (XOpApp GhcPs -> Expr -> Expr -> Expr -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
GHC.OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
an Expr
e1 Expr
op2 Expr
e2)
| Bool
associate_right = do
let e12' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
e12' = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> DeltaPos -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e12 (Int -> DeltaPos
GHC.SameLine Int
0)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_e <- [(String, Fixity)]
-> SrcSpanAnnA
-> EpAnn [AddEpAnn]
-> Expr
-> Expr
-> Fixity
-> Expr
-> StateT () IO Expr
mkOpAppRn [(String, Fixity)]
fs SrcSpanAnnA
loc' EpAnn [AddEpAnn]
an Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e12' Expr
op2 Fixity
fix2 Expr
e2
let (GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_e',Int
_,[String]
_) = Transform (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs), Int, [String])
forall a. Transform a -> (a, Int, [String])
runTransform (Transform (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs), Int, [String]))
-> Transform (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs), Int, [String])
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Transform (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (m :: * -> *) t2 t1 a b.
(Monad m, Monoid t2, Typeable t1, Typeable t2) =>
LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e12 GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_e
let res :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
res = SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
loc (XOpApp GhcPs -> Expr -> Expr -> Expr -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
GHC.OpApp XOpApp GhcPs
x1 Expr
e11 Expr
op1 Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_e')
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT () IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr GhcPs)
res
where
loc' :: SrcSpanAnnA
loc' = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a
GHC.combineLocsA Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e12 Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e2
fix1 :: Fixity
fix1 = [(String, Fixity)] -> Expr -> Fixity
findFixity [(String, Fixity)]
fs Expr
op1
(Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
GHC.compareFixity Fixity
fix1 Fixity
fix2
mkOpAppRn [(String, Fixity)]
fs SrcSpanAnnA
loc EpAnn [AddEpAnn]
an e1 :: Expr
e1@(GHC.L SrcSpanAnnA
_ (GHC.NegApp XNegApp GhcPs
an' Expr
neg_arg SyntaxExpr GhcPs
neg_name)) Expr
op2 Fixity
fix2 Expr
e2
| Bool
nofix_error =
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT () IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
loc (XOpApp GhcPs -> Expr -> Expr -> Expr -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
GHC.OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
an Expr
e1 Expr
op2 Expr
e2))
| Bool
associate_right =
do
GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_e <- [(String, Fixity)]
-> SrcSpanAnnA
-> EpAnn [AddEpAnn]
-> Expr
-> Expr
-> Fixity
-> Expr
-> StateT () IO Expr
mkOpAppRn [(String, Fixity)]
fs SrcSpanAnnA
loc' EpAnn [AddEpAnn]
an Expr
neg_arg Expr
op2 Fixity
fix2 Expr
e2
let new_e' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_e' = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> DeltaPos -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_e (Int -> DeltaPos
GHC.SameLine Int
0)
let res :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
res = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> DeltaPos -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP (SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
loc (XNegApp GhcPs -> Expr -> SyntaxExpr GhcPs -> HsExpr GhcPs
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
GHC.NegApp XNegApp GhcPs
an' Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
new_e' SyntaxExpr GhcPs
neg_name)) (Int -> DeltaPos
GHC.SameLine Int
0)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StateT () IO (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT () IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr GhcPs)
res
where
loc' :: SrcSpanAnnA
loc' = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpanAnnA
forall a e1 e2.
Semigroup a =>
GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a
GHC.combineLocsA Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
neg_arg Expr
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e2
(Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
GHC.compareFixity Fixity
GHC.negateFixity Fixity
fix2
mkOpAppRn [(String, Fixity)]
_ SrcSpanAnnA
loc EpAnn [AddEpAnn]
an Expr
e1 Expr
op1 Fixity
fix1 e2 :: Expr
e2@(GHC.L SrcSpanAnnA
_ GHC.NegApp {})
| Bool -> Bool
not Bool
associate_right
= do
Expr -> StateT () IO Expr
forall a. a -> StateT () IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> StateT () IO Expr) -> Expr -> StateT () IO Expr
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
loc (XOpApp GhcPs -> Expr -> Expr -> Expr -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
GHC.OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
an Expr
e1 Expr
op1 Expr
e2)
where
(Bool
_, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
GHC.compareFixity Fixity
fix1 Fixity
GHC.negateFixity
mkOpAppRn [(String, Fixity)]
_ SrcSpanAnnA
loc EpAnn [AddEpAnn]
an Expr
e1 Expr
op Fixity
_fix Expr
e2
= do
Expr -> StateT () IO Expr
forall a. a -> StateT () IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> StateT () IO Expr) -> Expr -> StateT () IO Expr
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
loc (XOpApp GhcPs -> Expr -> Expr -> Expr -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
GHC.OpApp XOpApp GhcPs
EpAnn [AddEpAnn]
an Expr
e1 Expr
op Expr
e2)
findFixity :: [(String, GHC.Fixity)] -> Expr -> GHC.Fixity
findFixity :: [(String, Fixity)] -> Expr -> Fixity
findFixity [(String, Fixity)]
fs Expr
r = [(String, Fixity)] -> String -> Fixity
askFix [(String, Fixity)]
fs (Expr -> String
getIdent Expr
r)
askFix :: [(String, GHC.Fixity)] -> String -> GHC.Fixity
askFix :: [(String, Fixity)] -> String -> Fixity
askFix [(String, Fixity)]
xs = \String
k -> Fixity -> String -> [(String, Fixity)] -> Fixity
forall {a} {a}. Eq a => a -> a -> [(a, a)] -> a
lookupWithDefault Fixity
GHC.defaultFixity String
k [(String, Fixity)]
xs
where
lookupWithDefault :: a -> a -> [(a, a)] -> a
lookupWithDefault a
def_v a
k [(a, a)]
mp1 = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def_v (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ a -> [(a, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
k [(a, a)]
mp1
preludeFixities :: [(String, GHC.Fixity)]
preludeFixities :: [(String, Fixity)]
preludeFixities =
[[(String, Fixity)]] -> [(String, Fixity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> [String] -> [(String, Fixity)]
infixr_ Int
9 [String
"."],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
9 [String
"!!"],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
8 [String
"^", String
"^^", String
"**"],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
7 [String
"*", String
"/", String
"quot", String
"rem", String
"div", String
"mod", String
":%", String
"%"],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
6 [String
"+", String
"-"],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
5 [String
":", String
"++"],
Int -> [String] -> [(String, Fixity)]
infix_ Int
4 [String
"==", String
"/=", String
"<", String
"<=", String
">=", String
">", String
"elem", String
"notElem"],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
3 [String
"&&"],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
2 [String
"||"],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
1 [String
">>", String
">>="],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
1 [String
"=<<"],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
0 [String
"$", String
"$!", String
"seq"]
]
baseFixities :: [(String, GHC.Fixity)]
baseFixities :: [(String, Fixity)]
baseFixities =
[(String, Fixity)]
preludeFixities
[(String, Fixity)] -> [(String, Fixity)] -> [(String, Fixity)]
forall a. [a] -> [a] -> [a]
++ [[(String, Fixity)]] -> [(String, Fixity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> [String] -> [(String, Fixity)]
infixl_ Int
9 [String
"!", String
"//", String
"!:"],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
8 [String
"shift", String
"rotate", String
"shiftL", String
"shiftR", String
"rotateL", String
"rotateR"],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
7 [String
".&."],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
6 [String
"xor"],
Int -> [String] -> [(String, Fixity)]
infix_ Int
6 [String
":+"],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
5 [String
".|."],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
5 [String
"+:+", String
"<++", String
"<+>"],
Int -> [String] -> [(String, Fixity)]
infix_ Int
5 [String
"\\\\"],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
4 [String
"<$>", String
"<$", String
"<*>", String
"<*", String
"*>", String
"<**>"],
Int -> [String] -> [(String, Fixity)]
infix_ Int
4 [String
"elemP", String
"notElemP"],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
3 [String
"<|>"],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
3 [String
"&&&", String
"***"],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
2 [String
"+++", String
"|||"],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
1 [String
"<=<", String
">=>", String
">>>", String
"<<<", String
"^<<", String
"<<^", String
"^>>", String
">>^"],
Int -> [String] -> [(String, Fixity)]
infixl_ Int
0 [String
"on"],
Int -> [String] -> [(String, Fixity)]
infixr_ Int
0 [String
"par", String
"pseq"]
]
infixr_, infixl_, infix_ :: Int -> [String] -> [(String, GHC.Fixity)]
infixr_ :: Int -> [String] -> [(String, Fixity)]
infixr_ = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
GHC.InfixR
infixl_ :: Int -> [String] -> [(String, Fixity)]
infixl_ = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
GHC.InfixL
infix_ :: Int -> [String] -> [(String, Fixity)]
infix_ = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
GHC.InfixN
fixity :: GHC.FixityDirection -> Int -> [String] -> [(String, GHC.Fixity)]
#if MIN_VERSION_ghc(9,12,0)
fixity a p = map (,Fixity p a)
#else
fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
a Int
p = (String -> (String, Fixity)) -> [String] -> [(String, Fixity)]
forall a b. (a -> b) -> [a] -> [b]
map (,SourceText -> Int -> FixityDirection -> Fixity
Fixity (String -> SourceText
SourceText String
"") Int
p FixityDirection
a)
#endif