{-| A constructor argument is forced if it appears as pattern variable
in an index of the target.

For instance @x@ is forced in @sing@ and @n@ is forced in @zero@ and @suc@:

@
  data Sing {a}{A : Set a} : A -> Set where
    sing : (x : A) -> Sing x

  data Fin : Nat -> Set where
    zero : (n : Nat) -> Fin (suc n)
    suc  : (n : Nat) (i : Fin n) -> Fin (suc n)
@

At runtime, forced constructor arguments may be erased as they can be
recovered from dot patterns.  For instance,
@
  unsing : {A : Set} (x : A) -> Sing x -> A
  unsing .x (sing x) = x
@
can become
@
  unsing x sing = x
@
and
@
  proj : (n : Nat) (i : Fin n) -> Nat
  proj .(suc n) (zero n) = n
  proj .(suc n) (suc n i) = n
@
becomes
@
  proj (suc n) zero    = n
  proj (suc n) (suc i) = n
@

This module implements the analysis of which constructor arguments are forced. The process of moving
the binding site of forced arguments is implemented in the unifier (see the Solution step of
Agda.TypeChecking.Rules.LHS.Unify.unifyStep).

Forcing is a concept from pattern matching and thus builds on the
concept of equality (I) used there (closed terms, extensional) which is
different from the equality (II) used in conversion checking and the
constraint solver (open terms, intensional).

Up to issue 1441 (Feb 2015), the forcing analysis here relied on the
wrong equality (II), considering type constructors as injective.  This is
unsound for program extraction, but ok if forcing is only used to decide which
arguments to skip during conversion checking.

From now on, forcing uses equality (I) and does not search for forced
variables under type constructors.  This may lose some savings during
conversion checking.  If this turns out to be a problem, the old
forcing could be brought back, using a new modality @Skip@ to indicate
that this is a relevant argument but still can be skipped during
conversion checking as it is forced by equality (II).

-}

module Agda.TypeChecking.Forcing
  ( computeForcingAnnotations,
    isForced,
    nextIsForced ) where

import Data.Bifunctor
import Data.DList (DList)
import qualified Data.DList as DL
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Monoid -- for (<>) in GHC 8.0.2

import Agda.Interaction.Options

import Agda.Syntax.Common
import Agda.Syntax.Internal

import Agda.TypeChecking.Monad
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope

import Agda.Utils.List
import Agda.Utils.Monad
import Agda.Syntax.Common.Pretty (prettyShow)
import Agda.Utils.Size

import Agda.Utils.Impossible

