🔥 the Analysis env fields.

semantic-analysis/src/Analysis/Analysis.hs

@@ -11,10 +11,7 @@ import GHC.Generics (Generic1)
 --
 -- This is intended to be replaced with a selection of algebraic effects providing these interfaces and carriers providing reusable implementations.
 data Analysis term name address value m = Analysis
-  { alloc     :: name -> m address
+  { deref     :: address -> m (Maybe value)
-  , bind      :: forall a . name -> address -> m a -> m a
-  , lookupEnv :: name -> m (Maybe address)
-  , deref     :: address -> m (Maybe value)
   , assign    :: address -> value -> m ()
   , abstract  :: (term name -> m value) -> name -> term name -> m value
   , apply     :: (term name -> m value) -> value -> value -> m value

semantic-analysis/src/Analysis/Concrete.hs

@@ -130,10 +130,7 @@ concreteAnalysis :: ( Carrier sig m
                     )
                  => Analysis term name Precise (Concrete term name) m
 concreteAnalysis = Analysis{..}
-  where alloc = A.alloc
+  where deref = gets . IntMap.lookup
-        bind = A.bind
-        lookupEnv = A.lookupEnv
-        deref = gets . IntMap.lookup
         assign addr value = modify (IntMap.insert addr value)
         abstract _ name body = do
           path <- ask
@@ -142,7 +139,7 @@ concreteAnalysis = Analysis{..}
           pure (Closure path span name body env)
         apply eval (Closure path span name body env) a = do
           local (const path) . local (const span) $ do
-            addr <- alloc name
+            addr <- A.alloc name
             assign addr a
             local (const (Map.insert name addr env)) (eval body)
         apply _ f _ = fail $ "Cannot coerce " <> show f <> " to function"
@@ -155,7 +152,7 @@ concreteAnalysis = Analysis{..}
         asString v          = fail $ "Cannot coerce " <> show v <> " to String"
         record fields = do
           fields' <- for fields $ \ (name, value) -> do
-            addr <- alloc name
+            addr <- A.alloc name
             assign addr value
             pure (name, addr)
           pure (Record (Map.fromList fields'))

semantic-analysis/src/Analysis/ImportGraph.hs

@@ -96,7 +96,8 @@ runFile eval file = traverse run file
 
 -- FIXME: decompose into a product domain and two atomic domains
 importGraphAnalysis
-  :: ( Alternative m
+  :: forall term name m sig
+  .  ( Alternative m
      , Carrier sig m
      , Member (Env name name) sig
      , Member (Reader Path.AbsRelFile) sig
@@ -110,19 +111,16 @@ importGraphAnalysis
      )
   => Analysis term name name (Value term name) m
 importGraphAnalysis = Analysis{..}
-  where alloc = A.alloc
+  where deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
-        bind = A.bind
-        lookupEnv = A.lookupEnv
-        deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
         assign addr v = modify (Map.insertWith (<>) addr (Set.singleton v))
         abstract _ name body = do
           path <- ask
           span <- ask
           pure (Value (Closure path span name body) mempty)
         apply eval (Value (Closure path span name body) _) a = local (const path) . local (const span) $ do
-          addr <- alloc name
+          addr <- alloc @name @name name
           assign addr a
-          bind name addr (eval body)
+          A.bind name addr (eval body)
         apply _ f _ = fail $ "Cannot coerce " <> show f <> " to function"
         unit = pure mempty
         bool _ = pure mempty
@@ -132,7 +130,7 @@ importGraphAnalysis = Analysis{..}
         asString _ = pure mempty
         record fields = do
           for_ fields $ \ (k, v) -> do
-            addr <- alloc k
+            addr <- A.alloc @name @name k
             assign addr v
           pure (Value Abstract (foldMap (valueGraph . snd) fields))
         _ ... m = pure (Just m)

semantic-analysis/src/Analysis/ScopeGraph.hs

@@ -94,7 +94,8 @@ runFile eval file = traverse run file
             . convergeTerm (Proxy @name) (fix (cacheTerm . eval scopeGraphAnalysis))
 
 scopeGraphAnalysis
-  :: ( Alternative m
+  :: forall term name m sig
+  .  ( Alternative m
      , Carrier sig m
      , Member (Reader Path.AbsRelFile) sig
      , Member (Env name name) sig
@@ -105,10 +106,7 @@ scopeGraphAnalysis
      )
   => Analysis term name name (ScopeGraph name) m
 scopeGraphAnalysis = Analysis{..}
-  where alloc = A.alloc
+  where deref addr = do
-        bind = A.bind
-        lookupEnv = A.lookupEnv
-        deref addr = do
           ref <- askRef
           bindRef <- asks (Map.lookup addr)
           cell <- gets (Map.lookup addr >=> nonEmpty . Set.toList)
@@ -119,9 +117,9 @@ scopeGraphAnalysis = Analysis{..}
           bindRef <- asks (Map.lookup addr)
           modify (Map.insertWith (<>) addr (Set.singleton (extendBinding addr ref bindRef <> v)))
         abstract eval name body = do
-          addr <- alloc name
+          addr <- A.alloc @name @name name
           assign name mempty
-          bind name addr (eval body)
+          A.bind name addr (eval body)
         apply _ f a = pure (f <> a)
         unit = pure mempty
         bool _ = pure mempty

semantic-analysis/src/Analysis/Typecheck.hs

@@ -152,7 +152,8 @@ runFile eval file = traverse run file
           . convergeTerm (Proxy @name) (fix (cacheTerm . eval typecheckingAnalysis))
 
 typecheckingAnalysis
-  :: ( Alternative m
+  :: forall term name m sig
+  .  ( Alternative m
      , Carrier sig m
      , Member (Env name name) sig
      , Member Fresh sig
@@ -162,14 +163,11 @@ typecheckingAnalysis
      )
   => Analysis term name name (Type name) m
 typecheckingAnalysis = Analysis{..}
-  where alloc = A.alloc
+  where deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
-        bind = A.bind
-        lookupEnv = A.lookupEnv
-        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))
         abstract eval name body = do
           -- FIXME: construct the associated scope
-          addr <- alloc name
+          addr <- A.alloc @name @name name
           arg <- meta
           assign addr arg
           ty <- eval body
@@ -187,7 +185,7 @@ typecheckingAnalysis = Analysis{..}
         asString s = unify (Alg String) s $> mempty
         record fields = do
           fields' <- for fields $ \ (k, v) -> do
-            addr <- alloc k
+            addr <- A.alloc @name @name k
             (k, v) <$ assign addr v
           -- FIXME: should records reference types by address instead?
           pure (Alg (Record (Map.fromList fields')))