Keep links in Redirect layer

core/diag/test/Luna/IR/Runner.hs

@@ -4,6 +4,7 @@ module Luna.IR.Runner where
 
 import           Luna.Prelude
 import           Luna.IR
+import           Luna.IR.Layer.Redirect
 import           Luna.Pass        (SubPass, Inputs, Outputs, Preserves, Events)
 import qualified Luna.Pass        as Pass
 import           System.Log
@@ -18,7 +19,7 @@ data TestPass
 type instance Abstract TestPass = TestPass
 type instance Inputs  Net   TestPass = '[AnyExpr, AnyExprLink]
 type instance Outputs Net   TestPass = '[AnyExpr, AnyExprLink]
-type instance Inputs  Layer TestPass = '[AnyExpr // Model, AnyExpr // UID, AnyExpr // Type, AnyExpr // Succs, AnyExprLink // UID, AnyExprLink // Model]
+type instance Inputs  Layer TestPass = '[AnyExpr // Model, AnyExpr // UID, AnyExpr // Type, AnyExpr // Succs, AnyExprLink // UID, AnyExprLink // Model, AnyExpr // Redirect]
 type instance Outputs Layer TestPass = '[AnyExpr // Model, AnyExpr // UID, AnyExpr // Type, AnyExpr // Succs, AnyExprLink // UID, AnyExprLink // Model]
 type instance Inputs  Attr  TestPass = '[]
 type instance Outputs Attr  TestPass = '[]

core/diag/test/Luna/Pass/AccessorFunctionSpec.hs

@@ -53,7 +53,7 @@ type instance Inputs     Event AccessorFunction = '[]
 type instance Outputs    Net   AccessorFunction = '[AnyExpr, AnyExprLink]
 type instance Outputs    Layer AccessorFunction = '[AnyExpr // Model, AnyExprLink // Model, AnyExpr // Succs, AnyExpr // Type, AnyExpr // Redirect]
 type instance Outputs    Attr  AccessorFunction = '[]
-type instance Outputs    Event AccessorFunction = '[New // AnyExpr, New // AnyExprLink, Import // AnyExpr, Import // AnyExprLink]
+type instance Outputs    Event AccessorFunction = '[New // AnyExpr, New // AnyExprLink, Import // AnyExpr, Import // AnyExprLink, Delete // AnyExprLink]
 
 type instance Preserves        AccessorFunction = '[]
 
@@ -88,7 +88,7 @@ importAccessor' = do
                             return $ Left $ MethodNotFound methodName
                         Right (ImportedMethod self body) -> do
                             replaceNode self v'
-                            writeLayer @Redirect (Just $ generalize body) acc
+                            reconnectLayer' @Redirect (Just (unsafeGeneralize body :: Expr Draft)) acc
                             unifyTypes acc body
                             unifyTypes self v'
                             return $ Right (self, body)
@@ -180,18 +180,28 @@ unifies = do
             t <- (,) <$> source l <*> source r
             return $ over each generalize t
 
+snapshotVis :: (MonadIR m, Vis.MonadVis m, MonadRef m) => P.String -> Pass.Pass TestPass m
+snapshotVis = Vis.snapshot
+
 runTest m = do
     imps <- testImports
-    out <- dropLogs $ runRefCache $ evalIRBuilder' $ evalPassManager' $ do
+    out <- withVis $ dropLogs $ runRefCache $ evalIRBuilder' $ evalPassManager' $ do
         runRegs
         addExprEventListener @Redirect initRedirectPass
         attachLayer 20 (getTypeDesc @Redirect) (getTypeDesc @AnyExpr)
         v <- Pass.eval' m
         setAttr (getTypeDesc @Imports) imps
         setAttr (getTypeDesc @CurrentAcc) v
         res    <- Pass.eval' importAccessor'
+        void $ Pass.eval' $ snapshotVis "import"
         c      <- Pass.eval' @AccessorFunction checkCoherence
-        redirect <- Pass.eval' @AccessorFunction $ readLayer @Redirect v
+        (redirect :: Maybe SomeExpr) <- Pass.eval' @AccessorFunction $ do
+            l <- readLayer @Redirect v
+            case l of
+                Just l' -> do
+                    src <- source l'
+                    return $ Just $ generalize src
+                _       -> return Nothing
         allUnifies  <- Pass.eval' @AccessorFunction unifies
         unifiesAndSuccs <- forM res $ \(self, body) -> Pass.eval' @AccessorFunction $ do
             accType  <- readLayer @Type v    >>= source

core/diag/test/Luna/Pass/RemoveGroupedSpec.hs

@@ -129,7 +129,7 @@ desugarsTo test expected = do
         desugared <- Pass.eval' $ removeGrouped $ generalize x
         void $ Pass.eval' $ snapshotVis "desugar"
         orphans   <- Pass.eval' @RemoveGrouped $ checkUnreachableExprs [desugared]
-        coherence <- Pass.eval' @RemoveGrouped checkCoherence
+        coherence <- Pass.eval' @TestPass checkCoherence
         groups    <- Pass.eval' noGroupedLeftBehind
         expected' <- Pass.eval' expected
         result <- Pass.eval' $ areExpressionsIsomorphic @(SubPass RemoveGrouped _) (unsafeRelayout expected') (unsafeRelayout desugared)

core/diag/test/Luna/TestUtils.hs

@@ -3,6 +3,7 @@ module Luna.TestUtils where
 import           Luna.Prelude
 import           Luna.IR
 import           Luna.IR.Function.Argument (Arg (..))
