{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Ormolu.Fixity.Internal
  ( FixityDirection (..),
    FixityInfo (..),
    defaultFixityInfo,
    colonFixityInfo,
    HackageInfo (..),
    FixityMap,
    LazyFixityMap (..),
    lookupFixity,
  )
where

import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
import qualified Data.Aeson as A
import Data.Foldable (asum)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text as T
import Instances.TH.Lift ()
import qualified Language.Haskell.TH.Syntax as TH

-- | Fixity direction.
data FixityDirection
  = InfixL
  | InfixR
  | InfixN
  deriving (FixityDirection -> FixityDirection -> Bool
(FixityDirection -> FixityDirection -> Bool)
-> (FixityDirection -> FixityDirection -> Bool)
-> Eq FixityDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FixityDirection -> FixityDirection -> Bool
$c/= :: FixityDirection -> FixityDirection -> Bool
== :: FixityDirection -> FixityDirection -> Bool
$c== :: FixityDirection -> FixityDirection -> Bool
Eq, Eq FixityDirection
Eq FixityDirection
-> (FixityDirection -> FixityDirection -> Ordering)
-> (FixityDirection -> FixityDirection -> Bool)
-> (FixityDirection -> FixityDirection -> Bool)
-> (FixityDirection -> FixityDirection -> Bool)
-> (FixityDirection -> FixityDirection -> Bool)
-> (FixityDirection -> FixityDirection -> FixityDirection)
-> (FixityDirection -> FixityDirection -> FixityDirection)
-> Ord FixityDirection
FixityDirection -> FixityDirection -> Bool
FixityDirection -> FixityDirection -> Ordering
FixityDirection -> FixityDirection -> FixityDirection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FixityDirection -> FixityDirection -> FixityDirection
$cmin :: FixityDirection -> FixityDirection -> FixityDirection
max :: FixityDirection -> FixityDirection -> FixityDirection
$cmax :: FixityDirection -> FixityDirection -> FixityDirection
>= :: FixityDirection -> FixityDirection -> Bool
$c>= :: FixityDirection -> FixityDirection -> Bool
> :: FixityDirection -> FixityDirection -> Bool
$c> :: FixityDirection -> FixityDirection -> Bool
<= :: FixityDirection -> FixityDirection -> Bool
$c<= :: FixityDirection -> FixityDirection -> Bool
< :: FixityDirection -> FixityDirection -> Bool
$c< :: FixityDirection -> FixityDirection -> Bool
compare :: FixityDirection -> FixityDirection -> Ordering
$ccompare :: FixityDirection -> FixityDirection -> Ordering
$cp1Ord :: Eq FixityDirection
Ord, Int -> FixityDirection -> ShowS
[FixityDirection] -> ShowS
FixityDirection -> String
(Int -> FixityDirection -> ShowS)
-> (FixityDirection -> String)
-> ([FixityDirection] -> ShowS)
-> Show FixityDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FixityDirection] -> ShowS
$cshowList :: [FixityDirection] -> ShowS
show :: FixityDirection -> String
$cshow :: FixityDirection -> String
showsPrec :: Int -> FixityDirection -> ShowS
$cshowsPrec :: Int -> FixityDirection -> ShowS
Show, FixityDirection -> Q Exp
FixityDirection -> Q (TExp FixityDirection)
(FixityDirection -> Q Exp)
-> (FixityDirection -> Q (TExp FixityDirection))
-> Lift FixityDirection
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: FixityDirection -> Q (TExp FixityDirection)
$cliftTyped :: FixityDirection -> Q (TExp FixityDirection)
lift :: FixityDirection -> Q Exp
$clift :: FixityDirection -> Q Exp
TH.Lift)

instance FromJSON FixityDirection where
  parseJSON :: Value -> Parser FixityDirection
parseJSON = String
-> (Text -> Parser FixityDirection)
-> Value
-> Parser FixityDirection
forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"FixityDirection" ((Text -> Parser FixityDirection)
 -> Value -> Parser FixityDirection)
-> (Text -> Parser FixityDirection)
-> Value
-> Parser FixityDirection
forall a b. (a -> b) -> a -> b
$ \case
    Text
"InfixL" -> FixityDirection -> Parser FixityDirection
forall (f :: * -> *) a. Applicative f => a -> f a
pure FixityDirection
InfixL
    Text
