{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- XOverlapMode, XXOverlapMode

{-# OPTIONS_GHC -fno-warn-orphans #-}
{- Necessary for the following instances:
  * (type class):  Binary OverlapMode
  * (type class):  NFData OverlapMode
-}

{- |
Data-types describing the overlap annotations for instances as well as
interpreting the instances usage within the Safe Haskell context.
-}
module GHC.Hs.Decls.Overlap (
        -- * OverlapFlag
        -- ** Data-type
        OverlapFlag(..),

        -- * OverlapMode
        -- ** Data-type
        OverlapMode(..),
        -- ** Queries
        hasOverlappableFlag,
        hasOverlappingFlag,
        hasIncoherentFlag,
        hasNonCanonicalFlag,
    ) where

import GHC.Prelude

import GHC.Hs.Extension

import Language.Haskell.Syntax.Decls.Overlap
import Language.Haskell.Syntax.Extension

import GHC.Types.SourceText
import GHC.Utils.Binary
import GHC.Utils.Outputable

import Control.DeepSeq (NFData(..))

{-
************************************************************************
*                                                                      *
                Instance overlap flag
*                                                                      *
************************************************************************
-}

-- | The semantics allowed for overlapping instances for a particular
-- instance. See Note [Safe Haskell isSafeOverlap] in GHC.Core.InstEnv for a
-- explanation of the `isSafeOverlap` field.
data OverlapFlag = OverlapFlag
  { OverlapFlag -> Bool
isSafeOverlap :: Bool
  , OverlapFlag -> OverlapMode GhcTc
overlapMode   :: OverlapMode GhcTc
  } deriving (OverlapFlag -> OverlapFlag -> Bool
(OverlapFlag -> OverlapFlag -> Bool)
-> (OverlapFlag -> OverlapFlag -> Bool) -> Eq OverlapFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OverlapFlag -> OverlapFlag -> Bool
== :: OverlapFlag -> OverlapFlag -> Bool
$c/= :: OverlapFlag -> OverlapFlag -> Bool
/= :: OverlapFlag -> OverlapFlag -> Bool
Eq)

instance Binary OverlapFlag where
    put_ :: WriteBinHandle -> OverlapFlag -> IO ()
put_ WriteBinHandle
bh OverlapFlag
flag = do WriteBinHandle -> OverlapMode GhcTc -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (OverlapFlag -> OverlapMode GhcTc
overlapMode OverlapFlag
flag)
                      WriteBinHandle -> Bool -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (OverlapFlag -> Bool
isSafeOverlap OverlapFlag
flag)
    get :: ReadBinHandle -> IO OverlapFlag
get ReadBinHandle
bh = do
        h <- ReadBinHandle -> IO (OverlapMode GhcTc)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
        b <- get bh
        return OverlapFlag { isSafeOverlap = b, overlapMode = h }

instance NFData OverlapFlag where
    rnf :: OverlapFlag -> ()
rnf (OverlapFlag Bool
mode OverlapMode GhcTc
safe) = Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
mode () -> () -> ()
forall a b. a -> b -> b
`seq` OverlapMode GhcTc -> ()
forall a. NFData a => a -> ()
rnf OverlapMode GhcTc
safe

instance Outputable OverlapFlag where
    ppr :: OverlapFlag -> SDoc
ppr OverlapFlag
flag = OverlapMode GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OverlapFlag -> OverlapMode GhcTc
overlapMode OverlapFlag
flag) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
pprSafeOverlap (OverlapFlag -> Bool
isSafeOverlap OverlapFlag
flag)

type instance XOverlapMode  (GhcPass _) = SourceText

type instance XXOverlapMode (GhcPass _) = DataConCantHappen

instance NFData (OverlapMode (GhcPass p)) where
    rnf :: OverlapMode (GhcPass p) -> ()
rnf = \case
        NoOverlap    XOverlapMode (GhcPass p)
s -> SourceText -> ()
forall a. NFData a => a -> ()
rnf XOverlapMode (GhcPass p)
SourceText
s
        Overlappable XOverlapMode (GhcPass p)
s -> SourceText -> ()
forall a. NFData a => a -> ()
rnf XOverlapMode (GhcPass p)
SourceText
s
        Overlapping  XOverlapMode (GhcPass p)
s -> SourceText -> ()
forall a. NFData a => a -> ()
rnf XOverlapMode (GhcPass p)
SourceText
s
        Overlaps     XOverlapMode (GhcPass p)
s -> SourceText -> ()
forall a. NFData a => a -> ()
rnf XOverlapMode (GhcPass p)
SourceText
s
        Incoherent   XOverlapMode (GhcPass p)
s -> SourceText -> ()
forall a. NFData a => a -> ()
rnf XOverlapMode (GhcPass p)
SourceText
s
        NonCanonical XOverlapMode (GhcPass p)
s -> SourceText -> ()
forall a. NFData a => a -> ()
rnf XOverlapMode (GhcPass p)
SourceText
s

instance Binary (OverlapMode (GhcPass p)) where
    put_ :: WriteBinHandle -> OverlapMode (GhcPass p) -> IO ()
put_ WriteBinHandle
bh = \case
        NoOverlap    XOverlapMode (GhcPass p)
s -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> SourceText -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh XOverlapMode (GhcPass p)
SourceText
s
        Overlaps     XOverlapMode (GhcPass p)
s -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> SourceText -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh XOverlapMode (GhcPass p)
SourceText
s
        Incoherent   XOverlapMode (GhcPass p)
s -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
2 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> SourceText -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh XOverlapMode (GhcPass p)
SourceText
s
        Overlapping  XOverlapMode (GhcPass p)
s -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
3 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> SourceText -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh XOverlapMode (GhcPass p)
SourceText
s
        Overlappable XOverlapMode (GhcPass p)
s -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
4 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> SourceText -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh XOverlapMode (GhcPass p)
SourceText
s
        NonCanonical XOverlapMode (GhcPass p)
s -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
5 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriteBinHandle -> SourceText -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh XOverlapMode (GhcPass p)
SourceText
s

    get :: ReadBinHandle -> IO (OverlapMode (GhcPass p))
get ReadBinHandle
bh = do
        h <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
        case h of
            Word8
0 -> ReadBinHandle -> IO SourceText
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh IO SourceText
-> (SourceText -> IO (OverlapMode (GhcPass p)))
-> IO (OverlapMode (GhcPass p))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SourceText
s -> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p)))
-> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a b. (a -> b) -> a -> b
$ XOverlapMode (GhcPass p) -> OverlapMode (GhcPass p)
forall pass. XOverlapMode pass -> OverlapMode pass
NoOverlap    XOverlapMode (GhcPass p)
SourceText
s
            Word8
