Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Commit 4cfe7cc

Browse files
robrixrobrix
authored
Merge pull request #668 from github/modular-mechanics
Modular abstract interpretation
2 parents 688695c + 128aebc commit 4cfe7cc

File tree

13 files changed

+297
-129
lines changed

13 files changed

+297
-129
lines changed

‎semantic-analysis/.ghci.repl

+4-1
Original file line numberDiff line numberDiff line change
@@ -32,9 +32,12 @@
3232
-- 8.10+
3333
:seti -Wno-missing-safe-haskell-mode
3434
:seti -Wno-prepositive-qualified-module
35+
-- 9.2+
36+
:seti -Wno-missing-kind-signatures
37+
:seti -Wno-missing-signatures
3538

3639
-- We have this one on in the project but not in the REPL to reduce noise
3740
:seti -Wno-type-defaults
3841
:set -Wno-unused-packages
3942

40-
:load Analysis.Concrete Analysis.Exception Analysis.Syntax Analysis.Typecheck
43+
:load Analysis.Analysis.Concrete Analysis.Analysis.Exception Analysis.Syntax Analysis.Analysis.Typecheck

‎semantic-analysis/.gitignore

+2
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
test.json
2+
test.py

‎semantic-analysis/python.tsg

+19-2
Original file line numberDiff line numberDiff line change
@@ -6,9 +6,26 @@
66
attr (@this.node) type = "module"
77
}
88

9-
(identifier) @id
9+
(identifier) @this
1010
{
11-
node @id.node
11+
node @this.node
12+
attr (@this.node) type = "identifier"
13+
var @this.text = (source-text @this)
14+
attr (@this.node) text = (source-text @this)
15+
}
16+
17+
(import_statement) @this
18+
{
19+
node @this.node
20+
attr (@this.node) type = "import"
21+
}
22+
23+
(import_statement name: (dotted_name (identifier) @id)) @this
24+
{
25+
edge @this.node -> @id.node
26+
attr (@id.node) role = "module-name-fragment"
27+
attr (@this.node -> @id.node) index = (named-child-index @id)
28+
attr (@this.node -> @id.node) text = @id.text
1229
}
1330

1431
(string) @this

‎semantic-analysis/script/ghci-flags