"InfixN" -> FixityDirection -> Parser FixityDirection
forall (f :: * -> *) a. Applicative f => a -> f a
pure FixityDirection
InfixN
    Text
"InfixR" -> FixityDirection -> Parser FixityDirection
forall (f :: * -> *) a. Applicative f => a -> f a
pure FixityDirection
InfixR
    Text
x -> String -> Parser FixityDirection
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Text -> String
T.unpack Text
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a fixity direction")

instance ToJSON FixityDirection where
  toJSON :: FixityDirection -> Value
toJSON FixityDirection
x =
    Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ case FixityDirection
x of
      FixityDirection
InfixL -> Text
"InfixL" :: Text
      FixityDirection
InfixN -> Text
"InfixN"
      FixityDirection
InfixR -> Text
"InfixR"

-- | Fixity information about an infix operator that takes the uncertainty
-- that can arise from conflicting definitions into account.
data FixityInfo = FixityInfo
  { -- | Fixity direction if it is known
    FixityInfo -> Maybe FixityDirection
fiDirection :: Maybe FixityDirection,
    -- | Minimum precedence level found in the (maybe conflicting)
    -- definitions for the operator (inclusive)
    FixityInfo -> Int
fiMinPrecedence :: Int,
    -- | Maximum precedence level found in the (maybe conflicting)
    -- definitions for the operator (inclusive)
    FixityInfo -> Int
fiMaxPrecedence :: Int
  }
  deriving (FixityInfo -> FixityInfo -> Bool
(FixityInfo -> FixityInfo -> Bool)
-> (FixityInfo -> FixityInfo -> Bool) -> Eq FixityInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FixityInfo -> FixityInfo -> Bool
$c/= :: FixityInfo -> FixityInfo -> Bool
== :: FixityInfo -> FixityInfo -> Bool
$c== :: FixityInfo -> FixityInfo -> Bool
Eq, Eq FixityInfo
Eq FixityInfo
-> (FixityInfo -> FixityInfo -> Ordering)
-> (FixityInfo -> FixityInfo -> Bool)
-> (FixityInfo -> FixityInfo -> Bool)
-> (FixityInfo -> FixityInfo -> Bool)
-> (FixityInfo -> FixityInfo -> Bool)
-> (FixityInfo -> FixityInfo -> FixityInfo)
-> (FixityInfo -> FixityInfo -> FixityInfo)
-> Ord FixityInfo
FixityInfo -> FixityInfo -> Bool
FixityInfo -> FixityInfo -> Ordering
FixityInfo -> FixityInfo -> FixityInfo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FixityInfo -> FixityInfo -> FixityInfo
$cmin :: FixityInfo -> FixityInfo -> FixityInfo
max :: FixityInfo -> FixityInfo -> FixityInfo
$cmax :: FixityInfo -> FixityInfo -> FixityInfo
>= :: FixityInfo -> FixityInfo -> Bool
$c>= :: FixityInfo -> FixityInfo -> Bool
> :: FixityInfo -> FixityInfo -> Bool
$c> :: FixityInfo -> FixityInfo -> Bool
<= :: FixityInfo -> FixityInfo -> Bool
$c<= :: FixityInfo -> FixityInfo -> Bool
< :: FixityInfo -> FixityInfo -> Bool
$c< :: FixityInfo -> FixityInfo -> Bool
compare :: FixityInfo -> FixityInfo -> Ordering
$ccompare :: FixityInfo -> FixityInfo -> Ordering
$cp1Ord :: Eq FixityInfo
Ord, Int -> FixityInfo -> ShowS
[FixityInfo] -> ShowS
FixityInfo -> String
(Int -> FixityInfo -> ShowS)
-> (FixityInfo -> String)
-> ([FixityInfo] -> ShowS)
-> Show FixityInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FixityInfo] -> ShowS
$cshowList :: [FixityInfo] -> ShowS
show :: FixityInfo -> String
$cshow :: FixityInfo -> String
showsPrec :: Int -> FixityInfo -> ShowS
$cshowsPrec :: Int -> FixityInfo -> ShowS
Show, FixityInfo -> Q Exp
FixityInfo -> Q (TExp FixityInfo)
(FixityInfo -> Q Exp)
-> (FixityInfo -> Q (TExp FixityInfo)) -> Lift FixityInfo
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: FixityInfo -> Q (TExp FixityInfo)
$cliftTyped :: FixityInfo -> Q (TExp FixityInfo)
lift :: FixityInfo -> Q Exp
$clift :: FixityInfo -> Q Exp
TH.Lift)