1 -> ReadBinHandle -> IO SourceText
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh IO SourceText
-> (SourceText -> IO (OverlapMode (GhcPass p)))
-> IO (OverlapMode (GhcPass p))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SourceText
s -> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p)))
-> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a b. (a -> b) -> a -> b
$ XOverlapMode (GhcPass p) -> OverlapMode (GhcPass p)
forall pass. XOverlapMode pass -> OverlapMode pass
Overlaps     XOverlapMode (GhcPass p)
SourceText
s
            Word8
2 -> ReadBinHandle -> IO SourceText
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh IO SourceText
-> (SourceText -> IO (OverlapMode (GhcPass p)))
-> IO (OverlapMode (GhcPass p))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SourceText
s -> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p)))
-> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a b. (a -> b) -> a -> b
$ XOverlapMode (GhcPass p) -> OverlapMode (GhcPass p)
forall pass. XOverlapMode pass -> OverlapMode pass
Incoherent   XOverlapMode (GhcPass p)
SourceText
s
            Word8
3 -> ReadBinHandle -> IO SourceText
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh IO SourceText
-> (SourceText -> IO (OverlapMode (GhcPass p)))
-> IO (OverlapMode (GhcPass p))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SourceText
s -> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p)))
-> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a b. (a -> b) -> a -> b
$ XOverlapMode (GhcPass p) -> OverlapMode (GhcPass p)
forall pass. XOverlapMode pass -> OverlapMode pass
Overlapping  XOverlapMode (GhcPass p)
SourceText
s
            Word8
4 -> ReadBinHandle -> IO SourceText
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh IO SourceText
-> (SourceText -> IO (OverlapMode (GhcPass p)))
-> IO (OverlapMode (GhcPass p))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SourceText
s -> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p)))
-> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a b. (a -> b) -> a -> b
$ XOverlapMode (GhcPass p) -> OverlapMode (GhcPass p)
forall pass. XOverlapMode pass -> OverlapMode pass
Overlappable XOverlapMode (GhcPass p)
SourceText
s
            Word8
_ -> ReadBinHandle -> IO SourceText
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh IO SourceText
-> (SourceText -> IO (OverlapMode (GhcPass p)))
-> IO (OverlapMode (GhcPass p))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SourceText
s -> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p)))
-> OverlapMode (GhcPass p) -> IO (OverlapMode (GhcPass p))
forall a b. (a -> b) -> a -> b
$ XOverlapMode (GhcPass p) -> OverlapMode (GhcPass p)
forall pass. XOverlapMode pass -> OverlapMode pass
NonCanonical XOverlapMode (GhcPass p)
SourceText
s

pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap Bool
True  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"[safe]"
pprSafeOverlap Bool
False = SDoc
forall doc. IsOutput doc => doc
empty