diff --git a/semantic-core/src/Analysis/FlowInsensitive.hs b/semantic-core/src/Analysis/FlowInsensitive.hs index b3c6bcaa08..0240d6739f 100644 --- a/semantic-core/src/Analysis/FlowInsensitive.hs +++ b/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 diff --git a/semantic-core/src/Analysis/ImportGraph.hs b/semantic-core/src/Analysis/ImportGraph.hs index 6b3bf28cdc..dbc25fafaf 100644 --- a/semantic-core/src/Analysis/ImportGraph.hs +++ b/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) diff --git a/semantic-core/src/Analysis/ScopeGraph.hs b/semantic-core/src/Analysis/ScopeGraph.hs index 19fa1dcd1c..73686fd396 100644 --- a/semantic-core/src/Analysis/ScopeGraph.hs +++ b/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) diff --git a/semantic-core/src/Analysis/Typecheck.hs b/semantic-core/src/Analysis/Typecheck.hs index 4e66af150e..62f9f2e81a 100644 --- a/semantic-core/src/Analysis/Typecheck.hs +++ b/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)