+import           Luna.IR.Layer.Redirect
 import           Control.Monad.Trans.Maybe
 import           Control.Monad.State       as State   hiding (when)
 import           Control.Monad             (guard)
@@ -120,7 +121,7 @@ data CoherenceCheck = CoherenceCheck { _incoherences :: [Incoherence]
 makeLenses ''CoherenceCheck
 
 type MonadCoherenceCheck m = (MonadState CoherenceCheck m, CoherenceCheckCtx m)
-type CoherenceCheckCtx   m = (MonadRef m, Readers Net '[AnyExpr, AnyExprLink] m, Readers Layer '[AnyExpr // Model, AnyExpr // Type, AnyExpr // Succs, AnyExprLink // Model] m)
+type CoherenceCheckCtx   m = (MonadRef m, Readers Net '[AnyExpr, AnyExprLink] m, Readers Layer '[AnyExpr // Model, AnyExpr // Type, AnyExpr // Succs, AnyExprLink // Model, AnyExpr // Redirect] m)
 
 
 checkCoherence :: CoherenceCheckCtx m => m [Incoherence]
@@ -172,8 +173,9 @@ checkIsSuccessor l e = do
 checkIsInput :: MonadCoherenceCheck m => SomeExprLink -> SomeExpr -> m ()
 checkIsInput l e = do
     tp <- readLayer @Type e
+    redirection <- readLayer @Redirect e
     fs <- symbolFields e
-    when (tp /= l && not (elem l fs)) $ reportIncoherence $ Incoherence DanglingTarget e l
+    when (tp /= l && not (elem l fs) && redirection /= Just l) $ reportIncoherence $ Incoherence DanglingTarget e l
 
 checkUnreachableExprs :: (MonadRef m, Reader Layer (AnyExpr // Model) m,
                           Reader Layer (Elem (LINK (Elem (EXPR ANY)) (Elem (EXPR ANY))) // Model) m,

core/src/Luna/IR/Expr/Combinators.hs

@@ -70,3 +70,11 @@ reconnectLayer src tgt = do
     delete old
     link <- link (generalize src) tgt
     writeLayer @l link tgt
+
+reconnectLayer' :: forall l m a b b' t. (MonadRef m, Editors Net '[AnyExprLink] m, Editors Layer '[AnyExpr // l] m, Emitters '[Delete // AnyExprLink, New // AnyExprLink] m, Traversable t, LayerData l (Expr a) ~  t (ExprLink b a), Generalizable' (Expr b') (Expr b))
+                => t (Expr b') -> Expr a -> m ()
+reconnectLayer' srcs tgt = do
+    old  <- readLayer @l tgt
+    mapM delete old
+    links <- forM srcs $ \src -> link (generalize src) tgt
+    writeLayer @l links tgt

core/src/Luna/IR/Layer/Redirect.hs

@@ -8,4 +8,4 @@ import Luna.IR.Internal.IR
 
 
 data Redirect
-type instance LayerData Redirect t = Maybe SomeExpr
+type instance LayerData Redirect t = Maybe (SubLink AnyExpr t)

core/src/Luna/Pass/Desugaring/BlankArguments.hs

@@ -10,6 +10,7 @@ import qualified Luna.Prelude as P
 import Data.TypeDesc
 import qualified Luna.IR.Repr.Vis as Vis
 import Luna.IR.Expr.Combinators
+import Luna.IR.Layer.Redirect
 import Luna.IR.Function hiding (args)
 import Luna.IR.Expr.Layout.ENT hiding (Cons)
 import Luna.IR
@@ -21,7 +22,7 @@ import Control.Monad (foldM)
 data BlankDesugaring
 type instance Abstract   BlankDesugaring = BlankDesugaring
 type instance Inputs     Net   BlankDesugaring = '[AnyExpr, AnyExprLink]
-type instance Inputs     Layer BlankDesugaring = '[AnyExpr // Model, AnyExprLink // Model, AnyExpr // Type, AnyExpr // Succs]
+type instance Inputs     Layer BlankDesugaring = '[AnyExpr // Model, AnyExprLink // Model, AnyExpr // Type, AnyExpr // Succs, AnyExpr // Redirect]
 type instance Inputs     Attr  BlankDesugaring = '[UniqueNameGen, UsedVars]
 type instance Inputs     Event BlankDesugaring = '[]
 

core/src/Luna/Pass/Inference/FunctionResolution.hs

@@ -7,6 +7,7 @@ import Luna.IR.Imports
 import Luna.IR.Module.Definition   as Module
 import Luna.IR
 import Luna.IR.Expr.Combinators
+import Luna.IR.Layer.Redirect
 import Luna.IR.Name                (Name)
 import qualified Data.Map          as Map
 import           Data.Map          (Map)
@@ -35,7 +36,7 @@ data FunctionResolution
 type instance Abstract  FunctionResolution = FunctionResolution
 
 type instance Inputs     Net   FunctionResolution = '[AnyExpr, AnyExprLink]
-type instance Inputs     Layer FunctionResolution = '[AnyExpr // Model, AnyExpr // Type, AnyExpr // Succs, AnyExpr // UID, AnyExprLink // Model, AnyExprLink // UID]
+type instance Inputs     Layer FunctionResolution = '[AnyExpr // Model, AnyExpr // Type, AnyExpr // Succs, AnyExpr // UID, AnyExprLink // Model, AnyExprLink // UID, AnyExpr // Redirect]
 type instance Inputs     Attr  FunctionResolution = '[CurrentVar, Imports]
 type instance Inputs     Event FunctionResolution = '[]