{-# LANGUAGE ViewPatterns #-}

module Fixity(
    FixityInfo, Associativity(..),
    defaultFixities,
    fromFixitySig, toFixitySig, toFixity,
    ) where

import GHC.Generics(Associativity(..))
import GHC.Hs.Binds
import GHC.Hs.Extension
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader
import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Parser.Annotation
import Language.Haskell.Syntax.Extension
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Language.Haskell.GhclibParserEx.Fixity

-- Lots of things define a fixity. None define it quite right, so let's have our own type.

-- | A Fixity definition, comprising the name the fixity applies to,
--   the direction and the precedence. As an example, a source file containing:
--
-- > infixr 3 `foo`
--
--   would create @(\"foo\", RightAssociative, 3)@.
type FixityInfo = (String, Associativity, Int)

fromFixitySig :: FixitySig GhcPs -> [FixityInfo]
fromFixitySig :: FixitySig GhcPs -> [FixityInfo]
fromFixitySig (FixitySig XFixitySig GhcPs
_ [LIdP GhcPs]
names (Fixity SourceText
_ Int
i FixityDirection
dir)) =
    [(LocatedN RdrName -> String
rdrNameStr LocatedN RdrName
name, FixityDirection -> Associativity
f FixityDirection
dir, Int
i) | LocatedN RdrName
name <- [LIdP GhcPs]
[LocatedN RdrName]
names]
    where
        f :: FixityDirection -> Associativity
f FixityDirection
InfixL = Associativity
LeftAssociative
        f FixityDirection
InfixR = Associativity
RightAssociative
        f FixityDirection
InfixN = Associativity
NotAssociative

toFixity :: FixityInfo -> (String, Fixity)
toFixity :: FixityInfo -> (String, Fixity)
toFixity (String
name, Associativity
dir, Int
i) = (String
name, SourceText -> Int -> FixityDirection -> Fixity
Fixity SourceText
NoSourceText Int
i (FixityDirection -> Fixity) -> FixityDirection -> Fixity
forall a b. (a -> b) -> a -> b
$ Associativity -> FixityDirection
f Associativity
dir)
    where
        f :: Associativity -> FixityDirection
f Associativity
LeftAssociative = FixityDirection
InfixL
        f Associativity
RightAssociative = FixityDirection
InfixR
        f Associativity
NotAssociative = FixityDirection
InfixN

fromFixity :: (String, Fixity) -> FixityInfo
fromFixity :: (String, Fixity) -> FixityInfo
fromFixity (String
name, Fixity SourceText
_ Int
i FixityDirection
dir) = (String
name, FixityDirection -> Associativity
assoc FixityDirection
dir, Int
i)
  where
    assoc :: FixityDirection -> Associativity
assoc FixityDirection
dir = case FixityDirection
dir of
      FixityDirection
InfixL -> Associativity
LeftAssociative
      FixityDirection
InfixR -> Associativity
RightAssociative
      FixityDirection
InfixN -> Associativity
NotAssociative

toFixitySig :: FixityInfo -> FixitySig GhcPs
toFixitySig :: FixityInfo -> FixitySig GhcPs
toFixitySig (FixityInfo -> (String, Fixity)
toFixity -> (String
name, Fixity
x)) = XFixitySig GhcPs -> [LIdP GhcPs] -> Fixity -> FixitySig GhcPs
forall pass.
XFixitySig pass -> [LIdP pass] -> Fixity -> FixitySig pass
FixitySig XFixitySig GhcPs
NoExtField
noExtField [RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ OccName -> RdrName
mkRdrUnqual (String -> OccName
mkVarOcc String
name)] Fixity
x

defaultFixities :: [FixityInfo]
defaultFixities :: [FixityInfo]
defaultFixities = ((String, Fixity) -> FixityInfo)
-> [(String, Fixity)] -> [FixityInfo]
forall a b. (a -> b) -> [a] -> [b]
map (String, Fixity) -> FixityInfo
fromFixity ([(String, Fixity)] -> [FixityInfo])
-> [(String, Fixity)] -> [FixityInfo]
forall a b. (a -> b) -> a -> b
$ [(String, Fixity)]
customFixities [(String, Fixity)] -> [(String, Fixity)] -> [(String, Fixity)]
forall a. [a] -> [a] -> [a]
++ [(String, Fixity)]
baseFixities [(String, Fixity)] -> [(String, Fixity)] -> [(String, Fixity)]
forall a. [a] -> [a] -> [a]
++ [(String, Fixity)]
lensFixities [(String, Fixity)] -> [(String, Fixity)] -> [(String, Fixity)]
forall a. [a] -> [a] -> [a]
++ [(String, Fixity)]
otherFixities

-- List as provided at https://github.com/ndmitchell/hlint/issues/416.
lensFixities :: [(String, Fixity)]
lensFixities :: [(String, Fixity)]
lensFixities = [[(String, Fixity)]] -> [(String, Fixity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Int -> [String] -> [(String, Fixity)]
infixr_ Int
4 [String
"%%@~",String
"<%@~",String
"%%~",String
"<+~",String
"<*~",String
"<-~",String
"<//~",String
"<^~",String
"<^^~",String
"<**~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ Int
4 [String
"%%@=",String
"<%@=",String
"%%=",String
"<+=",String
"<*=",String
"<-=",String
"<//=",String
"<^=",String
"<^^=",String
"<**="]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
2 [String
"<<~"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
9 [String
"#."]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
8 [String
".#"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
8 [String
"^!",String
"^@!"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
1 [String
"&",String
"<&>",String
"??"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
8 [String
"^.",String
"^@."]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
9 [String
"<.>",String
"<.",String
".>"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
4 [String
"%@~",String
".~",String
"+~",String
"*~",String
"-~",String
"//~",String
"^~",String
"^^~",String
"**~",String
"&&~",String
"<>~",String
"||~",String
"%~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ Int
4 [String
"%@=",String
".=",String
"+=",String
"*=",String
"-=",String
"//=",String
"^=",String
"^^=",String
"**=",String
"&&=",String
"<>=",String
"||=",String
"%="]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
2 [String
"<~"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
2 [String
"`zoom`",String
"`magnify`"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
8 [String
"^..",String
"^?",String
"^?!",String
"^@..",String
"^@?",String
"^@?!"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
8 [String
"^#"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
4 [String
"<#~",String
"#~",String
"#%~",String
"<#%~",String
"#%%~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ Int
4 [String
"<#=",String
"#=",String
"#%=",String
"<#%=",String
"#%%="]
    , Int -> [String] -> [(String, Fixity)]
infixl_ Int
9 [String
":>"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
4 [String
"</>~",String
"<</>~",String
"<.>~",String
"<<.>~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ Int
4 [String
"</>=",String
"<</>=",String
"<.>=",String
"<<.>="]
    , Int -> [String] -> [(String, Fixity)]
infixr_ Int
4 [String
".|.~",String
".&.~",String
"<.|.~",String
"<.&.~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ Int
4 [String
".|.=",String
".&.=",String
"<.|.=",String
"<.&.="]
    ]

otherFixities :: [(String, Fixity)]
otherFixities :: [(String, Fixity)]
otherFixities = [[(String, Fixity)]] -> [(String, Fixity)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  -- hspec
  [ Int -> [String] -> [(String, Fixity)]
infix_ Int
1 [String
"shouldBe",String
"shouldSatisfy",String
"shouldStartWith",String
"shouldEndWith",String
"shouldContain",String
"shouldMatchList"
              ,String
"shouldReturn",String
"shouldNotBe",String
"shouldNotSatisfy",String
"shouldNotContain",String
"shouldNotReturn",String
"shouldThrow"]
    -- quickcheck
  , Int -> [String] -> [(String, Fixity)]
infixr_ Int
0 [String
"==>"]
  , Int -> [String] -> [(String, Fixity)]
infix_ Int
4 [String
"==="]
    -- esqueleto
  , Int -> [String] -> [(String, Fixity)]
infix_ Int
4 [String
"==."]
    -- lattices
  , Int -> [String] -> [(String, Fixity)]
infixr_ Int
5 [String
"\\/"] -- \/
  , Int -> [String] -> [(String, Fixity)]
infixr_ Int
6 [String
"/\\"] -- /\
  ]

customFixities :: [(String, Fixity)]
customFixities :: [(String, Fixity)]
customFixities =
  Int -> [String] -> [(String, Fixity)]
infixl_ Int
1 [String
"`on`"]
        -- See https://github.com/ndmitchell/hlint/issues/425
        -- otherwise GTK apps using `on` at a different fixity have
        -- spurious warnings.