{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
module Rattus.Plugin.ScopeCheck (checkExpr, emptyCtx) where

import Rattus.Plugin.Utils 

import Prelude hiding ((<>))
import GhcPlugins
import Control.Monad
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe

type LCtx = Set Var
data HiddenReason = BoxApp | AdvApp | NestedRec Var | FunDef
type Hidden = Map Var HiddenReason

data Prim = Delay | Adv | Box | Unbox | Arr

instance Outputable Prim where
  ppr :: Prim -> SDoc
ppr Delay = "delay"
  ppr Adv = "adv"
  ppr Box = "box"
  ppr Unbox = "unbox"
  ppr Arr = "arr"
  

type RecDef = Set Var

data Ctx = Ctx
  { Ctx -> LCtx
current :: LCtx,
    Ctx -> Hidden
hidden :: Hidden,
    Ctx -> Hidden
hiddenRec :: Hidden,
    Ctx -> Maybe LCtx
earlier :: Maybe LCtx,
    Ctx -> SrcSpan
srcLoc :: SrcSpan,
    Ctx -> Maybe LCtx
recDef :: Maybe RecDef,
    Ctx -> LCtx
stableTypes :: Set Var,
    Ctx -> Map Var Prim
primAlias :: Map Var Prim,
    Ctx -> Var
funDef :: Var,
    Ctx -> Bool
stabilized :: Bool}

primMap :: Map FastString Prim
primMap :: Map FastString Prim
primMap = [(FastString, Prim)] -> Map FastString Prim
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [("Delay", Prim
Delay),
   ("delay", Prim
Delay),
   ("adv", Prim
Adv),
   ("box", Prim
Box),
   ("arr", Prim
Arr),
   ("unbox", Prim
Unbox)]


isPrim :: Ctx -> Var -> Maybe Prim
isPrim :: Ctx -> Var -> Maybe Prim
isPrim c :: Ctx
c v :: Var
v
  | Just p :: Prim
p <- Var -> Map Var Prim -> Maybe Prim
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctx -> Map Var Prim
primAlias Ctx
c) = Prim -> Maybe Prim
forall a. a -> Maybe a
Just Prim
p
  | Bool
otherwise = do
  (name :: FastString
name,mod :: FastString
mod) <- Var -> Maybe (FastString, FastString)
forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule Var
v
  if FastString -> Bool
isRattModule FastString
mod then FastString -> Map FastString Prim -> Maybe Prim
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FastString
name Map FastString Prim
primMap
  else Maybe Prim
forall a. Maybe a
Nothing

stabilizeLater :: Ctx -> Ctx
stabilizeLater :: Ctx -> Ctx
stabilizeLater c :: Ctx
c =
  if Maybe LCtx -> Bool
forall a. Maybe a -> Bool
isJust (Ctx -> Maybe LCtx
earlier Ctx
c)
  then Ctx
c {earlier :: Maybe LCtx
earlier = Maybe LCtx
forall a. Maybe a
Nothing,
          hidden :: Hidden
hidden = Hidden
hid,
          hiddenRec :: Hidden
hiddenRec = Hidden -> (LCtx -> Hidden) -> Maybe LCtx -> Hidden
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Ctx -> Hidden
hiddenRec Ctx
c) (Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Ctx -> Hidden
hidden Ctx
c) (Hidden -> Hidden) -> (LCtx -> Hidden) -> LCtx -> Hidden
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> HiddenReason) -> LCtx -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const HiddenReason
FunDef)) (Ctx -> Maybe LCtx
recDef Ctx
c),
          recDef :: Maybe LCtx
recDef = Maybe LCtx
forall a. Maybe a
Nothing}
  else Ctx
c {earlier :: Maybe LCtx
earlier = Maybe LCtx
forall a. Maybe a
Nothing,
          hidden :: Hidden
hidden = Hidden
hid}
  where hid :: Hidden
hid = Hidden -> (LCtx -> Hidden) -> Maybe LCtx -> Hidden
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Ctx -> Hidden
hidden Ctx
c) (Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Ctx -> Hidden
hidden Ctx
c) (Hidden -> Hidden) -> (LCtx -> Hidden) -> LCtx -> Hidden
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> HiddenReason) -> LCtx -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const HiddenReason
FunDef)) (Ctx -> Maybe LCtx
earlier Ctx
c)


