Parametric modular interpretation

.github/workflows/haskell.yml

@@ -58,7 +58,6 @@ jobs:
         cabal v2-run   --project-file=cabal.project.ci semantic:test
         cabal v2-run   --project-file=cabal.project.ci semantic-tags:test
         cabal v2-run   --project-file=cabal.project.ci semantic-codeql:test
-        cabal v2-run   --project-file=cabal.project.ci semantic-core:test
         cabal v2-run   --project-file=cabal.project.ci semantic-go:test
         cabal v2-run   --project-file=cabal.project.ci semantic-java:test
         cabal v2-run   --project-file=cabal.project.ci semantic-json:test

WORKSPACE

@@ -82,7 +82,6 @@ stack_snapshot(
         "fused-effects",
         "fused-effects-exceptions",
         "fused-effects-readline",
-        "fused-syntax",
         "gauge",
         "generic-lens",
         "generic-monoid",

build/common.bzl

@@ -127,7 +127,6 @@ def semantic_language_library(language, name, srcs, ts_package = "", nodetypes =
             "@stackage//:aeson",
             "@stackage//:algebraic-graphs",
             "@stackage//:fused-effects",
-            "@stackage//:fused-syntax",
             "@stackage//:generic-lens",
             "@stackage//:hashable",
             "@stackage//:lens",

cabal.project

@@ -20,8 +20,3 @@ packages: semantic
           semantic-tags
           semantic-tsx
           semantic-typescript
-
-source-repository-package
-  type: git
-  location: https://github.com/antitypical/fused-syntax.git
-  tag: 4a383d57c8fd7592f54a33f43eb9666314a6e80e

cabal.project.ci

@@ -21,11 +21,6 @@ packages: semantic
           semantic-tsx
           semantic-typescript
 
-source-repository-package
-  type: git
-  location: https://github.com/antitypical/fused-syntax.git
-  tag: 4a383d57c8fd7592f54a33f43eb9666314a6e80e
-
 -- Treat warnings as errors for CI builds
 package semantic
   ghc-options: -Werror

semantic-analysis/BUILD.bazel

@@ -27,16 +27,8 @@ haskell_library(
         "//:transformers",
         "//semantic-source",
         "@stackage//:aeson",
-        "@stackage//:algebraic-graphs",
         "@stackage//:fused-effects",
-        "@stackage//:fused-effects-readline",
-        "@stackage//:fused-syntax",
         "@stackage//:hashable",
-        "@stackage//:haskeline",
         "@stackage//:pathtype",
-        "@stackage//:prettyprinter",
-        "@stackage//:prettyprinter-ansi-terminal",
-        "@stackage//:semilattices",
-        "@stackage//:terminal-size",
     ],
 )

semantic-analysis/semantic-analysis.cabal

@@ -45,30 +45,25 @@ library
   hs-source-dirs: src
   exposed-modules:
     Analysis.Blob
-    Analysis.Carrier.Env.Monovariant
-    Analysis.Carrier.Env.Precise
-    Analysis.Carrier.Heap.Monovariant
-    Analysis.Carrier.Heap.Precise
+    Analysis.Carrier.Fail.WithLoc
+    Analysis.Carrier.Store.Monovariant
+    Analysis.Carrier.Store.Precise
     Analysis.Concrete
     Analysis.Effect.Domain
     Analysis.Effect.Env
-    Analysis.Effect.Heap
+    Analysis.Effect.Store
     Analysis.File
     Analysis.FlowInsensitive
     Analysis.Functor.Named
-    Analysis.ImportGraph
-    Analysis.Intro
     Analysis.Name
     Analysis.Project
+    Analysis.Reference
     Analysis.Typecheck
-    Control.Carrier.Fail.WithLoc
   build-depends:
     , aeson                       ^>= 1.4
-    , algebraic-graphs            ^>= 0.3
     , base                         >= 4.13 && < 5
     , containers                  ^>= 0.6
     , fused-effects               ^>= 1.1
-    , fused-syntax
     , hashable
     , pathtype                    ^>= 0.8.1
     , semantic-source             ^>= 0.1.0.1

semantic-analysis/src/Analysis/Blob.hs

@@ -8,7 +8,8 @@ module Analysis.Blob
   , nullBlob
   ) where
 
