{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
#include "ghclib_api.h"
module Language.Haskell.GhclibParserEx.Fixity(
applyFixities
, preludeFixities, baseFixities
, infixr_, infixl_, infix_, fixity
) where
import BasicTypes
#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)
import GHC.Hs
#else
import HsSyn
#endif
import RdrName
import OccName
import SrcLoc
import Data.Maybe
import Data.Data hiding (Fixity)
import Data.Generics.Uniplate.Data
#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)
noExt :: NoExtField
noExt = noExtField
#endif
applyFixities :: Data a => [(String, Fixity)] -> a -> a
applyFixities :: [(String, Fixity)] -> a -> a
applyFixities fixities :: [(String, Fixity)]
fixities m :: a
m =
let m' :: a
m' = (LHsExpr GhcPs -> LHsExpr GhcPs) -> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ([(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs
expFix [(String, Fixity)]
fixities) a
m
m'' :: a
m'' = (LPat GhcPs -> LPat GhcPs) -> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ([(String, Fixity)] -> LPat GhcPs -> LPat GhcPs
patFix [(String, Fixity)]
fixities) a
m'
in a
m''
expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs
expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs
expFix fixities :: [(String, Fixity)]
fixities (L loc :: SrcSpan
loc (OpApp _ l :: LHsExpr GhcPs
l op :: LHsExpr GhcPs
op r :: LHsExpr GhcPs
r)) =
[(String, Fixity)]
-> SrcSpan
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Fixity
-> LHsExpr GhcPs
-> LHsExpr GhcPs
mkOpApp ([(String, Fixity)] -> [(String, Fixity)]
getFixities [(String, Fixity)]
fixities) SrcSpan
loc LHsExpr GhcPs
l LHsExpr GhcPs
op ([(String, Fixity)] -> LHsExpr GhcPs -> Fixity
findFixity ([(String, Fixity)] -> [(String, Fixity)]
getFixities [(String, Fixity)]
fixities) LHsExpr GhcPs
op) LHsExpr GhcPs
r
expFix _ e :: LHsExpr GhcPs
e = LHsExpr GhcPs
e
patFix :: [(String, Fixity)] -> LPat GhcPs -> LPat GhcPs
#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)
patFix fixities (L loc (ConPatIn op (InfixCon pat1 pat2))) =
L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2)
#else
patFix :: [(String, Fixity)] -> LPat GhcPs -> LPat GhcPs
patFix fixities :: [(String, Fixity)]
fixities (LPat GhcPs -> Located (SrcSpanLess (LPat GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL -> L _ (ConPatIn op (InfixCon pat1 pat2))) =
[(String, Fixity)]
-> Located RdrName
-> Fixity
-> LPat GhcPs
-> LPat GhcPs
-> LPat GhcPs
mkConOpPat ([(String, Fixity)] -> [(String, Fixity)]
getFixities [(String, Fixity)]
fixities) Located RdrName
Located (IdP GhcPs)
op ([(String, Fixity)] -> Located RdrName -> Fixity
findFixity' ([(String, Fixity)] -> [(String, Fixity)]
getFixities [(String, Fixity)]
fixities) Located RdrName
Located (IdP GhcPs)
op) LPat GhcPs
pat1 LPat GhcPs
pat2
#endif
patFix _ p :: LPat GhcPs
p = LPat GhcPs
p
mkConOpPat ::
[(String, Fixity)]
-> Located RdrName -> Fixity
-> LPat GhcPs -> LPat GhcPs
-> Pat GhcPs
#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)
mkConOpPat fs op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
#else
mkConOpPat :: [(String, Fixity)]
-> Located RdrName
-> Fixity
-> LPat GhcPs
-> LPat GhcPs
-> LPat GhcPs
mkConOpPat fs :: [(String, Fixity)]
fs op2 :: Located RdrName
op2 fix2 :: Fixity
fix2 p1 :: LPat GhcPs
p1@(LPat GhcPs -> Located (SrcSpanLess (LPat GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (ConPatIn op1 (InfixCon p11 p12))) p2 :: LPat GhcPs
p2
#endif
| Bool
nofix_error = Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located RdrName
Located (IdP GhcPs)
op2 (LPat GhcPs -> LPat GhcPs -> HsConPatDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcPs
p1 LPat GhcPs
p2)
#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810)
| associate_right = ConPatIn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2)))
#else
| Bool
associate_right = Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP GhcPs)
op1 (LPat GhcPs -> LPat GhcPs -> HsConPatDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcPs
p11 (SrcSpan -> SrcSpanLess (LPat GhcPs) -> LPat GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc ([(String, Fixity)]
-> Located RdrName
-> Fixity
-> LPat GhcPs
-> LPat GhcPs
-> LPat GhcPs
mkConOpPat [(String, Fixity)]
fs Located RdrName
op2 Fixity
fix2 LPat GhcPs
p12 LPat GhcPs
p2)))
#endif
| Bool
otherwise = Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located RdrName
Located (IdP GhcPs)
op2 (LPat GhcPs -> LPat GhcPs -> HsConPatDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcPs
p1 LPat GhcPs
p2)
where
fix1 :: Fixity
fix1 = [(String, Fixity)] -> Located RdrName -> Fixity
findFixity' [(String, Fixity)]
fs Located RdrName
Located (IdP GhcPs)
op1
(nofix_error :: Bool
nofix_error, associate_right :: Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2
mkConOpPat _ op :: Located RdrName
op _ p1 :: LPat GhcPs
p1 p2 :: LPat GhcPs
p2 = Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located RdrName
Located (IdP GhcPs)
op (LPat GhcPs -> LPat GhcPs -> HsConPatDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcPs
p1 LPat GhcPs
p2)
mkOpApp ::
[(String, Fixity)]
-> SrcSpan
-> LHsExpr GhcPs
-> LHsExpr GhcPs -> Fixity
-> LHsExpr GhcPs
-> LHsExpr GhcPs
mkOpApp :: [(String, Fixity)]
-> SrcSpan
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Fixity
-> LHsExpr GhcPs
-> LHsExpr GhcPs
mkOpApp fs :: [(String, Fixity)]
fs loc :: SrcSpan
loc e1 :: LHsExpr GhcPs
e1@(L _ (OpApp x1 :: XOpApp GhcPs
x1 e11 :: LHsExpr GhcPs
e11 op1 :: LHsExpr GhcPs
op1 e12 :: LHsExpr GhcPs
e12)) op2 :: LHsExpr GhcPs
op2 fix2 :: Fixity
fix2 e2 :: LHsExpr GhcPs
e2
| Bool
nofix_error = SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt LHsExpr GhcPs
e1 LHsExpr GhcPs
op2 LHsExpr GhcPs
e2)
| Bool
associate_right = SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
x1 LHsExpr GhcPs
e11 LHsExpr GhcPs
op1 ([(String, Fixity)]
-> SrcSpan
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Fixity
-> LHsExpr GhcPs
-> LHsExpr GhcPs
mkOpApp [(String, Fixity)]
fs SrcSpan
loc' LHsExpr GhcPs
e12 LHsExpr GhcPs
op2 Fixity
fix2 LHsExpr GhcPs
e2 ))
where
loc' :: SrcSpan
loc'= LHsExpr GhcPs -> LHsExpr GhcPs -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs LHsExpr GhcPs
e12 LHsExpr GhcPs
e2
fix1 :: Fixity
fix1 = [(String, Fixity)] -> LHsExpr GhcPs -> Fixity
findFixity [(String, Fixity)]
fs LHsExpr GhcPs
op1
(nofix_error :: Bool
nofix_error, associate_right :: Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2
mkOpApp fs :: [(String, Fixity)]
fs loc :: SrcSpan
loc e1 :: LHsExpr GhcPs
e1@(L _ (NegApp _ neg_arg :: LHsExpr GhcPs
neg_arg neg_name :: SyntaxExpr GhcPs
neg_name)) op2 :: LHsExpr GhcPs
op2 fix2 :: Fixity
fix2 e2 :: LHsExpr GhcPs
e2
| Bool
nofix_error = SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt LHsExpr GhcPs
e1 LHsExpr GhcPs
op2 LHsExpr GhcPs
e2)
| Bool
associate_right = SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XNegApp GhcPs -> LHsExpr GhcPs -> SyntaxExpr GhcPs -> HsExpr GhcPs
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp NoExt
XNegApp GhcPs
noExt ([(String, Fixity)]
-> SrcSpan
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> Fixity
-> LHsExpr GhcPs
-> LHsExpr GhcPs
mkOpApp [(String, Fixity)]
fs SrcSpan
loc' LHsExpr GhcPs
neg_arg LHsExpr GhcPs
op2 Fixity
fix2 LHsExpr GhcPs
e2) SyntaxExpr GhcPs
neg_name)
where
loc' :: SrcSpan
loc' = LHsExpr GhcPs -> LHsExpr GhcPs -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs LHsExpr GhcPs
neg_arg LHsExpr GhcPs
e2
(nofix_error :: Bool
nofix_error, associate_right :: Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
negateFixity Fixity
fix2
mkOpApp _ loc :: SrcSpan
loc e1 :: LHsExpr GhcPs
e1 op1 :: LHsExpr GhcPs
op1 fix1 :: Fixity
fix1 e2 :: LHsExpr GhcPs
e2@(L _ NegApp {})
| Bool -> Bool
not Bool
associate_right = SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt LHsExpr GhcPs
e1 LHsExpr GhcPs
op1 LHsExpr GhcPs
e2)
where
(_, associate_right :: Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
negateFixity
mkOpApp _ loc :: SrcSpan
loc e1 :: LHsExpr GhcPs
e1 op :: LHsExpr GhcPs
op _fix :: Fixity
_fix e2 :: LHsExpr GhcPs
e2 = SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp NoExt
XOpApp GhcPs
noExt LHsExpr GhcPs
e1 LHsExpr GhcPs
op LHsExpr GhcPs
e2)
getIdent :: LHsExpr GhcPs -> String
getIdent :: LHsExpr GhcPs -> String
getIdent (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc -> HsVar _ (L _ 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
IdP GhcPs
n
getIdent _ = String -> String
forall a. HasCallStack => String -> a
error "Must be HsVar"
getFixities :: [(String, Fixity)] -> [(String, Fixity)]
getFixities :: [(String, Fixity)] -> [(String, Fixity)]
getFixities fixities :: [(String, Fixity)]
fixities = if [(String, Fixity)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Fixity)]
fixities then [(String, Fixity)]
baseFixities else [(String, Fixity)]
fixities
findFixity :: [(String, Fixity)] -> LHsExpr GhcPs -> Fixity
findFixity :: [(String, Fixity)] -> LHsExpr GhcPs -> Fixity
findFixity fs :: [(String, Fixity)]
fs r :: LHsExpr GhcPs
r = [(String, Fixity)] -> String -> Fixity
askFix [(String, Fixity)]
fs (LHsExpr GhcPs -> String
getIdent LHsExpr GhcPs
r)
findFixity' :: [(String, Fixity)] -> Located RdrName -> Fixity
findFixity' :: [(String, Fixity)] -> Located RdrName -> Fixity
findFixity' fs :: [(String, Fixity)]
fs r :: Located RdrName
r = [(String, Fixity)] -> String -> Fixity
askFix [(String, Fixity)]
fs (OccName -> String
occNameString (OccName -> String)
-> (Located RdrName -> OccName) -> Located RdrName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (Located RdrName -> RdrName) -> Located RdrName -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located RdrName -> String) -> Located RdrName -> String
forall a b. (a -> b) -> a -> b
$ Located RdrName
r)
askFix :: [(String, Fixity)] -> String -> Fixity
askFix :: [(String, Fixity)] -> String -> Fixity
askFix xs :: [(String, Fixity)]
xs = \k :: String
k -> Fixity -> String -> [(String, Fixity)] -> Fixity
forall a a. Eq a => a -> a -> [(a, a)] -> a
lookupWithDefault Fixity
defaultFixity String
k [(String, Fixity)]
xs
where lookupWithDefault :: a -> a -> [(a, a)] -> a
lookupWithDefault def_v :: a
def_v k :: a
k mp1 :: [(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, Fixity)]
preludeFixities :: [(String, Fixity)]
preludeFixities = [[(String, Fixity)]] -> [(String, Fixity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> [String] -> [(String, Fixity)]
infixr_ 9 ["."]
, Int -> [String] -> [(String, Fixity)]
infixl_ 9 ["!!"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 8 ["^","^^","**"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 7 ["*","/","quot","rem","div","mod",":%","%"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 6 ["+","-"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 5 [":","++"]
, Int -> [String] -> [(String, Fixity)]
infix_ 4 ["==","/=","<","<=",">=",">","elem","notElem"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 3 ["&&"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 2 ["||"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 1 [">>",">>="]
, Int -> [String] -> [(String, Fixity)]
infixr_ 1 ["=<<"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 0 ["$","$!","seq"]
]
baseFixities :: [(String, 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)]
infixr_ 9 ["Compose"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 9 ["!","//","!:"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 8 ["shift","rotate","shiftL","shiftR","rotateL","rotateR"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 7 [".&."]
, Int -> [String] -> [(String, Fixity)]
infixl_ 6 ["xor"]
, Int -> [String] -> [(String, Fixity)]
infix_ 6 [":+"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 6 ["<>"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 5 [".|."]
, Int -> [String] -> [(String, Fixity)]
infixr_ 5 ["+:+","<++","<+>","<|"]
, Int -> [String] -> [(String, Fixity)]
infix_ 5 ["\\\\"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 4 ["<$>","<$","$>","<*>","<*","*>","<**>","<$!>"]
, Int -> [String] -> [(String, Fixity)]
infix_ 4 ["elemP","notElemP",":~:", ":~~:"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 3 ["<|>"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 3 ["&&&","***"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 2 ["+++","|||"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"]
, Int -> [String] -> [(String, Fixity)]
infixl_ 0 ["on"]
, Int -> [String] -> [(String, Fixity)]
infixr_ 0 ["par","pseq"]
]
infixr_, infixl_, infix_ :: Int -> [String] -> [(String,Fixity)]
infixr_ :: Int -> [String] -> [(String, Fixity)]
infixr_ = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
InfixR
infixl_ :: Int -> [String] -> [(String, Fixity)]
infixl_ = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
InfixL
infix_ :: Int -> [String] -> [(String, Fixity)]
infix_ = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity FixityDirection
InfixN
fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity a :: FixityDirection
a p :: Int
p = (String -> (String, Fixity)) -> [String] -> [(String, Fixity)]
forall a b. (a -> b) -> [a] -> [b]
map (,SourceText -> Int -> FixityDirection -> Fixity
Fixity (String -> SourceText
SourceText "") Int
p FixityDirection
a)