-- | Given the type of a constructor (excluding the parameters),
--   decide which arguments are forced.
--   Precondition: the type is of the form @Γ → D vs@ and the @vs@
--   are in normal form.
computeForcingAnnotations :: QName -> Type -> TCM [IsForced]
computeForcingAnnotations :: QName -> Type -> TCM [IsForced]
computeForcingAnnotations QName
c Type
t =
  TCMT IO Bool -> TCM [IsForced] -> TCM [IsForced] -> TCM [IsForced]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM (PragmaOptions -> Bool
optForcing (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions {-then-}) ([IsForced] -> TCM [IsForced]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []) (TCM [IsForced] -> TCM [IsForced])
-> TCM [IsForced] -> TCM [IsForced]
forall a b. (a -> b) -> a -> b
$ {-else-} do
    -- Andreas, 2015-03-10  Normalization prevents Issue 1454.
    -- t <- normalise t
    -- Andreas, 2015-03-28  Issue 1469: Normalization too costly.
    -- Instantiation also fixes Issue 1454.
    -- Note that normalization of s0 below does not help.
    Type
t <- Type -> TCMT IO Type
forall a (m :: * -> *).
(InstantiateFull a, MonadReduce m) =>
a -> m a
instantiateFull Type
t
    -- Ulf, 2018-01-28 (#2919): We do need to reduce the target type enough to
    -- get to the actual data type.
    -- Also #2947: The type might reduce to a pi type.
    TelV Tele (Dom Type)
tel (El Sort' Term
_ Term
a) <- Type -> TCMT IO (TelV Type)
forall (m :: * -> *). PureTCM m => Type -> m (TelV Type)
telViewPath Type
t
    let vs :: Elims
vs = case Term
a of
          Def QName
_ Elims
us -> Elims
us
          Term
_        -> Elims
forall a. HasCallStack => a
__IMPOSSIBLE__
        n :: Int
n = Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel
        xs :: [(Modality, Nat)]
        xs :: [(Modality, Int)]
xs = DList (Modality, Int) -> [(Modality, Int)]
forall a. DList a -> [a]
DL.toList (DList (Modality, Int) -> [(Modality, Int)])
-> DList (Modality, Int) -> [(Modality, Int)]
forall a b. (a -> b) -> a -> b
$ Elims -> DList (Modality, Int)
forall a. ForcedVariables a => a -> DList (Modality, Int)
forcedVariables Elims
vs
        xs' :: IntMap [Modality]
        xs' :: IntMap [Modality]
xs' = (DList Modality -> [Modality])
-> IntMap (DList Modality) -> IntMap [Modality]
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map DList Modality -> [Modality]
forall a. DList a -> [a]
DL.toList (IntMap (DList Modality) -> IntMap [Modality])
-> IntMap (DList Modality) -> IntMap [Modality]
forall a b. (a -> b) -> a -> b
$ (DList Modality -> DList Modality -> DList Modality)
-> [(Int, DList Modality)] -> IntMap (DList Modality)
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith DList Modality -> DList Modality -> DList Modality
forall a. Semigroup a => a -> a -> a
(<>) ([(Int, DList Modality)] -> IntMap (DList Modality))
-> [(Int, DList Modality)] -> IntMap (DList Modality)
forall a b. (a -> b) -> a -> b
$
              ((Modality, Int) -> (Int, DList Modality))
-> [(Modality, Int)] -> [(Int, DList Modality)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Modality
m, Int
i) -> (Int
i, Modality -> DList Modality
forall a. a -> DList a
DL.singleton Modality
m)) [(Modality, Int)]
xs
        -- #2819: We can only mark an argument as forced if it appears in the
        -- type with a relevance below (i.e. more relevant) than the one of the
        -- constructor argument. Otherwise we can't actually get the value from
        -- the type. Also the argument shouldn't be irrelevant, since in that
        -- case it isn't really forced.
        isForced :: Modality -> Nat -> Bool
        isForced :: Modality -> Int -> Bool
isForced Modality
m Int
i =
               (Modality -> Bool
forall a. LensQuantity a => a -> Bool
hasQuantity0 Modality
m Bool -> Bool -> Bool
|| Modality -> Bool
forall a. LensQuantity a => a -> Bool
noUserQuantity Modality
m)
            Bool -> Bool -> Bool
&& (Modality -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Modality
m Relevance -> Relevance -> Bool
forall a. Eq a => a -> a -> Bool
/= Relevance
Irrelevant)
            Bool -> Bool -> Bool
&& case Int -> IntMap [Modality] -> Maybe [Modality]
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i IntMap [Modality]
xs' of
                 Maybe [Modality]
Nothing -> Bool
False
                 Just [Modality]
ms -> (Modality -> Bool) -> [Modality] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Modality -> Modality -> Bool
`moreUsableModality` Modality
m) [Modality]
ms
        forcedArgs :: [IsForced]
forcedArgs =
          [ if Modality -> Int -> Bool
isForced Modality
m Int
i then IsForced
Forced else IsForced
NotForced
          | (Int
i, Modality
m) <- [Int] -> [Modality] -> [(Int, Modality)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
forall a. Integral a => a -> [a]
downFrom Int
n) ([Modality] -> [(Int, Modality)])
-> [Modality] -> [(Int, Modality)]
forall a b. (a -> b) -> a -> b
$ (Dom (ArgName, Type) -> Modality)
-> [Dom (ArgName, Type)] -> [Modality]
forall a b. (a -> b) -> [a] -> [b]
map Dom (ArgName, Type) -> Modality
forall a. LensModality a => a -> Modality
getModality (Tele (Dom Type) -> [Dom (ArgName, Type)]
forall t. Tele (Dom t) -> [Dom (ArgName, t)]
telToList Tele (Dom Type)
tel)
          ]
    ArgName -> Int -> [ArgName] -> TCMT IO ()