stabilize :: HiddenReason -> Ctx -> Ctx
stabilize :: HiddenReason -> Ctx -> Ctx
stabilize hr :: HiddenReason
hr c :: Ctx
c = Ctx
c
  {current :: LCtx
current = LCtx
forall a. Set a
Set.empty,
   earlier :: Maybe LCtx
earlier = Maybe LCtx
forall a. Maybe a
Nothing,
   hidden :: Hidden
hidden = Ctx -> Hidden
hidden Ctx
c Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Var -> HiddenReason) -> LCtx -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const HiddenReason
hr) LCtx
ctxHid,
   hiddenRec :: Hidden
hiddenRec = Ctx -> Hidden
hiddenRec Ctx
c Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Hidden -> (LCtx -> Hidden) -> Maybe LCtx -> Hidden
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Hidden
forall k a. Map k a
Map.empty ((Var -> HiddenReason) -> LCtx -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const HiddenReason
hr)) (Ctx -> Maybe LCtx
recDef Ctx
c),
   recDef :: Maybe LCtx
recDef = Maybe LCtx
forall a. Maybe a
Nothing,
   stabilized :: Bool
stabilized = Bool
True}
  where ctxHid :: LCtx
ctxHid = LCtx -> (LCtx -> LCtx) -> Maybe LCtx -> LCtx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Ctx -> LCtx
current Ctx
c) (LCtx -> LCtx -> LCtx
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctx -> LCtx
current Ctx
c)) (Ctx -> Maybe LCtx
earlier Ctx
c)


data Scope = Hidden SDoc | Visible | ImplUnboxed

getScope  :: Ctx -> Var -> Scope
getScope :: Ctx -> Var -> Scope
getScope Ctx{recDef :: Ctx -> Maybe LCtx
recDef = Just (LCtx
vs), funDef :: Ctx -> Var
funDef = Var
recV, earlier :: Ctx -> Maybe LCtx
earlier = Maybe LCtx
e} v :: Var
v
  | Var