-import           Analysis.File
+import           Analysis.File as A
+import           Analysis.Reference as A
 import           Data.Aeson
 import           Source.Language as Language
 import           Source.Source as Source
@@ -34,13 +35,13 @@ instance FromJSON Blob where
 -- The resulting Blob's span is taken from the 'totalSpan' of the source.
 fromSource :: Path.PartClass.AbsRel ar => Path.File ar -> Language -> Source -> Blob
 fromSource filepath language source
-  = Blob source (Analysis.File.File (Path.toAbsRel filepath) (totalSpan source) language)
+  = Blob source (A.File (A.Reference (Path.toAbsRel filepath) (totalSpan source)) language)
 
 blobLanguage :: Blob -> Language
-blobLanguage = Analysis.File.fileBody . blobFile
+blobLanguage = A.fileBody . blobFile
 
 blobPath :: Blob -> Path.AbsRelFile
-blobPath = Analysis.File.filePath . blobFile
+blobPath = A.refPath . A.fileRef . blobFile
 
 -- | Show FilePath for error or json outputs.
 blobFilePath :: Blob -> String

semantic-analysis/src/Analysis/Carrier/Env/Monovariant.hs

@@ -22,7 +22,6 @@ newtype EnvC m a = EnvC { runEnv :: m a }
 instance Algebra sig m
       => Algebra (Env Name :+: sig) (EnvC m) where
   alg hdl sig ctx = case sig of
-    L (Alloc name)  -> pure (name <$ ctx)
     L (Bind _ _ m)  -> hdl (m <$ ctx)
     L (Lookup name) -> pure (Just name <$ ctx)
     R other         -> EnvC (alg (runEnv . hdl) other ctx)

semantic-analysis/src/Analysis/Carrier/Env/Precise.hs

@@ -8,32 +8,25 @@ module Analysis.Carrier.Env.Precise
 ( -- * Env carrier
   EnvC(..)
   -- * Env effect
-, A.alloc
-, A.bind
-, A.lookupEnv
-, A.Env(..)
+, module Analysis.Effect.Env
 ) where
 
-import qualified Analysis.Effect.Env as A
+import           Analysis.Effect.Env
 import           Analysis.Name
 import           Control.Algebra
-import           Control.Effect.Fresh
 import           Control.Effect.Reader
 import qualified Control.Monad.Fail as Fail
 import qualified Data.Map as Map
 
 type Precise = Int
-type Env = Map.Map Name Precise
+type PreciseEnv = Map.Map Name Precise
 
 newtype EnvC m a = EnvC { runEnv :: m a }
   deriving (Applicative, Functor, Monad, Fail.MonadFail)
 
-instance ( Has Fresh sig m
-         , Has (Reader Env) sig m
-         )
-      => Algebra (A.Env Precise :+: sig) (EnvC m) where
+instance Has (Reader PreciseEnv) sig m
+      => Algebra (Env Precise :+: sig) (EnvC m) where
   alg hdl sig ctx = case sig of
-    L (A.Alloc _)          -> (<$ ctx) <$> fresh
-    L (A.Bind name addr m) -> local (Map.insert name addr) (hdl (m <$ ctx))
-    L (A.Lookup name)      -> (<$ ctx) <$> asks (Map.lookup name)
-    R other                -> EnvC (alg (runEnv . hdl) other ctx)
+    L (Bind name addr m) -> local (Map.insert name addr) (hdl (m <$ ctx))
+    L (Lookup name)      -> (<$ ctx) <$> asks (Map.lookup name)
+    R other              -> EnvC (alg (runEnv . hdl) other ctx)

