Merge pull request #211 from github/scope-graphs

Scope graphs

Author: Patrick Thomson

semantic-core/src/Analysis/FlowInsensitive.hs

@@ -68,7 +68,7 @@ cacheTerm eval term = do
       result <$ modify (Cache . Map.insertWith (<>) term (Set.singleton (result :: a)) . unCache)
 
 runHeap :: StateC (Heap address a) m b -> m (Heap address a, b)
-runHeap m = runState (Map.empty) m
+runHeap m = runState Map.empty m
 
 -- | Fold a collection by mapping each element onto an 'Alternative' action.
 foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a

semantic-core/src/Analysis/ImportGraph.hs

@@ -15,7 +15,7 @@ import           Control.Effect.Reader
 import           Control.Effect.State
 import           Control.Monad ((>=>))
 import           Data.File
-import           Data.Foldable (fold)
+import           Data.Foldable (fold, for_)
 import           Data.Function (fix)
 import           Data.List.NonEmpty (nonEmpty)
 import           Data.Loc
@@ -103,7 +103,7 @@ importGraphAnalysis = Analysis{..}
         bind _ _ m = m
         lookupEnv = pure . Just
         deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
-        assign addr ty = modify (Map.insertWith (<>) addr (Set.singleton ty))
+        assign addr v = modify (Map.insertWith (<>) addr (Set.singleton v))
         abstract _ name body = do
           loc <- ask
           pure (Value (Closure loc name body) mempty)
@@ -118,5 +118,9 @@ importGraphAnalysis = Analysis{..}
         string s = pure (Value (String s) mempty)
         asString (Value (String s) _) = pure s
         asString _ = pure mempty
-        record fields = pure (Value Abstract (foldMap (valueGraph . snd) fields))
+        record fields = do
+          for_ fields $ \ (k, v) -> do
+            addr <- alloc k
+            assign addr v
+          pure (Value Abstract (foldMap (valueGraph . snd) fields))
         _ ... m = pure (Just m)

semantic-core/src/Analysis/ScopeGraph.hs