forall a (m :: * -> *).
(ReportS a, MonadDebug m) =>
ArgName -> Int -> a -> m ()
forall (m :: * -> *).
MonadDebug m =>
ArgName -> Int -> [ArgName] -> m ()
reportS ArgName
"tc.force" Int
60
      [ ArgName
"Forcing analysis for " ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ QName -> ArgName
forall a. Pretty a => a -> ArgName
prettyShow QName
c
      , ArgName
"  xs          = " ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ [Int] -> ArgName
forall a. Show a => a -> ArgName
show (((Modality, Int) -> Int) -> [(Modality, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Modality, Int) -> Int
forall a b. (a, b) -> b
snd [(Modality, Int)]
xs)
      , ArgName
"  forcedArgs  = " ArgName -> ArgName -> ArgName
forall a. [a] -> [a] -> [a]
++ [IsForced] -> ArgName
forall a. Show a => a -> ArgName
show [IsForced]
forcedArgs
      ]
    [IsForced] -> TCM [IsForced]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [IsForced]
forcedArgs

-- | Compute the pattern variables of a term or term-like thing.
class ForcedVariables a where
  forcedVariables :: a -> DList (Modality, Nat)

  default forcedVariables ::
    (ForcedVariables b, Foldable t, a ~ t b) =>
    a -> DList (Modality, Nat)
  forcedVariables = (b -> DList (Modality, Int)) -> t b -> DList (Modality, Int)
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap b -> DList (Modality, Int)
forall a. ForcedVariables a => a -> DList (Modality, Int)
forcedVariables

instance ForcedVariables a => ForcedVariables [a] where

-- Note that the 'a' does not include the 'Arg' in 'Apply'.
instance ForcedVariables a => ForcedVariables (Elim' a) where
  forcedVariables :: Elim' a -> DList (Modality, Int)
forcedVariables (Apply Arg a
x) = Arg a -> DList (Modality, Int)
forall a. ForcedVariables a => a -> DList (Modality, Int)
forcedVariables Arg a
x
  forcedVariables IApply{}  = DList (Modality, Int)
forall a. Monoid a => a
mempty  -- No forced variables in path applications
  forcedVariables Proj{}    = DList (Modality, Int)
forall a. Monoid a => a
mempty

instance ForcedVariables a => ForcedVariables (Arg a) where
  forcedVariables :: Arg a -> DList (Modality, Int)
forcedVariables Arg a
x =
    ((Modality, Int) -> (Modality, Int))
-> DList (Modality, Int) -> DList (Modality, Int)
forall a b. (a -> b) -> DList a -> DList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Modality -> Modality) -> (Modality, Int) -> (Modality, Int)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Modality -> Modality -> Modality
composeModality Modality
m)) (a -> DList (Modality, Int)
forall a. ForcedVariables a => a -> DList (Modality, Int)
forcedVariables (Arg a -> a
forall e. Arg e -> e
unArg Arg a
x))
    where m :: Modality
m = Arg a -> Modality
forall a. LensModality a => a -> Modality
getModality Arg a
x

-- | Assumes that the term is in normal form.
instance ForcedVariables Term where
  forcedVariables :: Term -> DList (Modality, Int)
forcedVariables = \case
    Var Int
i []   -> (Modality, Int) -> DList (Modality, Int)
forall a. a -> DList a
DL.singleton (Modality
unitModality, Int
i)
    Con ConHead
_ ConInfo
_ Elims
vs -> Elims -> DList (Modality, Int)
forall a. ForcedVariables a => a -> DList (Modality, Int)
forcedVariables Elims
vs
    Term
_          -> DList (Modality, Int)
forall a. Monoid a => a
mempty

isForced :: IsForced -> Bool
isForced :: IsForced -> Bool
isForced IsForced
Forced    = Bool
True
isForced IsForced
NotForced = Bool
False

nextIsForced :: [IsForced] -> (IsForced, [IsForced])
nextIsForced :: [IsForced] -> (IsForced, [IsForced])
nextIsForced []     = (IsForced
NotForced, [])
nextIsForced (IsForced
f:[IsForced]
fs) = (IsForced
f, [IsForced]
fs)