1-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. 2-- SPDX-License-Identifier: BSD-3-Clause. 3-- 4-- Adapted from (1) https://github.com/mpickering/apply-refact.git and 5-- (2) https://gitlab.haskell.org/ghc/ghc ('compiler/renamer/RnTypes.hs'). 6 7{-# LANGUAGE CPP #-} 8{-# LANGUAGE ViewPatterns #-} 9{-# LANGUAGE TupleSections #-} 10#include "ghclib_api.h" 11 12module Language.Haskell.GhclibParserEx.Fixity( 13 applyFixities 14 , fixitiesFromModule 15 , preludeFixities, baseFixities 16 , infixr_, infixl_, infix_, fixity 17 ) where 18 19#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) 20import GHC.Hs 21#if defined (GHCLIB_API_HEAD) 22import GHC.Types.Fixity 23import GHC.Types.SourceText 24#else 25import GHC.Types.Basic 26#endif 27import GHC.Types.Name.Reader 28import GHC.Types.Name 29import GHC.Types.SrcLoc 30#elif defined (GHCLIB_API_810) 31import GHC.Hs 32import BasicTypes 33import RdrName 34import OccName 35import SrcLoc 36#else 37import HsSyn 38import BasicTypes 39import RdrName 40import OccName 41import SrcLoc 42#endif 43import Data.Maybe 44import Data.Data hiding (Fixity) 45import Data.Generics.Uniplate.Data 46 47#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) 48noExt :: NoExtField 49noExt = noExtField 50#endif 51 52-- | Rearrange a parse tree to account for fixities. 53applyFixities :: Data a => [(String, Fixity)] -> a -> a 54applyFixities fixities m = 55 let m' = transformBi (expFix fixities) m 56 m'' = transformBi (patFix fixities) m' 57 in m'' 58 59expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs 60expFix fixities (L loc (OpApp _ l op r)) = 61 mkOpApp (getFixities fixities) loc l op (findFixity (getFixities fixities) op) r 62expFix _ e = e 63 64-- LPat and Pat have gone through a lot of churn. See 65-- https://gitlab.haskell.org/ghc/ghc/merge_requests/1925 for details. 66patFix :: [(String, Fixity)] -> LPat GhcPs -> LPat GhcPs 67#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) 68patFix fixities (L loc (ConPat _ op (InfixCon pat1 pat2))) = 69 L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2) 70#elif defined (GHCLIB_API_810) 71patFix fixities (L loc (ConPatIn op (InfixCon pat1 pat2))) = 72 L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2) 73#else 74patFix fixities (dL -> L _ (ConPatIn op (InfixCon pat1 pat2))) = 75 mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2 76#endif 77patFix _ p = p 78 79mkConOpPat :: 80 [(String, Fixity)] 81 -> Located RdrName -> Fixity 82 -> LPat GhcPs -> LPat GhcPs 83 -> Pat GhcPs 84#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) 85mkConOpPat fs op2 fix2 p1@(L loc (ConPat _ op1 (InfixCon p11 p12))) p2 86#elif defined (GHCLIB_API_810) 87mkConOpPat fs op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 88#else 89mkConOpPat fs op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 90#endif 91#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) 92 | nofix_error = ConPat noExtField op2 (InfixCon p1 p2) 93#else 94 | nofix_error = ConPatIn op2 (InfixCon p1 p2) 95#endif 96#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) 97 | associate_right = ConPat noExtField op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) 98#elif defined (GHCLIB_API_810) 99 | associate_right = ConPatIn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) 100#else 101 | associate_right = ConPatIn op1 (InfixCon p11 (cL loc (mkConOpPat fs op2 fix2 p12 p2))) 102#endif 103#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) 104 | otherwise = ConPat noExtField op2 (InfixCon p1 p2) 105#else 106 | otherwise = ConPatIn op2 (InfixCon p1 p2) 107#endif 108 where 109 fix1 = findFixity' fs op1 110 (nofix_error, associate_right) = compareFixity fix1 fix2 111#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) 112mkConOpPat _ op _ p1 p2 = ConPat noExtField op (InfixCon p1 p2) 113#else 114mkConOpPat _ op _ p1 p2 = ConPatIn op (InfixCon p1 p2) 115#endif 116 117mkOpApp :: 118 [(String, Fixity)] 119 -> SrcSpan 120 -> LHsExpr GhcPs -- Left operand; already rearrange. 121 -> LHsExpr GhcPs -> Fixity -- Operator and fixity. 122 -> LHsExpr GhcPs -- Right operand (not an OpApp, but might be a NegApp). 123 -> LHsExpr GhcPs 124-- (e11 `op1` e12) `op2` e2 125mkOpApp fs loc e1@(L _ (OpApp x1 e11 op1 e12)) op2 fix2 e2 126 | nofix_error = L loc (OpApp noExt e1 op2 e2) 127 | associate_right = L loc (OpApp x1 e11 op1 (mkOpApp fs loc' e12 op2 fix2 e2 )) 128 where 129 loc'= combineLocs e12 e2 130 fix1 = findFixity fs op1 131 (nofix_error, associate_right) = compareFixity fix1 fix2 132-- (- neg_arg) `op` e2 133mkOpApp fs loc e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 134 | nofix_error = L loc (OpApp noExt e1 op2 e2) 135 | associate_right = L loc (NegApp noExt (mkOpApp fs loc' neg_arg op2 fix2 e2) neg_name) 136 where 137 loc' = combineLocs neg_arg e2 138 (nofix_error, associate_right) = compareFixity negateFixity fix2 139-- e1 `op` - neg_arg 140mkOpApp _ loc e1 op1 fix1 e2@(L _ NegApp {}) -- NegApp can occur on the right. 141 | not associate_right = L loc (OpApp noExt e1 op1 e2)-- We *want* right association. 142 where 143 (_, associate_right) = compareFixity fix1 negateFixity 144 -- Default case, no rearrangment. 145mkOpApp _ loc e1 op _fix e2 = L loc (OpApp noExt e1 op e2) 146 147getIdent :: LHsExpr GhcPs -> String 148getIdent (unLoc -> HsVar _ (L _ n)) = occNameString . rdrNameOcc $ n 149getIdent _ = error "Must be HsVar" 150 151-- If there are no fixities, give 'baseFixities'. 152getFixities :: [(String, Fixity)] -> [(String, Fixity)] 153getFixities fixities = if null fixities then baseFixities else fixities 154 155findFixity :: [(String, Fixity)] -> LHsExpr GhcPs -> Fixity 156findFixity fs r = askFix fs (getIdent r) -- Expressions. 157 158findFixity' :: [(String, Fixity)] -> Located RdrName -> Fixity 159findFixity' fs r = askFix fs (occNameString . rdrNameOcc . unLoc $ r) -- Patterns. 160 161askFix :: [(String, Fixity)] -> String -> Fixity 162askFix xs = \k -> lookupWithDefault defaultFixity k xs 163 where lookupWithDefault def_v k mp1 = fromMaybe def_v $ lookup k mp1 164 165-- All fixities defined in the Prelude. 166preludeFixities :: [(String, Fixity)] 167preludeFixities = concat 168 [ infixr_ 9 ["."] 169 , infixl_ 9 ["!!"] 170 , infixr_ 8 ["^","^^","**"] 171 , infixl_ 7 ["*","/","quot","rem","div","mod",":%","%"] 172 , infixl_ 6 ["+","-"] 173 , infixr_ 5 [":","++"] 174 , infix_ 4 ["==","/=","<","<=",">=",">","elem","notElem"] 175 , infixr_ 3 ["&&"] 176 , infixr_ 2 ["||"] 177 , infixl_ 1 [">>",">>="] 178 , infixr_ 1 ["=<<"] 179 , infixr_ 0 ["$","$!","seq"] 180 ] 181 182-- All fixities defined in the base package. Note that the @+++@ 183-- operator appears in both Control.Arrows and 184-- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in 185-- this list is that of Control.Arrows. 186baseFixities :: [(String, Fixity)] 187baseFixities = preludeFixities ++ concat 188 [ infixr_ 9 ["Compose"] 189 , infixl_ 9 ["!","//","!:"] 190 , infixl_ 8 ["shift","rotate","shiftL","shiftR","rotateL","rotateR"] 191 , infixl_ 7 [".&."] 192 , infixl_ 6 ["xor"] 193 , infix_ 6 [":+"] 194 , infixr_ 6 ["<>"] 195 , infixl_ 5 [".|."] 196 , infixr_ 5 ["+:+","<++","<+>","<|"] -- Fixity conflict for +++ between ReadP and Arrow. 197 , infix_ 5 ["\\\\"] 198 , infixl_ 4 ["<$>","<$","$>","<*>","<*","*>","<**>","<$!>"] 199 , infix_ 4 ["elemP","notElemP",":~:", ":~~:"] 200 , infixl_ 3 ["<|>"] 201 , infixr_ 3 ["&&&","***"] 202 , infixr_ 2 ["+++","|||"] 203 , infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"] 204 , infixl_ 0 ["on"] 205 , infixr_ 0 ["par","pseq"] 206 ] 207 208infixr_, infixl_, infix_ :: Int -> [String] -> [(String,Fixity)] 209infixr_ = fixity InfixR 210infixl_ = fixity InfixL 211infix_ = fixity InfixN 212 213fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)] 214fixity a p = map (,Fixity (SourceText "") p a) 215 216#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) 217fixitiesFromModule :: Located HsModule -> [(String, Fixity)] 218#else 219fixitiesFromModule :: Located (HsModule GhcPs) -> [(String, Fixity)] 220#endif 221#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_900) 222fixitiesFromModule (L _ (HsModule _ _ _ _ decls _ _)) = concatMap f decls 223#else 224fixitiesFromModule (L _ (HsModule _ _ _ decls _ _)) = concatMap f decls 225#endif 226 where 227 f :: LHsDecl GhcPs -> [(String, Fixity)] 228 f (L _ (SigD _ (FixSig _ (FixitySig _ ops (Fixity _ p dir))))) = 229 fixity dir p (map (occNameString. rdrNameOcc . unLoc) ops) 230 f _ = [] 231