+3-2
Original file line numberDiff line numberDiff line change
@@ -64,8 +64,9 @@ function flags {
6464
echo "-Wno-name-shadowing"
6565
echo "-Wno-safe"
6666
echo "-Wno-unsafe"
67-
[[ "$ghc_version" = 8.8.* ]] || [[ "$ghc_version" = 8.10.* ]] && echo "-Wno-missing-deriving-strategies" || true
68-
[[ "$ghc_version" = 8.10.* ]] && echo "-Wno-missing-safe-haskell-mode" && echo "-Wno-prepositive-qualified-module" && echo "-Wno-unused-packages"
67+
[[ "$ghc_version" = 8.8.* ]] || [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-deriving-strategies" || true
68+
[[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-safe-haskell-mode" && echo "-Wno-prepositive-qualified-module" && echo "-Wno-unused-packages" || true
69+
[[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-kind-signatures" || true
6970
}
7071

7172
flags > "$output_file"

‎semantic-analysis/semantic-analysis.cabal

+8-2
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,9 @@ common common
3939
ghc-options:
4040
-Wno-missing-safe-haskell-mode
4141
-Wno-prepositive-qualified-module
42+
if (impl(ghc >= 9.2))
43+
ghc-options:
44+
-Wno-missing-kind-signatures
4245

4346
library
4447
import: common
@@ -49,23 +52,26 @@ library
4952
Analysis.Analysis.Typecheck
5053
Analysis.Blob
5154
Analysis.Carrier.Fail.WithLoc
55+
Analysis.Carrier.Statement.State
5256
Analysis.Carrier.Store.Monovariant
5357
Analysis.Carrier.Store.Precise
5458
Analysis.Data.Snoc
5559
Analysis.Effect.Domain
5660
Analysis.Effect.Env
61+
Analysis.Effect.Statement
5762
Analysis.Effect.Store
5863
Analysis.File
5964
Analysis.FlowInsensitive
6065
Analysis.Functor.Named
66+
Analysis.Module
6167
Analysis.Name
6268
Analysis.Project
6369
Analysis.Reference
6470
Analysis.Syntax
6571
build-depends:
66-
, aeson ^>= 1.4
72+
, aeson >= 1.4 && < 3
6773
, base >= 4.13 && < 5
68-
, bytestring ^>= 0.10.8.2
74+
, bytestring >= 0.10.8.2 && < 0.13
6975
, containers ^>= 0.6
7076
, fused-effects ^>= 1.1
7177
, hashable

‎semantic-analysis/src/Analysis/Analysis/Exception.hs

+44
Original file line numberDiff line numberDiff line change
@@ -1,25 +1,40 @@
1+
{-# LANGUAGE FlexibleContexts #-}
12
{-# LANGUAGE FlexibleInstances #-}
23
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
45
{-# LANGUAGE MultiParamTypeClasses #-}
6+
{-# LANGUAGE RankNTypes #-}
7+
{-# LANGUAGE TypeApplications #-}
58
{-# LANGUAGE TypeOperators #-}
69
{-# LANGUAGE UndecidableInstances #-}
710
module Analysis.Analysis.Exception
811
( Exception(..)
912
, ExcSet(..)
13+
, exceptionTracing
1014
, fromExceptions
1115
, var
1216
, exc
1317
-- * Exception tracing analysis
1418
, ExcC(..)
1519
) where
1620

21+
import qualified Analysis.Carrier.Statement.State as A
22+
import qualified Analysis.Carrier.Store.Monovariant as A
1723
import Analysis.Effect.Domain
24+
import Analysis.Effect.Env (Env)
25+
import Analysis.Effect.Store
26+
import Analysis.File
27+
import Analysis.FlowInsensitive (cacheTerm, convergeTerm)
28+
import Analysis.Module
1829
import Analysis.Name
1930
import Control.Algebra
2031
import Control.Applicative (Alternative (..))
32+
import Control.Effect.Labelled
33+
import Control.Effect.State
2134
import qualified Data.Foldable as Foldable
35+
import Data.Function (fix)
2236
import qualified Data.Set as Set
37+
import qualified Data.Text as Text
2338

2439
-- | Names of exceptions thrown in the guest language and recorded by this analysis.
2540
--
@@ -47,6 +62,35 @@ exc :: Exception -> ExcSet
4762
exc e = ExcSet mempty (Set.singleton e)
4863

4964

65+
exceptionTracing
66+
:: Ord term
67+
=> ( forall sig m
68+
. (Has (Env A.MAddr) sig m, HasLabelled Store (Store A.MAddr ExcSet) sig m, Has (Dom ExcSet) sig m, Has A.Statement sig m)
69+
=> (term -> m ExcSet)
70+
-> (term -> m ExcSet) )
71+
-> [File term]
72+
-> (A.MStore ExcSet, [File (Module ExcSet)])
73+
exceptionTracing eval = A.runFiles (runFile eval)
74+
75+
runFile
76+
:: ( Has (State (A.MStore ExcSet)) sig m
77+
, Ord term )
78+
=> ( forall sig m
79+
. (Has (Env A.MAddr) sig m, HasLabelled Store (Store A.MAddr ExcSet) sig m, Has (Dom ExcSet) sig m, Has A.Statement sig m)
80+
=> (term -> m ExcSet)
81+
-> (term -> m ExcSet) )
82+
-> File term
83+
-> m (File (Module ExcSet))
84+
runFile eval = traverse run where
85+
run
86+
= A.runStatement result
87+
. A.runEnv @ExcSet
88+
. convergeTerm (A.runStore @ExcSet . runExcC . fix (cacheTerm . eval))
89+
result msgs sets = do
90+
let set = Foldable.fold sets
91+
imports = Set.fromList (map (\ (A.Import components) -> name (Text.intercalate (Text.pack ".") (Foldable.toList components))) msgs)
92+
pure (Module (const set) imports mempty (freeVariables set))
93+
5094
newtype ExcC m a = ExcC { runExcC :: m a }
5195
deriving (Alternative, Applicative, Functor, Monad)
5296

‎semantic-analysis/src/Analysis/Carrier/Statement/State.hs

+43
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
{-# LANGUAGE FlexibleInstances #-}
2+
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
{-# LANGUAGE MultiParamTypeClasses #-}
5+
{-# LANGUAGE TypeOperators #-}
6+
{-# LANGUAGE UndecidableInstances #-}
7+
module Analysis.Carrier.Statement.State
8+
( -- * Messages
9+
Message(..)
10+
-- * Statement carrier
11+
, runStatement
12+
, StatementC(..)
13+
-- * Statement effect
14+
, module Analysis.Effect.Statement
15+
) where
16+
17+
import Analysis.Effect.Statement hiding (Import)
18+
import qualified Analysis.Effect.Statement as S
19+
import Control.Algebra
20+
import Control.Carrier.State.Church
21+
import Control.Monad.Fail as Fail
22+
import Data.List.NonEmpty (NonEmpty)
23+
import Data.Text (Text)
24+
25+
-- Messages
26+
27+
newtype Message
28+
= Import (NonEmpty Text)
29+
deriving (Eq, Ord, Show)
30+
31+
32+
-- Statement carrier
33+
34+
runStatement :: ([Message] -> a -> m r) -> StatementC m a -> m r
35+
runStatement k (StatementC m) = runState (k . reverse) [] m
36+
37+
newtype StatementC m a = StatementC { runStatementC :: StateC [Message] m a }
38+
deriving (Applicative, Functor, Monad, Fail.MonadFail)
39+
40+
instance Algebra sig m => Algebra (S.Statement :+: sig) (StatementC m) where
41+
alg hdl sig ctx = case sig of
42+
L (S.Import ns) -> StatementC ((<$ ctx) <$> modify (Import ns:))
43+
R other -> StatementC (alg (runStatementC . hdl) (R other) ctx)

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

+16
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE GADTs #-}
33
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
44
{-# LANGUAGE MultiParamTypeClasses #-}
5+
{-# LANGUAGE RankNTypes #-}
56
{-# LANGUAGE ScopedTypeVariables #-}
67
{-# LANGUAGE TypeApplications #-}
78
{-# LANGUAGE TypeOperators #-}
@@ -19,10 +20,13 @@ module Analysis.Carrier.Store.Monovariant
1920
, EnvC(..)
2021
-- * Env effect
2122
, module Analysis.Effect.Env
23+
-- * Running
24+
, runFiles
2225
) where
2326

2427
import Analysis.Effect.Env
2528
import Analysis.Effect.Store
29+
import Analysis.File (File)
2630
import Analysis.Name
2731
import Control.Algebra
2832
import Control.Carrier.State.Church
@@ -83,3 +87,15 @@ instance Has (State (MStore value)) sig m
8387
pure (MAddr n <$ Map.lookup (MAddr n) store <$ ctx)
8488

8589
R other -> EnvC (alg (runEnv . hdl) other ctx)
90+
91+
92+
-- Running
93+
94+
runFiles
95+
:: (forall sig m . Has (State (MStore value)) sig m => File term -> m (File result))
96+
-> [File term]
97+
-> (MStore value, [File result])
98+
runFiles runFile
99+
= run
100+
. runStoreState
101+
. traverse runFile

‎semantic-analysis/src/Analysis/Effect/Statement.hs

+25
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE KindSignatures #-}
3+
{- |
4+
The @'Statement'@ effect is designed to provide instrumentation for source-level interactions we need visibility into which are nevertheless not (currently) modelled by expressions: e.g. statements, declarations, certain directives, etc.
5+
6+
Currently this is limited to imports, where the value-level semantics are (for many languages) essentially the unit value, but where the effect of bringing an environment and entire subset of the store into scope are essential to track for modular interpretation.
7+
-}
8+
module Analysis.Effect.Statement
9+
( -- * Statement effect
10+
simport
11+
, Statement(..)
12+
) where
13+
14+
import Control.Algebra
15+
import Data.Kind as K
16+
import Data.List.NonEmpty (NonEmpty)
17+
import Data.Text
18+
19+
-- Statement effect
20+
21+
simport :: Has Statement sig m => NonEmpty Text -> m ()
22+
simport ns = send (Import ns)
23+
24+
data Statement (m :: K.Type -> K.Type) k where
25+
Import :: NonEmpty Text -> Statement m ()

‎semantic-analysis/src/Analysis/Module.hs

+27
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
module Analysis.Module
2+
( Module(..)
3+
, ModuleSet(..)
4+
, link
5+
) where
6+
7+
import Analysis.Name
8+
import Data.Foldable (foldl')
9+
import qualified Data.Map as Map
10+
import qualified Data.Set as Set
11+
12+
data Module a = Module
13+
{ body :: Map.Map Name a -> a
14+
, imports :: Set.Set Name
15+
, exports :: Map.Map Name a
16+
, unknown :: Set.Set Name
17+
}
18+
19+
newtype ModuleSet a = ModuleSet { getModuleSet :: Map.Map Name (Module a) }
20+
21+
instance Semigroup (ModuleSet a) where
22+
m1 <> m2 = ModuleSet ((link m2 <$> getModuleSet m1) <> (link m1 <$> getModuleSet m2))
23+
24+
link :: ModuleSet a -> Module a -> Module a
25+
link (ModuleSet ms) m = Module body' (imports m Set.\\ Map.keysSet ms) (exports m) unknown' where
26+
(unknown', body') = foldl' (uncurry resolveSymbolsInModule) (unknown m, body m) (Map.restrictKeys ms (imports m))
27+
resolveSymbolsInModule unknown body m = (unknown Set.\\ Map.keysSet (exports m), body . mappend (Map.restrictKeys (exports m) unknown))

0 commit comments

Comments
 (0)