instance FromJSON FixityInfo where
  parseJSON :: Value -> Parser FixityInfo
parseJSON = String
-> (Object -> Parser FixityInfo) -> Value -> Parser FixityInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"FixitiyInfo" ((Object -> Parser FixityInfo) -> Value -> Parser FixityInfo)
-> (Object -> Parser FixityInfo) -> Value -> Parser FixityInfo
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Maybe FixityDirection -> Int -> Int -> FixityInfo
FixityInfo
      (Maybe FixityDirection -> Int -> Int -> FixityInfo)
-> Parser (Maybe FixityDirection)
-> Parser (Int -> Int -> FixityInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser (Maybe FixityDirection)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"dir")
      Parser (Int -> Int -> FixityInfo)
-> Parser Int -> Parser (Int -> FixityInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"min_prec"
      Parser (Int -> FixityInfo) -> Parser Int -> Parser FixityInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"max_prec"

instance ToJSON FixityInfo where
  toJSON :: FixityInfo -> Value
toJSON FixityInfo {Int
Maybe FixityDirection
fiMaxPrecedence :: Int
fiMinPrecedence :: Int
fiDirection :: Maybe FixityDirection
fiMaxPrecedence :: FixityInfo -> Int
fiMinPrecedence :: FixityInfo -> Int
fiDirection :: FixityInfo -> Maybe FixityDirection
..} =
    [Pair] -> Value
A.object
      [ Key
"dir" Key -> Maybe FixityDirection -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe FixityDirection
fiDirection,
        Key
"min_prec" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
fiMinPrecedence,
        Key
"max_prec" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
fiMaxPrecedence
      ]

-- | The lowest level of information we can have about an operator.
defaultFixityInfo :: FixityInfo
defaultFixityInfo :: FixityInfo
defaultFixityInfo =
  FixityInfo :: Maybe FixityDirection -> Int -> Int -> FixityInfo
FixityInfo
    { fiDirection :: Maybe FixityDirection
fiDirection = Maybe FixityDirection
forall a. Maybe a
Nothing,
      fiMinPrecedence :: Int
fiMinPrecedence = Int
0,
      fiMaxPrecedence :: Int
fiMaxPrecedence = Int
9
    }

-- | Fixity info of the built-in colon data constructor.
colonFixityInfo :: FixityInfo
colonFixityInfo :: FixityInfo
colonFixityInfo =
  FixityInfo :: Maybe FixityDirection -> Int -> Int -> FixityInfo
FixityInfo
    { fiDirection :: Maybe FixityDirection
fiDirection = FixityDirection -> Maybe FixityDirection
forall a. a -> Maybe a
Just FixityDirection
InfixR,
      fiMinPrecedence :: Int
fiMinPrecedence = Int
5,
      fiMaxPrecedence :: Int
fiMaxPrecedence = Int
5
    }

-- | Gives the ability to merge two (maybe conflicting) definitions for an
-- operator, keeping the higher level of compatible information from both.
instance Semigroup FixityInfo where
  FixityInfo {fiDirection :: FixityInfo -> Maybe FixityDirection
fiDirection = Maybe FixityDirection
dir1, fiMinPrecedence :: FixityInfo -> Int
fiMinPrecedence = Int
min1, fiMaxPrecedence :: FixityInfo -> Int
fiMaxPrecedence = Int
max1}
    <> :: FixityInfo -> FixityInfo -> FixityInfo
<> FixityInfo {fiDirection :: FixityInfo -> Maybe FixityDirection
fiDirection = Maybe FixityDirection
dir2, fiMinPrecedence :: FixityInfo -> Int
fiMinPrecedence = Int
min2, fiMaxPrecedence :: FixityInfo -> Int
fiMaxPrecedence = Int
max2} =
      FixityInfo :: Maybe FixityDirection -> Int -> Int -> FixityInfo
FixityInfo
        { fiDirection :: Maybe FixityDirection
fiDirection = Maybe FixityDirection
dir',
          fiMinPrecedence :: Int
fiMinPrecedence = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
min1 Int
min2,
          fiMaxPrecedence :: Int
fiMaxPrecedence = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
max1 Int
max2
        }
      where
        dir' :: Maybe FixityDirection
dir' = case (Maybe FixityDirection
dir1, Maybe FixityDirection
dir2) of
          (Just FixityDirection
a, Just FixityDirection
b) | FixityDirection
a FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
b -> FixityDirection -> Maybe FixityDirection
forall a. a -> Maybe a
Just FixityDirection
a
          (Maybe FixityDirection, Maybe FixityDirection)