v Var -> LCtx -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` LCtx
vs =
    case Maybe LCtx
e of
      Just _ -> Scope
Visible
      Nothing 
        | Var
recV Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v -> SDoc -> Scope
Hidden ("Recursive call to " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " must occur under delay")
        | Bool
otherwise -> SDoc -> Scope
Hidden ("Mutually recursice call to " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " must occur under delay")
  
--getScope Ctx{hiddenRecs = h} v
  -- recursive call that is out of scope
--  | (Set.member v h) = Hidden ""
getScope c :: Ctx
c v :: Var
v =
  case Var -> Hidden -> Maybe HiddenReason
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctx -> Hidden
hiddenRec Ctx
c) of
    Just (NestedRec rv :: Var
rv) -> SDoc -> Scope
Hidden ("Recursive call to" SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<>
                            " is not allowed as it occurs in a local recursive definiton (namely of " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
rv SDoc -> SDoc -> SDoc
<> ")")
    Just BoxApp -> SDoc -> Scope
Hidden ("Recursive call to " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " is not allowed here, since it occurs under a box")
    Just FunDef -> SDoc -> Scope
Hidden ("Recursive call to " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " is not allowed here, since it occurs in a function that is defined under delay")
    Just AdvApp -> SDoc -> Scope
Hidden ("This should not happen: recursive call to " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " is out of scope due to adv")
    Nothing -> 
      case Var -> Hidden -> Maybe HiddenReason
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
v (Ctx -> Hidden
hidden Ctx
c) of
        Just (NestedRec rv :: Var
rv) ->
          if (LCtx -> Type -> Bool
isStable (Ctx -> LCtx
stableTypes Ctx
c) (Var -> Type
varType Var
v)) then Scope
Visible
          else SDoc -> Scope
Hidden ("Variable " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " is no longer in scope:" SDoc -> SDoc -> SDoc
$$
                       "It appears in a local recursive definiton (namely of " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
rv SDoc -> SDoc -> SDoc
<> ")"
                       SDoc -> SDoc -> SDoc
$$ "and is of type " SDoc -> SDoc -> SDoc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> ", which is not stable.")
        Just BoxApp ->
          if (LCtx -> Type -> Bool
isStable (Ctx -> LCtx
stableTypes Ctx
c) (Var -> Type
varType Var
v)) then Scope
Visible
          else SDoc -> Scope
Hidden ("Variable " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " is no longer in scope:" SDoc -> SDoc -> SDoc
$$
                       "It occurs under " SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
keyword "box" SDoc -> SDoc -> SDoc
$$ "and is of type " SDoc -> SDoc -> SDoc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> ", which is not stable.")
        Just AdvApp -> SDoc -> Scope
Hidden ("Variable " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " is no longer in scope: It occurs under adv.")
        Just FunDef -> if (LCtx -> Type -> Bool
isStable (Ctx -> LCtx
stableTypes Ctx
c) (Var -> Type
varType Var
v)) then Scope
Visible
          else SDoc -> Scope
Hidden ("Variable " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " is no longer in scope: It occurs in a function that is defined under a delay, is a of a non-stable type " SDoc -> SDoc -> SDoc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> ", and is bound outside delay")
        Nothing
          | Bool -> (LCtx -> Bool) -> Maybe LCtx -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Var -> LCtx -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Var
v) (Ctx -> Maybe LCtx
earlier Ctx
c) ->
            if LCtx -> Type -> Bool
isStable (Ctx -> LCtx
stableTypes Ctx
c) (Var -> Type
varType Var
v) then Scope
Visible
            else SDoc -> Scope
Hidden ("Variable " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " is no longer in scope:" SDoc -> SDoc -> SDoc
$$
                         "It occurs under delay" SDoc -> SDoc -> SDoc
$$ "and is of type " SDoc -> SDoc -> SDoc
<> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Type
varType Var
v) SDoc -> SDoc -> SDoc
<> ", which is not stable.")
          | Var -> LCtx -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Var
v (Ctx -> LCtx
current Ctx
c) -> Scope
Visible
          | Type -> Bool
isTemporal (Var -> Type
varType Var
v) Bool -> Bool -> Bool
&& Maybe LCtx -> Bool
forall a. Maybe a -> Bool
isJust (Ctx -> Maybe LCtx
earlier Ctx
c) Bool -> Bool -> Bool
&& Var -> Bool
userFunction Var
v
            -> Scope
ImplUnboxed
          | Bool
otherwise -> Scope
Visible



pickFirst :: SrcSpan -> SrcSpan -> SrcSpan
pickFirst :: SrcSpan -> SrcSpan -> SrcSpan
pickFirst s :: SrcSpan
s@RealSrcSpan{} _ = SrcSpan
s
pickFirst _ s :: SrcSpan
s = SrcSpan
s

printMessage' :: Severity -> Ctx -> Var -> SDoc -> CoreM ()
printMessage' :: Severity -> Ctx -> Var -> SDoc -> CoreM ()
printMessage' sev :: Severity
sev cxt :: Ctx
cxt var :: Var
var doc :: SDoc
doc =
  Severity -> SrcSpan -> SDoc -> CoreM ()
printMessage Severity
sev (SrcSpan -> SrcSpan -> SrcSpan
pickFirst (Ctx -> SrcSpan
srcLoc Ctx
cxt) (Name -> SrcSpan
nameSrcSpan (Var -> Name
varName Var
var))) SDoc
doc

printMessageCheck :: Severity -> Ctx -> Var -> SDoc -> CoreM Bool
printMessageCheck :: Severity -> Ctx -> Var -> SDoc -> CoreM Bool
printMessageCheck sev :: Severity
sev cxt :: Ctx
cxt var :: Var
var doc :: SDoc
doc = Severity -> Ctx -> Var -> SDoc -> CoreM ()
printMessage' Severity
sev Ctx
cxt Var
var SDoc
doc CoreM () -> CoreM Bool -> CoreM Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  case Severity
sev of
    SevError -> Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    _ -> Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True



emptyCtx :: Maybe (Set Var) -> Var -> Ctx
emptyCtx :: Maybe LCtx -> Var -> Ctx
emptyCtx mvar :: Maybe LCtx
mvar fun :: Var
fun =
  Ctx :: LCtx
-> Hidden
-> Hidden
-> Maybe LCtx
-> SrcSpan
-> Maybe LCtx
-> LCtx
-> Map Var Prim
-> Var
-> Bool
-> Ctx
Ctx { current :: LCtx
current =  LCtx
forall a. Set a
Set.empty,
        earlier :: Maybe LCtx
earlier = Maybe LCtx
forall a. Maybe a
Nothing,
        hidden :: Hidden
hidden = Hidden
forall k a. Map k a
Map.empty,
        hiddenRec :: Hidden
hiddenRec = Hidden
forall k a. Map k a
Map.empty,
        srcLoc :: SrcSpan
srcLoc = FastString -> SrcSpan
UnhelpfulSpan "<no location info>",
        recDef :: Maybe LCtx
recDef = Maybe LCtx
mvar,
        funDef :: Var
funDef = Var
fun,
        primAlias :: Map Var Prim
primAlias = Map Var Prim
forall k a. Map k a
Map.empty,
        stableTypes :: LCtx
stableTypes = LCtx
forall a. Set a
Set.empty,
        stabilized :: Bool
stabilized = Maybe LCtx -> Bool
forall a. Maybe a -> Bool
isJust Maybe LCtx
mvar}


isPrimExpr :: Ctx -> Expr Var -> Maybe (Prim,Var)
isPrimExpr :: Ctx -> Expr Var -> Maybe (Prim, Var)
isPrimExpr c :: Ctx
c (App e :: Expr Var
e (Type _)) = Ctx -> Expr Var -> Maybe (Prim, Var)
isPrimExpr Ctx
c Expr Var
e
isPrimExpr c :: Ctx
c (App e :: Expr Var
e e' :: Expr Var
e') | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Bool
tcIsLiftedTypeKind (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Type
Type -> Type
typeKind (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Expr Var -> Type
exprType Expr Var
e' = Ctx -> Expr Var -> Maybe (Prim, Var)
isPrimExpr Ctx
c Expr Var
e
isPrimExpr c :: Ctx
c (Var v :: Var
v) = (Prim -> (Prim, Var)) -> Maybe Prim -> Maybe (Prim, Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Var
v) (Ctx -> Var -> Maybe Prim
isPrim Ctx
c Var
v)
isPrimExpr c :: Ctx
c (Tick _ e :: Expr Var
e) = Ctx -> Expr Var -> Maybe (Prim, Var)
isPrimExpr Ctx
c Expr Var
e
isPrimExpr c :: Ctx
c (Lam v :: Var
v e :: Expr Var
e)
  | Var -> Bool
isTyVar Var
v Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Bool
tcIsLiftedTypeKind (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Type
Type -> Type
typeKind (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
v) = Ctx -> Expr Var -> Maybe (Prim, Var)
isPrimExpr Ctx
c Expr Var
e
isPrimExpr _ _ = Maybe (Prim, Var)
forall a. Maybe a
Nothing


isStableConstr :: Type -> CoreM (Maybe Var)
isStableConstr :: Type -> CoreM (Maybe Var)
isStableConstr t :: Type
t = 
  case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t of
    Just (con :: TyCon
con,[args :: Type
args]) ->
      case TyCon -> Maybe (FastString, FastString)
forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule TyCon
con of
        Just (name :: FastString
name, mod :: FastString
mod) ->
          if FastString -> Bool
isRattModule FastString
mod Bool -> Bool -> Bool
&& FastString
name FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== "Stable"
          then Maybe Var -> CoreM (Maybe Var)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Maybe Var
getTyVar_maybe Type
args)
          else Maybe Var -> CoreM (Maybe Var)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Var
forall a. Maybe a
Nothing
        _ -> Maybe Var -> CoreM (Maybe Var)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Var
forall a. Maybe a
Nothing                           
    _ ->  Maybe Var -> CoreM (Maybe Var)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Var
forall a. Maybe a
Nothing

checkExpr :: Ctx -> Expr Var -> CoreM Bool
checkExpr :: Ctx -> Expr Var -> CoreM Bool
checkExpr c :: Ctx
c (App e :: Expr Var
e e' :: Expr Var
e') | Expr Var -> Bool
forall b. Expr b -> Bool
isType Expr Var
e' Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Bool
tcIsLiftedTypeKind (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Type
Type -> Type
typeKind (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Expr Var -> Type
exprType Expr Var
e')
  = Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c Expr Var
e
checkExpr c :: Ctx
c@Ctx{current :: Ctx -> LCtx
current = LCtx
cur, hidden :: Ctx -> Hidden
hidden = Hidden
hid, earlier :: Ctx -> Maybe LCtx
earlier = Maybe LCtx
earl} (App e1 :: Expr Var
e1 e2 :: Expr Var
e2) =
  case Ctx -> Expr Var -> Maybe (Prim, Var)
isPrimExpr Ctx
c Expr Var
e1 of
    Just (p :: Prim
p,v :: Var
v) -> case Prim
p of
      Box -> do
        Bool
ch <- Ctx -> Expr Var -> CoreM Bool
checkExpr (HiddenReason -> Ctx -> Ctx
stabilize HiddenReason
BoxApp Ctx
c) Expr Var
e2
        -- don't bother with a warning if the scopecheck fails
        Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
ch Bool -> Bool -> Bool
&& Ctx -> Bool
stabilized Ctx
c Bool -> Bool -> Bool
&& Bool -> Bool
not (LCtx -> Type -> Bool
isStable (Ctx -> LCtx
stableTypes Ctx
c) (Expr Var -> Type
exprType Expr Var
e2)))
          (Severity -> Ctx -> Var -> SDoc -> CoreM ()
printMessage' Severity
SevWarning Ctx
c Var
v
           (String -> SDoc
text "When box is used inside another box or a recursive definition, it can cause time leaks unless applied to an expression of stable type"))
        Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch
      Arr -> do
        Bool
ch <- Ctx -> Expr Var -> CoreM Bool
checkExpr (HiddenReason -> Ctx -> Ctx
stabilize HiddenReason
BoxApp Ctx
c) Expr Var
e2
        -- don't bother with a warning if the scopecheck fails
        Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
ch Bool -> Bool -> Bool
&& Ctx -> Bool
stabilized Ctx
c Bool -> Bool -> Bool
&& Bool -> Bool
not (LCtx -> Type -> Bool
isStable (Ctx -> LCtx
stableTypes Ctx
c) (Expr Var -> Type
exprType Expr Var
e2)))
          (Severity -> Ctx -> Var -> SDoc -> CoreM ()
printMessage' Severity
SevWarning Ctx
c Var
v
            (String -> SDoc
text "When arr is used inside box or a recursive definition, it can cause time leaks unless applied to an expression of stable type"))
        Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ch

      Unbox -> Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c Expr Var
e2
      Delay -> case Maybe LCtx
earl of
        Just _ -> Severity -> Ctx -> Var -> SDoc -> CoreM Bool
printMessageCheck Severity
SevError Ctx
c Var
v (String -> SDoc
text "cannot delay more than once")
        Nothing -> Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c{current :: LCtx
current = LCtx
forall a. Set a
Set.empty, earlier :: Maybe LCtx
earlier = LCtx -> Maybe LCtx
forall a. a -> Maybe a
Just LCtx
cur} Expr Var
e2
      Adv -> case Maybe LCtx
earl of
        Just er :: LCtx
er -> Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c{earlier :: Maybe LCtx
earlier = Maybe LCtx
forall a. Maybe a
Nothing, current :: LCtx
current = LCtx
er,
                               hidden :: Hidden
hidden = Hidden
hid Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Var -> HiddenReason) -> LCtx -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const HiddenReason
AdvApp) LCtx
cur} Expr Var
e2
        Nothing -> Severity -> Ctx -> Var -> SDoc -> CoreM Bool
printMessageCheck Severity
SevError Ctx
c Var
v (String -> SDoc
text "can only advance under delay")
    _ -> (Bool -> Bool -> Bool) -> CoreM Bool -> CoreM Bool -> CoreM Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c Expr Var
e1)  (Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c Expr Var
e2)
checkExpr c :: Ctx
c (Case e :: Expr Var
e v :: Var
v _ alts :: [Alt Var]
alts) =
    (Bool -> Bool -> Bool) -> CoreM Bool -> CoreM Bool -> CoreM Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c Expr Var
e) (([Bool] -> Bool) -> CoreM [Bool] -> CoreM Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Alt Var -> CoreM Bool) -> [Alt Var] -> CoreM [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (_,vs :: [Var]
vs,e :: Expr Var
e)-> Ctx -> Expr Var -> CoreM Bool
checkExpr ([Var] -> Ctx -> Ctx
addVars [Var]
vs Ctx
c') Expr Var
e) [Alt Var]
alts))
  where c' :: Ctx
c' = [Var] -> Ctx -> Ctx
addVars [Var
v] Ctx
c
checkExpr c :: Ctx
c (Lam v :: Var
v e :: Expr Var
e)
  | Var -> Bool
isTyVar Var
v Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Bool
tcIsLiftedTypeKind (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Type
Type -> Type
typeKind (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
v) = do
      Maybe Var
is <- Type -> CoreM (Maybe Var)
isStableConstr (Var -> Type
varType Var
v)
      let c' :: Ctx
c' = case Maybe Var
is of
            Nothing -> Ctx
c
            Just t :: Var
t -> Ctx
c{stableTypes :: LCtx
stableTypes = Var -> LCtx -> LCtx
forall a. Ord a => a -> Set a -> Set a
Set.insert Var
t (Ctx -> LCtx
stableTypes Ctx
c)}
      Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c' Expr Var
e
  | Bool
otherwise = Ctx -> Expr Var -> CoreM Bool
checkExpr ([Var] -> Ctx -> Ctx
addVars [Var
v] (Ctx -> Ctx
stabilizeLater Ctx
c)) Expr Var
e
checkExpr _ (Type _)  = Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkExpr _ (Lit _)  = Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkExpr _ (Coercion _)  = Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkExpr c :: Ctx
c (Tick (SourceNote span :: RealSrcSpan
span _name :: String
_name) e :: Expr Var
e) =
  Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c{srcLoc :: SrcSpan
srcLoc = RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
span} Expr Var
e
checkExpr c :: Ctx
c (Tick _ e :: Expr Var
e) = Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c Expr Var
e
checkExpr c :: Ctx
c (Cast e :: Expr Var
e _) = Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c Expr Var
e
checkExpr c :: Ctx
c (Let (NonRec v :: Var
v e1 :: Expr Var
e1) e2 :: Expr Var
e2) =
  case Ctx -> Expr Var -> Maybe (Prim, Var)
isPrimExpr Ctx
c Expr Var
e1 of
    Just (p :: Prim
p,_) -> (Ctx -> Expr Var -> CoreM Bool
checkExpr (Ctx
c{primAlias :: Map Var Prim
primAlias = Var -> Prim -> Map Var Prim -> Map Var Prim
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Var
v Prim
p (Ctx -> Map Var Prim
primAlias Ctx
c)}) Expr Var
e2)
    Nothing -> (Bool -> Bool -> Bool) -> CoreM Bool -> CoreM Bool -> CoreM Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (Ctx -> Expr Var -> CoreM Bool
checkExpr Ctx
c Expr Var
e1)  (Ctx -> Expr Var -> CoreM Bool
checkExpr ([Var] -> Ctx -> Ctx
addVars [Var
v] Ctx
c) Expr Var
e2)
checkExpr _ (Let (Rec ([])) _) = Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkExpr c :: Ctx
c (Let (Rec binds :: [(Var, Expr Var)]
binds) e2 :: Expr Var
e2) = do
    [Bool]
r1 <- ((Var, Expr Var) -> CoreM Bool)
-> [(Var, Expr Var)] -> CoreM [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (v :: Var
v,e :: Expr Var
e) -> Ctx -> Expr Var -> CoreM Bool
checkExpr (Var -> Ctx
c' Var
v) Expr Var
e) [(Var, Expr Var)]
binds
    Bool
r2 <- Ctx -> Expr Var -> CoreM Bool
checkExpr ([Var] -> Ctx -> Ctx
addVars [Var]
vs Ctx
c) Expr Var
e2
    let r :: Bool
r = ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
r1 Bool -> Bool -> Bool
&& Bool
r2)  
    Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
r Bool -> Bool -> Bool
&& Ctx -> Bool
stabilized Ctx
c) (Severity -> Ctx -> Var -> SDoc -> CoreM ()
printMessage' Severity
SevWarning Ctx
c ([Var] -> Var
forall a. [a] -> a
head [Var]
vs)
          (String -> SDoc
text "recursive definition nested inside a box or annother recursive definition can cause time leaks"))
    Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
r
  where vs :: [Var]
vs = ((Var, Expr Var) -> Var) -> [(Var, Expr Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Expr Var) -> Var
forall a b. (a, b) -> a
fst [(Var, Expr Var)]
binds
        vs' :: LCtx
vs' = [Var] -> LCtx
forall a. Ord a => [a] -> Set a
Set.fromList [Var]
vs
        ctxHid :: LCtx
ctxHid = LCtx -> (LCtx -> LCtx) -> Maybe LCtx -> LCtx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Ctx -> LCtx
current Ctx
c) (LCtx -> LCtx -> LCtx
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Ctx -> LCtx
current Ctx
c)) (Ctx -> Maybe LCtx
earlier Ctx
c)
        recHid :: LCtx
recHid = LCtx -> (LCtx -> LCtx) -> Maybe LCtx -> LCtx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LCtx
ctxHid (LCtx -> LCtx -> LCtx
forall a. Ord a => Set a -> Set a -> Set a
Set.union LCtx
ctxHid) (Ctx -> Maybe LCtx
recDef Ctx
c)
        c' :: Var -> Ctx
c' v :: Var
v = Ctx
c {current :: LCtx
current = LCtx
forall a. Set a
Set.empty,
                  earlier :: Maybe LCtx
earlier = Maybe LCtx
forall a. Maybe a
Nothing,
                  hidden :: Hidden
hidden =  Ctx -> Hidden
hidden Ctx
c Hidden -> Hidden -> Hidden
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                   ((Var -> HiddenReason) -> LCtx -> Hidden
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (HiddenReason -> Var -> HiddenReason
forall a b. a -> b -> a
const (Var -> HiddenReason
NestedRec Var
v)) LCtx
recHid),
                  recDef :: Maybe LCtx
recDef = LCtx -> Maybe LCtx
forall a. a -> Maybe a
Just (LCtx
vs'),
                  funDef :: Var
funDef = Var
v,
                  stabilized :: Bool
stabilized = Bool
True}
checkExpr c :: Ctx
c (Var v :: Var
v)
  | Type -> Bool
tcIsLiftedTypeKind (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Type
Type -> Type
typeKind (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
v =
    case Ctx -> Var -> Maybe Prim
isPrim Ctx
c Var
v of
      Just p :: Prim
p ->
        case Prim
p of
          Unbox -> Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          _ -> Severity -> SrcSpan -> SDoc -> CoreM ()
printMessage Severity
SevError (Name -> SrcSpan
nameSrcSpan (Var -> Name
varName (Ctx -> Var
funDef Ctx
c))) ("Defining an alias for " SDoc -> SDoc -> SDoc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> " is not allowed") CoreM () -> CoreM Bool -> CoreM Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      _ -> case Ctx -> Var -> Scope
getScope Ctx
c Var
v of
             Hidden reason :: SDoc
reason -> Severity -> Ctx -> Var -> SDoc -> CoreM Bool
printMessageCheck Severity
SevError Ctx
c Var
v SDoc
reason
             Visible -> Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
             ImplUnboxed -> Severity -> Ctx -> Var -> SDoc -> CoreM Bool
printMessageCheck Severity
SevWarning Ctx
c Var
v
                (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
<> String -> SDoc
text " is an external temporal function used under delay, which may cause time leaks")

  | Bool
otherwise = Bool -> CoreM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True



addVars :: [Var] -> Ctx -> Ctx
addVars :: [Var] -> Ctx -> Ctx
addVars v :: [Var]
v c :: Ctx
c = Ctx
c{current :: LCtx
current = [Var] -> LCtx
forall a. Ord a => [a] -> Set a
Set.fromList [Var]
v LCtx -> LCtx -> LCtx
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Ctx -> LCtx
current Ctx
c }