Merge pull request #1 from luna/pass/accessorfunction

Import functions used as accessors

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

@@ -0,0 +1,153 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Luna.Pass.AccessorFunctionSpec (spec) where
+
+import           Luna.Pass hiding (compile)
+import qualified Luna.Pass        as Pass
+import           Control.Monad.Raise (MonadException(..), tryAll)
+import qualified Luna.IR.Repr.Vis as Vis
+
+import qualified Data.Set as Set (null)
+import Test.Hspec   (Spec, Expectation, describe, expectationFailure, it, shouldBe, shouldSatisfy, shouldMatchList)
+import Luna.Prelude hiding (String, s, new)
+import qualified Luna.Prelude as P
+import Data.Maybe (isJust)
+import Data.TypeDesc
+import qualified Luna.IR.Repr.Vis as Vis
+import Luna.IR.Expr.Combinators
+import Luna.IR.Imports
+import qualified Luna.IR.Module.Definition   as Module
+import qualified Data.Map          as Map
+import Luna.IR.Function hiding (args)
+import Luna.IR.Function.Definition
+import Luna.IR.Expr.Layout
+import Luna.IR.Layer.Redirect
+import Luna.Pass.Sugar.TH (makePass)
+import Luna.IR.Expr.Layout.ENT hiding (Cons)
+import           Luna.IR.Name                (Name)
+import Luna.IR.Class.Method        (Method(..))
+import Luna.IR.Class.Definition
+import Luna.IR.Runner
+import Luna.Pass.Sugar.Construction
+import Luna.IR
+import Luna.TestUtils
+import Luna.Pass.Inference.MethodResolution
+import Luna.Pass.Inference.FunctionResolution (ImportError(..), lookupSym)
+import System.Log
+import Control.Monad (foldM)
+import Type.Any (AnyType)
+
+
+
+testSuccess :: _ => SubPass TestPass _ _
+testSuccess = do
+    one <- integer (1::Int)
+    int <- string "Int"
+    c <- cons_ @Draft int
+    reconnectLayer @Type c one
+
+    rawAcc "succ" one
+
+testUnknownMethod :: _ => SubPass TestPass _ _
+testUnknownMethod = do
+    one <- integer (1::Int)
+    int <- string "Int"
+    c <- cons_ @Draft int
+    reconnectLayer @Type c one
+
+    rawAcc "isLetter" one
+
+testAmbiguousType :: _ => SubPass TestPass _ _
+testAmbiguousType = do
+    one <- integer (1::Int)
+    int <- string "Int"
+
+    rawAcc "isLetter" one
+
+testImports :: IO Imports
+testImports = do
+    Right succ' <- runGraph $ do
+        self <- strVar "self"
+        one <- integer (1::Int)
+        plus <- strVar "+"
+        a1 <- app plus (arg self)
+        a2 <- app a1 (arg one)
+        c <- compile $ generalize a2
+        return $ Method (generalize self) c
+    let klass = Class Map.empty $ Map.fromList [("succ", succ')]
+    let mod = Module.Module (Map.fromList [("Int", klass)]) Map.empty
+    return $ Imports $ Map.singleton "Stdlib" mod
+
+instance Exception e => MonadException e IO where
+    raise = throwM
+
+unifies :: _ => SubPass AccessorFunction _ [(SomeExpr, SomeExpr)]
+unifies = do
+    es <- exprs
+    maybeUnifies <- mapM (narrowAtom @Unify) es
+    let unifies = catMaybes maybeUnifies
+    forM unifies $ flip match $ \case
+        Unify l r -> 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 <- 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 :: 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
+            bodyType <- readLayer @Type body >>= source
+            let accBodyUnify :: (SomeExpr, SomeExpr)
+                accBodyUnify = (generalize accType, generalize bodyType)
+
+            selfType <- readLayer @Type self >>= source
+            accTargetType <- match v $ \case
+                Acc _ target -> source target >>= readLayer @Type >>= source
+            let accSelfUnify :: (SomeExpr, SomeExpr)
+                accSelfUnify = (generalize selfType, generalize accTargetType)
+            selfSuccs <- readLayer @Succs self
+            return $ (selfSuccs, [accBodyUnify, accSelfUnify])
+
+        return (res, c, redirect, allUnifies, unifiesAndSuccs)
+    return out
+
+spec :: Spec
+spec = describe "accessor function importer" $ do
+    it "imports" $ do
+        (res, coherence, redirect, allUnifies, unifiesAndSuccs) <- runTest testSuccess
+        withRight res $ \(_self, body) -> do
+            redirect `shouldBe` Just body
+        coherence `shouldSatisfy` null
+        withRight unifiesAndSuccs $ \(selfSuccs, unifies) -> do
+            selfSuccs `shouldSatisfy` Set.null
+            unifies `shouldMatchList` allUnifies
+    it "does not import unknown method" $ do
+        (res, coherence, redirect, allUnifies, unifiesAndSuccs) <- runTest testUnknownMethod
+        res `shouldBe` Left (MethodNotFound "isLetter")
+        coherence `shouldSatisfy` null
+    it "does not import when type is ambiguous" $ do
+        (res, coherence, redirect, allUnifies, unifiesAndSuccs) <- runTest testAmbiguousType
+        res `shouldBe` Left AmbiguousType
+        coherence `shouldSatisfy` null

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

@@ -18,6 +18,7 @@ import Luna.Pass.Inference.FunctionResolution
 import qualified Data.Map          as Map
 import Luna.IR.Function.Definition as Function
 import Luna.IR.Function
+import Luna.IR.Imports
 import Luna.IR.Module.Definition   as Module
 import Control.Monad.Raise
 

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/Class/Method.hs

@@ -5,9 +5,8 @@ import Luna.IR
 import Luna.IR.Function.Definition (CompiledFunction)
 import Luna.IR.Name                (Name)
 
-data Method = Method { _self :: AnyExpr
+data Method = Method { _self :: SomeExpr
                      , _body :: CompiledFunction
                      }
 
 makeLenses ''Method
-

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/Function/Definition.hs

@@ -1,5 +1,3 @@
-{-# NoMonomorphismRestriction #-}
-
 module Luna.IR.Function.Definition where
 
 import           Luna.Prelude
@@ -36,9 +34,9 @@ mkTranslationVector size knownIxes = Vector.fromList reixed where
 translateWith :: Vector Int -> (forall t. Elem t -> Elem t)
 translateWith v = idx %~ Vector.unsafeIndex v
 
-importFunction :: forall l m. (MonadIR m, MonadRef m, Editors Net '[AnyExpr, AnyExprLink] m, Emitter (Import // AnyExpr) m, Emitter (Import // AnyExprLink) m)
-               => CompiledFunction -> m SomeExpr
-importFunction (CompiledFunction (unwrap' -> map) r) = do
+importTranslator :: forall l m. (MonadIR m, MonadRef m, Editors Net '[AnyExpr, AnyExprLink] m, Emitter (Import // AnyExpr) m, Emitter (Import // AnyExprLink) m)
+               => CompiledFunction -> m (SomeExpr -> SomeExpr)
+importTranslator (CompiledFunction (unwrap' -> map) _) = do
     ir      <- getIR
     exprNet <- readNet @AnyExpr
     linkNet <- readNet @AnyExprLink
@@ -56,4 +54,9 @@ importFunction (CompiledFunction (unwrap' -> map) r) = do
 
     forM_ importedLinks $ emit . Payload @(Import // AnyExprLink) . (, ElemTranslations exprTranslator linkTranslator) . unsafeGeneralize
     forM_ importedExprs $ emit . Payload @(Import // AnyExpr)     . (, ElemTranslations exprTranslator linkTranslator) . unsafeGeneralize
-    return $ exprTranslator r
+
+    return exprTranslator
+
+importFunction :: forall l m. (MonadIR m, MonadRef m, Editors Net '[AnyExpr, AnyExprLink] m, Emitter (Import // AnyExpr) m, Emitter (Import // AnyExprLink) m)
+               => CompiledFunction -> m SomeExpr
+importFunction cf = importTranslator cf >>= \f -> return $ f (cf ^. root)

core/src/Luna/IR/Imports.hs

@@ -0,0 +1,11 @@
+module Luna.IR.Imports where
+
+import Luna.Prelude
+import Luna.IR.Module.Definition
+import Luna.IR.Name                (Name)
+import           Data.Map          (Map)
+
+
+
+newtype Imports = Imports (Map Name Module)
+makeWrapped ''Imports

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

@@ -0,0 +1,11 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Luna.IR.Layer.Redirect where
+
+import Luna.Prelude
+import Luna.IR.Layer.Class
+import Luna.IR.Internal.IR
+
+
+data Redirect
+type instance LayerData Redirect t = Maybe (SubLink AnyExpr t)

core/src/Luna/IR/Module/Definition.hs

@@ -17,3 +17,6 @@ makeLenses ''Module
 
 lookupFunction :: Module -> Name -> Maybe CompiledFunction
 lookupFunction m n = Map.lookup n $ m ^. functions
+
+lookupClass :: Module -> Name -> Maybe Class
+lookupClass m n = Map.lookup n $ m ^. classes

core/src/Luna/IR/ToRefactor.hs

@@ -18,6 +18,7 @@ import Luna.IR.Layer
 import Luna.IR.Layer.Type
 import Luna.IR.Layer.Model
 import Luna.IR.Layer.UID
+import Luna.IR.Layer.Redirect
 import Luna.IR.Layer.Succs
 import Luna.IR.Expr.Term.Named (HasName, name)
 import Luna.IR.Expr.Format
@@ -260,6 +261,9 @@ init4 = do
     addExprEventListener @Type watchTypeImportPass
 
 
+initRedirect :: Req m '[Editor // Layer // AnyExpr // Redirect] => Listener New (Expr l) m
+initRedirect = listener $ \(t, _) -> (writeLayer @Redirect) Nothing t
+makePass 'initRedirect
 
 
 
@@ -276,6 +280,7 @@ runRegs = do
     init2
     init3
     init4
+    addExprEventListener @Redirect initRedirectPass
 
     attachLayer 0 (getTypeDesc @Model) (getTypeDesc @AnyExpr)
     attachLayer 0 (getTypeDesc @Model) (getTypeDesc @AnyExprLink)
@@ -284,6 +289,7 @@ runRegs = do
     attachLayer 5 (getTypeDesc @Succs) (getTypeDesc @AnyExpr)
 
     attachLayer 10 (getTypeDesc @Type) (getTypeDesc @AnyExpr)
+    attachLayer 10 (getTypeDesc @Redirect) (getTypeDesc @AnyExpr)
 
 
 

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

@@ -3,9 +3,11 @@ module Luna.Pass.Inference.FunctionResolution where
 import Luna.Prelude hiding (String)
 import Luna.IR.Function.Definition as Function
 import Luna.IR.Function
+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)
@@ -17,9 +19,6 @@ import qualified Luna.Pass        as Pass
 
 -- === Definitions === --
 
-newtype Imports = Imports (Map Name Module)
-makeWrapped ''Imports
-
 newtype CurrentVar = CurrentVar (Expr Var)
 makeWrapped ''CurrentVar
 
@@ -37,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 = '[]