_ -> Maybe FixityDirection
forall a. Maybe a
Nothing

-- | Map from the operator name to its 'FixityInfo'.
type FixityMap = Map String FixityInfo

-- | A variant of 'FixityMap', represented as a lazy union of several
-- 'FixityMap's.
newtype LazyFixityMap = LazyFixityMap [FixityMap]
  deriving (Int -> LazyFixityMap -> ShowS
[LazyFixityMap] -> ShowS
LazyFixityMap -> String
(Int -> LazyFixityMap -> ShowS)
-> (LazyFixityMap -> String)
-> ([LazyFixityMap] -> ShowS)
-> Show LazyFixityMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LazyFixityMap] -> ShowS
$cshowList :: [LazyFixityMap] -> ShowS
show :: LazyFixityMap -> String
$cshow :: LazyFixityMap -> String
showsPrec :: Int -> LazyFixityMap -> ShowS
$cshowsPrec :: Int -> LazyFixityMap -> ShowS
Show)

-- | Lookup a 'FixityInfo' of an operator. This might have drastically
-- different performance depending on whether this is an "unusal"
-- operator.
lookupFixity :: String -> LazyFixityMap -> Maybe FixityInfo
lookupFixity :: String -> LazyFixityMap -> Maybe FixityInfo
lookupFixity String
op (LazyFixityMap [FixityMap]
maps) = [Maybe FixityInfo] -> Maybe FixityInfo
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (String -> FixityMap -> Maybe FixityInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
op (FixityMap -> Maybe FixityInfo)
-> [FixityMap] -> [Maybe FixityInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FixityMap]
maps)

-- | The map of operators declared by each package and the popularity of
-- each package, if available.
data HackageInfo
  = HackageInfo
      (Map String FixityMap)
      -- ^ Map from package name to a map from operator name to its fixity
      (Map String Int)
      -- ^ Map from package name to its 30-days download count from Hackage
  deriving (HackageInfo -> Q Exp
HackageInfo -> Q (TExp HackageInfo)
(HackageInfo -> Q Exp)
-> (HackageInfo -> Q (TExp HackageInfo)) -> Lift HackageInfo
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: HackageInfo -> Q (TExp HackageInfo)
$cliftTyped :: HackageInfo -> Q (TExp HackageInfo)
lift :: HackageInfo -> Q Exp
$clift :: HackageInfo -> Q Exp
TH.Lift)

instance FromJSON HackageInfo where
  parseJSON :: Value -> Parser HackageInfo
parseJSON = String
-> (Object -> Parser HackageInfo) -> Value -> Parser HackageInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"HackageInfo" ((Object -> Parser HackageInfo) -> Value -> Parser HackageInfo)
-> (Object -> Parser HackageInfo) -> Value -> Parser HackageInfo
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Map String FixityMap -> Map String Int -> HackageInfo
HackageInfo
      (Map String FixityMap -> Map String Int -> HackageInfo)
-> Parser (Map String FixityMap)
-> Parser (Map String Int -> HackageInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Map String FixityMap)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"operators"
      Parser (Map String Int -> HackageInfo)
-> Parser (Map String Int) -> Parser HackageInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Map String Int)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"popularity"

instance ToJSON HackageInfo where
  toJSON :: HackageInfo -> Value
toJSON (HackageInfo Map String FixityMap
operators Map String Int
popularity) =
    [Pair] -> Value
A.object
      [ Key
"operators" Key -> Map String FixityMap -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Map String FixityMap
operators,
        Key
"popularity" Key -> Map String Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Map String Int
popularity
      ]