{-# LANGUAGE ViewPatterns #-}
module GHC.Core.UsageEnv (UsageEnv, addUsage, scaleUsage, zeroUE,
                          lookupUE, scaleUE, deleteUE, addUE, Usage(..), unitUE,
                          bottomUE, supUE, supUEs) where

import Data.Foldable
import GHC.Prelude
import GHC.Core.Multiplicity
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Utils.Outputable

--
-- * Usage environments
--

-- The typechecker and the linter output usage environments. See Note [Usages]
-- in Multiplicity. Every absent name being considered to map to 'Zero' of
-- 'Bottom' depending on a flag. See Note [Zero as a usage] in Multiplicity, see
-- Note [Bottom as a usage] in Multiplicity.

data Usage = Zero | Bottom | MUsage Mult

instance Outputable Usage where
  ppr :: Usage -> SDoc
ppr Usage
Zero = String -> SDoc
text String
"0"
  ppr Usage
Bottom = String -> SDoc
text String
"Bottom"
  ppr (MUsage Mult
x) = Mult -> SDoc
forall a. Outputable a => a -> SDoc
ppr Mult
x

addUsage :: Usage -> Usage -> Usage
addUsage :: Usage -> Usage -> Usage
addUsage Usage
Zero Usage
x = Usage
x
addUsage Usage
x Usage
Zero = Usage
x
addUsage Usage
Bottom Usage
x = Usage
x
addUsage Usage
x Usage
Bottom = Usage
x
addUsage (MUsage Mult
x) (MUsage Mult
y) = Mult -> Usage
MUsage (Mult -> Usage) -> Mult -> Usage
forall a b. (a -> b) -> a -> b
$ Mult -> Mult -> Mult
mkMultAdd Mult
x Mult
y

scaleUsage :: Mult -> Usage -> Usage
scaleUsage :: Mult -> Usage -> Usage
scaleUsage Mult
One Usage
Bottom     = Usage
Bottom
scaleUsage Mult
_   Usage
Zero       = Usage
Zero
scaleUsage Mult
x   Usage
Bottom     = Mult -> Usage
MUsage Mult
x
scaleUsage Mult
x   (MUsage Mult
y) = Mult -> Usage
MUsage (Mult -> Usage) -> Mult -> Usage
forall a b. (a -> b) -> a -> b
$ Mult -> Mult -> Mult
mkMultMul Mult
x Mult
y

-- For now, we use extra multiplicity Bottom for empty case.
data UsageEnv = UsageEnv (NameEnv Mult) Bool

unitUE :: NamedThing n => n -> Mult -> UsageEnv
unitUE :: forall n. NamedThing n => n -> Mult -> UsageEnv
unitUE n
x Mult
w = NameEnv Mult -> Bool -> UsageEnv
UsageEnv (Name -> Mult -> NameEnv Mult
forall a. Name -> a -> NameEnv a
unitNameEnv (n -> Name
forall a. NamedThing a => a -> Name
getName n
x) Mult
w) Bool
False

zeroUE, bottomUE :: UsageEnv
zeroUE :: UsageEnv
zeroUE = NameEnv Mult -> Bool -> UsageEnv
UsageEnv NameEnv Mult
forall a. NameEnv a
emptyNameEnv Bool
False

bottomUE :: UsageEnv
bottomUE = NameEnv Mult -> Bool -> UsageEnv
UsageEnv NameEnv Mult
forall a. NameEnv a
emptyNameEnv Bool
True

addUE :: UsageEnv -> UsageEnv -> UsageEnv
addUE :: UsageEnv -> UsageEnv -> UsageEnv
addUE (UsageEnv NameEnv Mult
e1 Bool
b1) (UsageEnv NameEnv Mult
e2 Bool
b2) =
  NameEnv Mult -> Bool -> UsageEnv
UsageEnv ((Mult -> Mult -> Mult)
-> NameEnv Mult -> NameEnv Mult -> NameEnv Mult
forall a. (a -> a -> a) -> NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C Mult -> Mult -> Mult
mkMultAdd NameEnv Mult
e1 NameEnv Mult
e2) (Bool
b1 Bool -> Bool -> Bool
|| Bool
b2)

scaleUE :: Mult -> UsageEnv -> UsageEnv
scaleUE :: Mult -> UsageEnv -> UsageEnv
scaleUE Mult
One UsageEnv
ue = UsageEnv
ue
scaleUE Mult
w (UsageEnv NameEnv Mult
e Bool
_) =
  NameEnv Mult -> Bool -> UsageEnv
UsageEnv ((Mult -> Mult) -> NameEnv Mult -> NameEnv Mult
forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv (Mult -> Mult -> Mult
mkMultMul Mult
w) NameEnv Mult
e) Bool
False

supUE :: UsageEnv -> UsageEnv -> UsageEnv
supUE :: UsageEnv -> UsageEnv -> UsageEnv
supUE (UsageEnv NameEnv Mult
e1 Bool
False) (UsageEnv NameEnv Mult
e2 Bool
False) =
  NameEnv Mult -> Bool -> UsageEnv
UsageEnv ((Mult -> Mult -> Mult)
-> NameEnv Mult -> Mult -> NameEnv Mult -> Mult -> NameEnv Mult
forall a.
(a -> a -> a) -> NameEnv a -> a -> NameEnv a -> a -> NameEnv a
plusNameEnv_CD Mult -> Mult -> Mult
mkMultSup NameEnv Mult
e1 Mult
Many NameEnv Mult
e2 Mult
Many) Bool
False
supUE (UsageEnv NameEnv Mult
e1 Bool
b1) (UsageEnv NameEnv Mult
e2 Bool
b2) = NameEnv Mult -> Bool -> UsageEnv
UsageEnv ((Maybe Mult -> Maybe Mult -> Mult)
-> NameEnv Mult -> NameEnv Mult -> NameEnv Mult
forall a.
(Maybe a -> Maybe a -> a) -> NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_CD2 Maybe Mult -> Maybe Mult -> Mult
combineUsage NameEnv Mult
e1 NameEnv Mult
e2) (Bool
b1 Bool -> Bool -> Bool
&& Bool
b2)
   where combineUsage :: Maybe Mult -> Maybe Mult -> Mult
combineUsage (Just Mult
x) (Just Mult
y) = Mult -> Mult -> Mult
mkMultSup Mult
x Mult
y
         combineUsage Maybe Mult
Nothing  (Just Mult
x) | Bool
b1        = Mult
x
                                        | Bool
otherwise = Mult
Many
         combineUsage (Just Mult
x) Maybe Mult
Nothing  | Bool
b2        = Mult
x
                                        | Bool
otherwise = Mult
Many
         combineUsage Maybe Mult
Nothing  Maybe Mult
Nothing  = String -> SDoc -> Mult
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"supUE" (NameEnv Mult -> SDoc
forall a. Outputable a => a -> SDoc
ppr NameEnv Mult
e1 SDoc -> SDoc -> SDoc
<+> NameEnv Mult -> SDoc
forall a. Outputable a => a -> SDoc
ppr NameEnv Mult
e2)
-- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well.

supUEs :: [UsageEnv] -> UsageEnv
supUEs :: [UsageEnv] -> UsageEnv
supUEs = (UsageEnv -> UsageEnv -> UsageEnv)
-> UsageEnv -> [UsageEnv] -> UsageEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UsageEnv -> UsageEnv -> UsageEnv
supUE UsageEnv
bottomUE


deleteUE :: NamedThing n => UsageEnv -> n -> UsageEnv
deleteUE :: forall n. NamedThing n => UsageEnv -> n -> UsageEnv
deleteUE (UsageEnv NameEnv Mult
e Bool
b) n
x = NameEnv Mult -> Bool -> UsageEnv
UsageEnv (NameEnv Mult -> Name -> NameEnv Mult
forall a. NameEnv a -> Name -> NameEnv a
delFromNameEnv NameEnv Mult
e (n -> Name
forall a. NamedThing a => a -> Name
getName n
x)) Bool
b

-- | |lookupUE x env| returns the multiplicity assigned to |x| in |env|, if |x| is not
-- bound in |env|, then returns |Zero| or |Bottom|.
lookupUE :: NamedThing n => UsageEnv -> n -> Usage
lookupUE :: forall n. NamedThing n => UsageEnv -> n -> Usage
lookupUE (UsageEnv NameEnv Mult
e Bool
has_bottom) n
x =
  case NameEnv Mult -> Name -> Maybe Mult
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Mult
e (n -> Name
forall a. NamedThing a => a -> Name
getName n
x) of
    Just Mult
w  -> Mult -> Usage
MUsage Mult
w
    Maybe Mult
Nothing -> if Bool
has_bottom then Usage
Bottom else Usage
Zero

instance Outputable UsageEnv where
  ppr :: UsageEnv -> SDoc
ppr (UsageEnv NameEnv Mult
ne Bool
b) = String -> SDoc
text String
"UsageEnv:" SDoc -> SDoc -> SDoc
<+> NameEnv Mult -> SDoc
forall a. Outputable a => a -> SDoc
ppr NameEnv Mult
ne SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
b