semantic-analysis/src/Analysis/Carrier/Fail/WithLoc.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Analysis.Carrier.Fail.WithLoc
+( -- * Fail carrier
+  runFail
+, FailC(..)
+  -- * Fail effect
+, module Control.Effect.Fail
+) where
+
+import Analysis.Reference
+import Control.Algebra
+import Control.Applicative
+import Control.Carrier.Error.Either
+import Control.Effect.Fail
+import Control.Effect.Reader
+import Prelude hiding (fail)
+
+-- Fail carrier
+
+runFail :: FailC m a -> m (Either (Reference, String) a)
+runFail = runError . runFailC
+
+newtype FailC m a = FailC { runFailC :: ErrorC (Reference, String) m a }
+  deriving (Alternative, Applicative, Functor, Monad)
+
+instance Has (Reader Reference) sig m => MonadFail (FailC m) where
+  fail s = do
+    ref <- ask
+    FailC (throwError (ref :: Reference, s))
+
+instance Has (Reader Reference) sig m => Algebra (Fail :+: sig) (FailC m) where
+  alg _   (L (Fail s)) _   = fail s
+  alg hdl (R other)    ctx = FailC (alg (runFailC . hdl) (R other) ctx)

semantic-analysis/src/Analysis/Carrier/Store/Monovariant.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Analysis.Carrier.Store.Monovariant
+( -- * Store carrier
+  MAddr(..)
+, MStore(..)
+, runStoreState
+, runStore
+, StoreC(..)
+  -- * Store effect
+, module Analysis.Effect.Store
+  -- * Env carrier
+, EnvC(..)
+  -- * Env effect
+, module Analysis.Effect.Env
+) where
+
+import Analysis.Effect.Env
+import Analysis.Effect.Store
+import Analysis.Name
+import Control.Algebra
+import Control.Carrier.State.Church
+import Control.Effect.Labelled
+import Control.Effect.NonDet
+import Control.Monad.Fail as Fail
+import Data.Map as Map
+import Data.Set as Set
+
+newtype MAddr = MAddr Name
+  deriving (Eq, Ord, Show)
+
+newtype MStore value = MStore { getMStore :: Map.Map MAddr (Set.Set value) }
+  deriving (Eq, Ord, Show)
+
+instance Ord value => Semigroup (MStore value) where
+  MStore s1 <> MStore s2 = MStore (Map.unionWith Set.union s1 s2)
+
+instance Ord value => Monoid (MStore value) where
+  mempty = MStore Map.empty
+
+
+-- Store carrier
+
+runStoreState :: Applicative m => StateC (MStore value) m a -> m (MStore value, a)
+runStoreState = runState (curry pure) (MStore Map.empty)
+
+runStore :: Labelled Store (StoreC value) m a -> m a
+runStore = runStoreC . runLabelled
+
+newtype StoreC value m a = StoreC { runStoreC :: m a }
+  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail)
+
+instance (Has (State (MStore value)) sig m, Alternative m, Ord value) => Algebra (Store MAddr value :+: sig) (StoreC value m) where
+  alg hdl sig ctx = StoreC $ do
+    MStore store <- get @(MStore value)
+    case sig of
+      L op        -> case op of
+        Alloc name        -> let addr = MAddr name in addr <$ ctx <$ put (MStore (Map.insertWith Set.union addr Set.empty store))
+        Assign addr value -> ctx <$ put (MStore (Map.insertWith Set.union addr (Set.singleton value) store))
+        Fetch addr        -> foldMapA ((<$ put (MStore store)) . (<$ ctx)) (Map.findWithDefault Set.empty addr store)
+
+      R other -> alg (runStoreC . hdl) other ctx
+
+
+-- Env carrier
+
+newtype EnvC value m a = EnvC { runEnv :: m a }
+  deriving (Applicative, Functor, Monad, Fail.MonadFail)
+
+instance Has (State (MStore value)) sig m
+      => Algebra (Env MAddr :+: sig) (EnvC value m) where
+  alg hdl sig ctx = case sig of
+    L op    -> case op of
+      Bind _ _ m -> hdl (m <$ ctx)
+      Lookup n   -> do
+        MStore store <- get @(MStore value)
+        pure (MAddr n <$ Map.lookup (MAddr n) store <$ ctx)
+
+    R other -> EnvC (alg (runEnv . hdl) other ctx)