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