{-# LANGUAGE ViewPatterns #-}

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

import GHC.Generics(Associativity(..))
import GHC.Hs.Binds
import GHC.Hs.Extension
import OccName
import RdrName
import SrcLoc
import BasicTypes
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 _ names :: [Located (IdP GhcPs)]
names (Fixity _ i :: Int
i dir :: FixityDirection
dir)) =
    [(Located RdrName -> String
rdrNameStr Located RdrName
name, FixityDirection -> Associativity
f FixityDirection
dir, Int
i) | Located RdrName
name <- [Located (IdP GhcPs)]
[Located RdrName]
names]
    where
        f :: FixityDirection -> Associativity
f InfixL = Associativity
LeftAssociative
        f InfixR = Associativity
RightAssociative
        f InfixN = Associativity
NotAssociative
fromFixitySig _ = []

toFixity :: FixityInfo -> (String, Fixity)
toFixity :: FixityInfo -> (String, Fixity)
toFixity (name :: String
name, dir :: Associativity
dir, i :: 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 LeftAssociative = FixityDirection
InfixL
        f RightAssociative = FixityDirection
InfixR
        f NotAssociative = FixityDirection
InfixN

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

toFixitySig :: FixityInfo -> FixitySig GhcPs
toFixitySig :: FixityInfo -> FixitySig GhcPs
toFixitySig (FixityInfo -> (String, Fixity)
toFixity -> (name :: String
name, x :: Fixity
x)) = XFixitySig GhcPs
-> [Located (IdP GhcPs)] -> Fixity -> FixitySig GhcPs
forall pass.
XFixitySig pass -> [Located (IdP pass)] -> Fixity -> FixitySig pass
FixitySig NoExtField
XFixitySig GhcPs
noExtField [SrcSpanLess (Located RdrName) -> Located (IdP GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located RdrName) -> Located (IdP GhcPs))
-> SrcSpanLess (Located RdrName) -> Located (IdP GhcPs)
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_ 4 ["%%@~","<%@~","%%~","<+~","<*~","<-~","<//~","<^~","<^^~","<**~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ 4 ["%%@=","<%@=","%%=","<+=","<*=","<-=","<//=","<^=","<^^=","<**="]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 2 ["<<~"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 9 ["#."]
    , Int -> [String] -> [(String, Fixity)]
infixl_ 8 [".#"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 8 ["^!","^@!"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ 1 ["&","<&>","??"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ 8 ["^.","^@."]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 9 ["<.>","<.",".>"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 4 ["%@~",".~","+~","*~","-~","//~","^~","^^~","**~","&&~","<>~","||~","%~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ 4 ["%@=",".=","+=","*=","-=","//=","^=","^^=","**=","&&=","<>=","||=","%="]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 2 ["<~"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 2 ["`zoom`","`magnify`"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ 8 ["^..","^?","^?!","^@..","^@?","^@?!"]
    , Int -> [String] -> [(String, Fixity)]
infixl_ 8 ["^#"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 4 ["<#~","#~","#%~","<#%~","#%%~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ 4 ["<#=","#=","#%=","<#%=","#%%="]
    , Int -> [String] -> [(String, Fixity)]
infixl_ 9 [":>"]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 4 ["</>~","<</>~","<.>~","<<.>~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ 4 ["</>=","<</>=","<.>=","<<.>="]
    , Int -> [String] -> [(String, Fixity)]
infixr_ 4 [".|.~",".&.~","<.|.~","<.&.~"]
    , Int -> [String] -> [(String, Fixity)]
infix_ 4 [".|.=",".&.=","<.|.=","<.&.="]
    ]

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_ 1 ["shouldBe","shouldSatisfy","shouldStartWith","shouldEndWith","shouldContain","shouldMatchList"
              ,"shouldReturn","shouldNotBe","shouldNotSatisfy","shouldNotContain","shouldNotReturn","shouldThrow"]
    -- quickcheck
  , Int -> [String] -> [(String, Fixity)]
infixr_ 0 ["==>"]
  , Int -> [String] -> [(String, Fixity)]
infix_ 4 ["==="]
    -- esqueleto
  , Int -> [String] -> [(String, Fixity)]
infix_ 4 ["==."]
    -- lattices
  , Int -> [String] -> [(String, Fixity)]
infixr_ 5 ["\\/"] -- \/
  , Int -> [String] -> [(String, Fixity)]
infixr_ 6 ["/\\"] -- /\
  ]

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