module Agda.TypeChecking.Monad.Open
( makeOpen
, getOpen
, tryGetOpen
, isClosed
) where
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import Agda.Syntax.Internal
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.State (currentModuleNameHash)
import {-# SOURCE #-} Agda.TypeChecking.Monad.Context
import Agda.Utils.Lens
import Agda.Utils.Maybe
makeOpen :: (ReadTCState m, MonadTCEnv m) => a -> m (Open a)
makeOpen :: forall (m :: * -> *) a.
(ReadTCState m, MonadTCEnv m) =>
a -> m (Open a)
makeOpen a
x = do
CheckpointId
cp <- forall (m :: * -> *) a. MonadTCEnv m => Lens' a TCEnv -> m a
viewTC Lens' CheckpointId TCEnv
eCurrentCheckpoint
Map CheckpointId Substitution
env <- forall (m :: * -> *) a. MonadTCEnv m => Lens' a TCEnv -> m a
viewTC Lens' (Map CheckpointId Substitution) TCEnv
eCheckpoints
ModuleNameHash
m <- forall (m :: * -> *). ReadTCState m => m ModuleNameHash
currentModuleNameHash
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
CheckpointId
-> Map CheckpointId Substitution -> ModuleNameHash -> a -> Open a
OpenThing CheckpointId
cp Map CheckpointId Substitution
env ModuleNameHash
m a
x
getOpen :: (TermSubst a, MonadTCEnv m) => Open a -> m a
getOpen :: forall a (m :: * -> *).
(TermSubst a, MonadTCEnv m) =>
Open a -> m a
getOpen (OpenThing CheckpointId
cp Map CheckpointId Substitution
_ ModuleNameHash
_ a
x) = do
Substitution
sub <- forall (tcm :: * -> *).
MonadTCEnv tcm =>
CheckpointId -> tcm Substitution
checkpointSubstitution CheckpointId
cp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
sub a
x
tryGetOpen :: (TermSubst a, ReadTCState m, MonadTCEnv m) => (Substitution -> a -> Maybe a) -> Open a -> m (Maybe a)
tryGetOpen :: forall a (m :: * -> *).
(TermSubst a, ReadTCState m, MonadTCEnv m) =>
(Substitution -> a -> Maybe a) -> Open a -> m (Maybe a)
tryGetOpen Substitution -> a -> Maybe a
extract Open a
open = do
OpenThing CheckpointId
cp Map CheckpointId Substitution
env ModuleNameHash
_ a
x <- forall {m :: * -> *} {a}. ReadTCState m => Open a -> m (Open a)
restrict Open a
open
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
(forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` a
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Alternative f => Maybe a -> f a
liftMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadTCEnv m => Lens' a TCEnv -> m a
viewTC (Lens' (Map CheckpointId Substitution) TCEnv
eCheckpoints forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => k -> Lens' (Maybe v) (Map k v)
key CheckpointId
cp))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
Map CheckpointId Substitution
curEnv <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadTCEnv m => Lens' a TCEnv -> m a
viewTC Lens' (Map CheckpointId Substitution) TCEnv
eCheckpoints
CheckpointId
parent <- forall {a} {f :: * -> *} {a} {b}.
(Ord a, Alternative f, Monad f) =>
Map a a -> Map a b -> f a
findParent Map CheckpointId Substitution
env Map CheckpointId Substitution
curEnv
let Just Substitution
subToOld = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CheckpointId
parent Map CheckpointId Substitution
env
Just Substitution
subToCur = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CheckpointId
parent Map CheckpointId Substitution
curEnv
(forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
subToCur) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => Maybe a -> f a
liftMaybe (Substitution -> a -> Maybe a
extract Substitution
subToOld a
x)
where
restrict :: Open a -> m (Open a)
restrict o :: Open a
o@(OpenThing CheckpointId
cp Map CheckpointId Substitution
env ModuleNameHash
m a
x) = do
ModuleNameHash
cur <- forall (m :: * -> *). ReadTCState m => m ModuleNameHash
currentModuleNameHash
if ModuleNameHash
m forall a. Eq a => a -> a -> Bool
== ModuleNameHash
cur then forall (m :: * -> *) a. Monad m => a -> m a
return Open a
o
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
CheckpointId
-> Map CheckpointId Substitution -> ModuleNameHash -> a -> Open a
OpenThing (-CheckpointId
1) (forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\ CheckpointId
k Substitution
_ -> CheckpointId
k forall a. Eq a => a -> a -> Bool
== CheckpointId
0) Map CheckpointId Substitution
env) ModuleNameHash
m a
x
findParent :: Map a a -> Map a b -> f a
findParent Map a a
m1 Map a b
m2 = case forall k a. Map k a -> Maybe (k, a)
Map.lookupMax (forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map a a
m1 Map a b
m2) of
Maybe (a, a)
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty
Just (a
max, a
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
max
isClosed :: Open a -> Bool
isClosed :: forall a. Open a -> Bool
isClosed (OpenThing CheckpointId
cp Map CheckpointId Substitution
_ ModuleNameHash
_ a
_) = CheckpointId
cp forall a. Eq a => a -> a -> Bool
== CheckpointId
0