@@ -1,15 +1,130 @@
+{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes, RecordWildCards, TypeApplications, TypeOperators #-}
 module Analysis.ScopeGraph
-( ScopeGraph
-, Entry(..)
+( ScopeGraph(..)
+, Decl(..)
+, scopeGraph
+, scopeGraphAnalysis
 ) where
 
+import           Analysis.Eval
+import           Analysis.FlowInsensitive
+import           Control.Applicative (Alternative (..))
+import           Control.Effect.Carrier
+import           Control.Effect.Fail
+import           Control.Effect.Fresh
+import           Control.Effect.Reader
+import           Control.Effect.State
+import           Control.Monad ((>=>))
+import           Data.File
+import           Data.Foldable (fold)
+import           Data.Function (fix)
+import           Data.List.NonEmpty
 import           Data.Loc
 import qualified Data.Map as Map
+import           Data.Name
+import           Data.Proxy
 import qualified Data.Set as Set
+import           Data.Text (Text)
+import           Data.Traversable (for)
+import           Prelude hiding (fail)
 
-data Entry = Entry
-  { entrySymbol :: String -- FIXME: Text
-  , entryLoc    :: Loc
+data Decl = Decl
+  { declSymbol :: Text
+  , declLoc    :: Loc
   }
+  deriving (Eq, Ord, Show)
 
-type ScopeGraph = Map.Map Entry (Set.Set Entry)
+newtype Ref = Ref Loc
+  deriving (Eq, Ord, Show)
+
+newtype ScopeGraph = ScopeGraph { unScopeGraph :: Map.Map Decl (Set.Set Ref) }
+  deriving (Eq, Ord, Show)
+
+instance Semigroup ScopeGraph where
+  ScopeGraph a <> ScopeGraph b = ScopeGraph (Map.unionWith (<>) a b)
+
+instance Monoid ScopeGraph where
+  mempty = ScopeGraph Map.empty
+
+scopeGraph
+  :: Ord term
+  => (forall sig m
+     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     => Analysis term User ScopeGraph m
+     -> (term -> m ScopeGraph)
+     -> (term -> m ScopeGraph)
+     )
+  -> [File term]
+  -> (Heap User ScopeGraph, [File (Either (Loc, String) ScopeGraph)])
+scopeGraph eval
+  = run
+  . runFresh
+  . runHeap
+  . traverse (runFile eval)
+
+runFile
+  :: ( Carrier sig m
+     , Effect sig
+     , Member Fresh sig
+     , Member (State (Heap User ScopeGraph)) sig
+     , Ord term
+     )
+  => (forall sig m
+     .  (Carrier sig m, Member (Reader Loc) sig, MonadFail m)
+     => Analysis term User ScopeGraph m
+     -> (term -> m ScopeGraph)
+     -> (term -> m ScopeGraph)
+     )
+  -> File term
+  -> m (File (Either (Loc, String) ScopeGraph))
+runFile eval file = traverse run file
+  where run = runReader (fileLoc file)
+            . runReader (Map.empty @User @Loc)
+            . runFailWithLoc
+            . fmap fold
+            . convergeTerm (Proxy @User) (fix (cacheTerm . eval scopeGraphAnalysis))
+
+scopeGraphAnalysis
+  :: ( Alternative m
+     , Carrier sig m
+     , Member (Reader Loc) sig
+     , Member (Reader (Map.Map User Loc)) sig
+     , Member (State (Heap User ScopeGraph)) sig
+     )
+  => Analysis term User ScopeGraph m
+scopeGraphAnalysis = Analysis{..}
+  where alloc = pure
+        bind name _ m = do
+          loc <- ask @Loc
+          local (Map.insert name loc) m
+        lookupEnv = pure . Just
+        deref addr = do
+          ref <- asks Ref
+          bindLoc <- asks (Map.lookup addr)
+          cell <- gets (Map.lookup addr >=> nonEmpty . Set.toList)
+          let extending = mappend (extendBinding addr ref bindLoc)
+          maybe (pure Nothing) (foldMapA (pure . Just . extending)) cell
+        assign addr v = do
+          ref <- asks Ref
+          bindLoc <- asks (Map.lookup addr)
+          modify (Map.insertWith (<>) addr (Set.singleton (extendBinding addr ref bindLoc <> v)))
+        abstract eval name body = do
+          addr <- alloc name
+          assign name (mempty @ScopeGraph)
+          bind name addr (eval body)
+        apply _ f a = pure (f <> a)
+        unit = pure mempty
+        bool _ = pure mempty
+        asBool _ = pure True <|> pure False
+        string _ = pure mempty
+        asString _ = pure mempty
+        record fields = do
+          fields' <- for fields $ \ (k, v) -> do
+            addr <- alloc k
+            loc <- ask @Loc
+            let v' = ScopeGraph (Map.singleton (Decl k loc) mempty) <> v
+            (k, v') <$ assign addr v'
+          pure (foldMap snd fields')
+        _ ... m = pure (Just m)
+
+        extendBinding addr ref bindLoc = ScopeGraph (maybe Map.empty (\ bindLoc -> Map.singleton (Decl addr bindLoc) (Set.singleton ref)) bindLoc)

semantic-core/src/Analysis/Typecheck.hs

@@ -33,6 +33,7 @@ import           Data.Scope
 import           Data.Semigroup (Last (..))
 import qualified Data.Set as Set
 import           Data.Term
+import           Data.Traversable (for)
 import           Data.Void
 import           GHC.Generics (Generic1)
 import           Prelude hiding (fail)
@@ -175,7 +176,12 @@ typecheckingAnalysis = Analysis{..}
         asBool b = unify (Term Bool) b >> pure True <|> pure False
         string _ = pure (Term String)
         asString s = unify (Term String) s $> mempty
-        record fields = pure (Term (Record (Map.fromList fields)))
+        record fields = do
+          fields' <- for fields $ \ (k, v) -> do
+            addr <- alloc k
+            (k, v) <$ assign addr v
+          -- FIXME: should records reference types by address instead?
+          pure (Term (Record (Map.fromList fields')))
         _ ... m = pure (Just m)