Skip to content

Commit b0ccf17

Browse files
robrixrobrix
authored
Merge pull request github#685 from github/demo-memo
2 parents 58398f9 + 0f36370 commit b0ccf17

File tree

10 files changed

+295
-39
lines changed

10 files changed

+295
-39
lines changed

‎semantic-analysis/python.tsg

Lines changed: 51 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,10 @@
44
{
55
node @this.node
66
attr (@this.node) type = "module"
7+
attr (@this.node) start-line = (start-row @this)
8+
attr (@this.node) start-col = (start-column @this)
9+
attr (@this.node) end-line = (end-row @this)
10+
attr (@this.node) end-col = (end-column @this)
711
}
812

913
(identifier) @this
@@ -52,13 +56,46 @@
5256
node @this.node
5357
attr (@this.node) type = "print"
5458
edge @this.node -> @arg.node
59+
attr (@this.node) start-line = (start-row @this)
60+
attr (@this.node) start-col = (start-column @this)
61+
attr (@this.node) end-line = (end-row @this)
62+
attr (@this.node) end-col = (end-column @this)
5563
}
5664

5765
(raise_statement (_) @arg) @this
5866
{
5967
node @this.node
6068
attr (@this.node) type = "throw"
6169
edge @this.node -> @arg.node
70+
attr (@this.node) start-line = (start-row @this)
71+
attr (@this.node) start-col = (start-column @this)
72+
attr (@this.node) end-line = (end-row @this)
73+
attr (@this.node) end-col = (end-column @this)
74+
}
75+
76+
(call function: (_) @function arguments: (argument_list (_)* @args)) @this
77+
{
78+
node @this.node
79+
attr (@this.node) function = (source-text @function)
80+
attr (@this.node) type = "call"
81+
for arg in @args {
82+
edge @this.node -> arg.node
83+
}
84+
attr (@this.node) start-line = (start-row @this)
85+
attr (@this.node) start-col = (start-column @this)
86+
attr (@this.node) end-line = (end-row @this)
87+
attr (@this.node) end-col = (end-column @this)
88+
}
89+
90+
(expression_statement (_) @child) @this
91+
{
92+
let @this.node = @child.node
93+
}
94+
95+
(pass_statement) @this
96+
{
97+
node @this.node
98+
attr (@this.node) type = "noop"
6299
}
63100

64101
(block (_)* @children) @this
@@ -67,7 +104,12 @@
67104
attr (@this.node) type = "block"
68105
for child in @children {
69106
edge @this.node -> child.node
107+
attr (@this.node -> child.node) index = (named-child-index child)
70108
}
109+
attr (@this.node) start-line = (start-row @this)
110+
attr (@this.node) start-col = (start-column @this)
111+
attr (@this.node) end-line = (end-row @this)
112+
attr (@this.node) end-col = (end-column @this)
71113
}
72114

73115
(else_clause body: (_) @body) @this
@@ -78,6 +120,10 @@
78120
(if_statement (_)) @this {
79121
node @this.node
80122
attr (@this.node) type = "if"
123+
attr (@this.node) start-line = (start-row @this)
124+
attr (@this.node) start-col = (start-column @this)
125+
attr (@this.node) end-line = (end-row @this)
126+
attr (@this.node) end-col = (end-column @this)
81127
}
82128

83129
(if_statement condition: (_) @cond consequence: (_) @then) @this {
@@ -100,9 +146,14 @@
100146
attr (@this.node) name = (source-text @name)
101147
edge @this.node -> @body.node
102148
attr (@this.node -> @body.node) type = "body"
149+
attr (@this.node) start-line = (start-row @this)
150+
attr (@this.node) start-col = (start-column @this)
151+
attr (@this.node) end-line = (end-row @this)
152+
attr (@this.node) end-col = (end-column @this)
103153
}
104154

105155
(module (_) @child) @this
106156
{
107157
edge @this.node -> @child.node
158+
attr (@this.node -> @child.node) index = (named-child-index @child)
108159
}

‎semantic-analysis/semantic-analysis.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -73,6 +73,7 @@ library
7373
, base >= 4.13 && < 5
7474
, bytestring >= 0.10.8.2 && < 0.13
7575
, containers ^>= 0.6
76+
, filepath
7677
, fused-effects ^>= 1.1
7778
, hashable
7879
, pathtype ^>= 0.8.1

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -172,6 +172,7 @@ instance ( Has (A.Env A.PAddr) sig m
172172
| otherwise -> hdl (e <$ ctx)
173173
_ -> fail "expected Bool"
174174
L (DString s) -> pure (String s <$ ctx)
175+
L (_ :>>> t) -> pure (t <$ ctx)
175176
L (DDie msg) -> fail (show (quote msg))
176177

177178
R other -> DomainC (alg (runDomain . hdl) other ctx)

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

Lines changed: 95 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -3,18 +3,27 @@
33
{-# LANGUAGE GADTs #-}
44
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
55
{-# LANGUAGE MultiParamTypeClasses #-}
6+
{-# LANGUAGE OverloadedStrings #-}
67
{-# LANGUAGE RankNTypes #-}
8+
{-# LANGUAGE TupleSections #-}
79
{-# LANGUAGE TypeApplications #-}
810
{-# LANGUAGE TypeOperators #-}
911
{-# LANGUAGE UndecidableInstances #-}
1012
module Analysis.Analysis.Exception
1113
( Exception(..)
1214
, ExcSet(..)
1315
, exceptionTracing
16+
, exceptionTracingIndependent
1417
, fromExceptions
1518
, var
1619
, exc
20+
, str
1721
, subst
22+
, nullExcSet
23+
, freeVariablesForLine
24+
, exceptionsForLine
25+
, printExcSet
26+
, refLines
1827
-- * Exception tracing analysis
1928
, ExcC(..)
2029
) where
@@ -28,91 +37,158 @@ import Analysis.File
2837
import Analysis.FlowInsensitive (cacheTerm, convergeTerm)
2938
import Analysis.Module
3039
import Analysis.Name
40+
import Analysis.Reference
3141
import Control.Algebra
3242
import Control.Applicative (Alternative (..))
43+
import Control.Carrier.Reader
3344
import Control.Effect.Labelled
3445
import Control.Effect.State
46+
import Control.Monad (unless)
47+
import Data.Foldable (for_)
3548
import qualified Data.Foldable as Foldable
3649
import Data.Function (fix)
50+
import qualified Data.IntSet as IntSet
3751
import qualified Data.Map as Map
3852
import qualified Data.Set as Set
3953
import qualified Data.Text as Text
54+
import qualified Data.Text.IO as Text
55+
import qualified Source.Source as Source
56+
import Source.Span
4057

4158
-- | Names of exceptions thrown in the guest language and recorded by this analysis.
4259
--
4360
-- Not to be confused with exceptions thrown in Haskell itself.
44-
newtype Exception = Exception { exceptionName :: Name }
61+
data Exception = Exception { exceptionName :: Name, exceptionLines :: IntSet.IntSet }
62+
deriving (Eq, Ord, Show)
63+
64+
data FreeVariable = FreeVariable { freeVariableName :: Name, freeVariableLines :: IntSet.IntSet }
4565
deriving (Eq, Ord, Show)
4666

4767
-- | Sets whose elements are each a variable or an exception.
48-
data ExcSet = ExcSet { freeVariables :: Set.Set Name, exceptions :: Set.Set Exception }
68+
data ExcSet = ExcSet { freeVariables :: Set.Set FreeVariable, exceptions :: Set.Set Exception, strings :: Set.Set Text.Text }
4969
deriving (Eq, Ord, Show)
5070

5171
instance Semigroup ExcSet where
52-
ExcSet v1 e1 <> ExcSet v2 e2 = ExcSet (v1 <> v2) (e1 <> e2)
72+
ExcSet v1 e1 s1 <> ExcSet v2 e2 s2 = ExcSet (v1 <> v2) (e1 <> e2) (s1 <> s2)
5373

5474
instance Monoid ExcSet where
55-
mempty = ExcSet mempty mempty
75+
mempty = ExcSet mempty mempty mempty
5676

5777
fromExceptions :: Foldable t => t Exception -> ExcSet
58-
fromExceptions = ExcSet mempty . Set.fromList . Foldable.toList
78+
fromExceptions es = ExcSet mempty (Set.fromList (Foldable.toList es)) mempty
5979

60-
var :: Name -> ExcSet
61-
var v = ExcSet (Set.singleton v) mempty
80+
var :: FreeVariable -> ExcSet
81+
var v = ExcSet (Set.singleton v) mempty mempty
6282

6383
exc :: Exception -> ExcSet
64-
exc e = ExcSet mempty (Set.singleton e)
84+
exc e = ExcSet mempty (Set.singleton e) mempty
85+
86+
str :: Text.Text -> ExcSet
87+
str s = ExcSet mempty mempty (Set.singleton s)
6588

6689
subst :: Name -> ExcSet -> ExcSet -> ExcSet
67-
subst name (ExcSet fvs' es') (ExcSet fvs es) = ExcSet (Set.delete name fvs <> fvs') (es <> es')
90+
-- FIXME: this doesn't handle transitivity at all.
91+
subst name (ExcSet _ es' _) (ExcSet fvs es ss) = ExcSet fvs'' (es <> es'') ss
92+
where
93+
(fvs'', es'') = foldMap combine fvs
94+
combine fv
95+
| freeVariableName fv == name = (mempty, Set.map (\ (Exception n _) -> Exception n (freeVariableLines fv)) es')
96+
| otherwise = (Set.singleton fv, mempty)
97+
98+
99+
nullExcSet :: ExcSet -> Bool
100+
nullExcSet e = null (freeVariables e) && null (exceptions e)
101+
102+
freeVariablesForLine :: Int -> ExcSet -> Set.Set FreeVariable
103+
freeVariablesForLine l e = Set.filter (\ fv -> IntSet.member l (freeVariableLines fv)) (freeVariables e)
104+
105+
exceptionsForLine :: Int -> ExcSet -> Set.Set Exception
106+
exceptionsForLine l e = Set.filter (\ ex -> IntSet.member l (exceptionLines ex)) (exceptions e)
68107

108+
printExcSet :: Source.Source -> ExcSet -> IO ()
109+
printExcSet src e = for_ (zip [0..] (Source.lines src)) $ \ (i, line) -> do
110+
Text.putStr (keywords (Text.dropWhileEnd (== '\n') (Source.toText line)))
111+
let es = exceptionsForLine i e
112+
fvs = freeVariablesForLine i e
113+
unless (null es && null fvs) $ do
114+
Text.putStr " \ESC[30;1m# "
115+
Text.putStr ("{" <> union
116+
( formatFreeVariables fvs
117+
<> formatExceptions es ) <> "}" <> reset)
118+
Text.putStrLn mempty
119+
where
120+
keyword k s = Text.intercalate ("\ESC[34;1m" <> k <> reset) (Text.splitOn k s)
121+
keywords = keyword "raise" . keyword "import" . keyword "def" . keyword "pass"
122+
union = Text.intercalate ", "
123+
formatFreeVariables fvs = map (\ fv -> "?" <> formatName (freeVariableName fv)) (Set.toList fvs)
124+
formatExceptions excs = map (Text.pack . show . formatName . exceptionName) (Set.toList excs)
125+
reset = "\ESC[0m"
126+
127+
refLines :: Reference -> IntSet.IntSet
128+
refLines (Reference _ (Span (Pos startLine _) (Pos endLine _))) = IntSet.fromAscList [startLine..endLine]
69129

70130
exceptionTracing
71131
:: Ord term
72132
=> ( forall sig m
73-
. (Has (Env A.MAddr) sig m, HasLabelled Store (Store A.MAddr ExcSet) sig m, Has (Dom ExcSet) sig m, Has A.Statement sig m)
133+
. (Has (Env A.MAddr) sig m, HasLabelled Store (Store A.MAddr ExcSet) sig m, Has (Dom ExcSet) sig m, Has (Reader Reference) sig m, Has A.Statement sig m)
74134
=> (term -> m ExcSet)
75135
-> (term -> m ExcSet) )
76136
-> [File term]
77137
-> (A.MStore ExcSet, [File (Module ExcSet)])
78-
exceptionTracing eval = A.runFiles (runFile eval)
138+
exceptionTracing eval = run . A.runFiles (runFile eval)
139+
140+
exceptionTracingIndependent
141+
:: Ord term
142+
=> ( forall sig m
143+
. (Has (Env A.MAddr) sig m, HasLabelled Store (Store A.MAddr ExcSet) sig m, Has (Dom ExcSet) sig m, Has (Reader Reference) sig m, Has A.Statement sig m)
144+
=> (term -> m ExcSet)
145+
-> (term -> m ExcSet) )
146+
-> File term
147+
-> (A.MStore ExcSet, File (Module ExcSet))
148+
exceptionTracingIndependent eval = run . A.runStoreState . runFile eval
79149

80150
runFile
81151
:: ( Has (State (A.MStore ExcSet)) sig m
82152
, Ord term )
83153
=> ( forall sig m
84-
. (Has (Env A.MAddr) sig m, HasLabelled Store (Store A.MAddr ExcSet) sig m, Has (Dom ExcSet) sig m, Has A.Statement sig m)
154+
. (Has (Env A.MAddr) sig m, HasLabelled Store (Store A.MAddr ExcSet) sig m, Has (Dom ExcSet) sig m, Has (Reader Reference) sig m, Has A.Statement sig m)
85155
=> (term -> m ExcSet)
86156
-> (term -> m ExcSet) )
87157
-> File term
88158
-> m (File (Module ExcSet))
89-
runFile eval = traverse run where
159+
runFile eval file = traverse run file where
90160
run
91161
= A.runStatement result
92162
. A.runEnv @ExcSet
163+
. runReader (fileRef file)
93164
. convergeTerm (A.runStore @ExcSet . runExcC . fix (cacheTerm . eval))
94165
result msgs sets = do
95166
exports <- gets @(A.MStore ExcSet) (fmap Foldable.fold . Map.mapKeys A.getMAddr . A.getMStore)
96167
let set = Foldable.fold sets
97168
imports = Set.fromList (map extractImport msgs)
98-
pure (Module (Foldable.foldl' (flip (uncurry subst)) set . Map.toList) imports exports (freeVariables set))
99-
extractImport (A.Import components) = name (Text.intercalate (Text.pack ".") (Foldable.toList components))
169+
pure (Module (Foldable.foldl' (flip (uncurry subst)) set . Map.toList) imports exports (Set.map freeVariableName (freeVariables set)))
170+
extractImport (A.Import components) = name (Text.intercalate "." (Foldable.toList components))
100171

101172
newtype ExcC m a = ExcC { runExcC :: m a }
102173
deriving (Alternative, Applicative, Functor, Monad)
103174

104-
instance (Algebra sig m, Alternative m) => Algebra (Dom ExcSet :+: sig) (ExcC m) where
175+
instance (Has (Reader Reference) sig m, Alternative m) => Algebra (Dom ExcSet :+: sig) (ExcC m) where
105176
alg hdl sig ctx = ExcC $ case sig of
106177
L dom -> case dom of
107-
DVar n -> pure $ var n <$ ctx
178+
DVar n -> do
179+
lines <- asks refLines
180+
pure $ var (FreeVariable n lines) <$ ctx
108181
DAbs _ b -> runExcC (hdl (b mempty <$ ctx))
109182
DApp f a -> pure $ f <> Foldable.fold a <$ ctx
110183
DInt _ -> pure nil
111184
DUnit -> pure nil
112185
DBool _ -> pure nil
113186
DIf c t e -> fmap (mappend c) <$> runExcC (hdl (t <$ ctx) <|> hdl (e <$ ctx))
114-
DString _ -> pure nil
115-
DDie e -> pure $ e <> fromExceptions [Exception n | n <- Set.toList (freeVariables e)] <$ ctx
187+
DString s -> pure (str (Text.dropAround (== '"') s) <$ ctx)
188+
t :>>> u -> pure (t <> u <$ ctx)
189+
DDie e -> do
190+
lines <- asks refLines
191+
pure $ e{ strings = mempty } <> fromExceptions [Exception (name n) lines | n <- Set.toList (strings e)] <$ ctx
116192
where
117193
nil = (mempty :: ExcSet) <$ ctx
118194

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -242,6 +242,8 @@ instance ( Alternative m
242242
sequenceA_ (zipWith unify a args)
243243
pure (ret <$ ctx)
244244

245+
L (_ :>>> t) -> pure (t <$ ctx)
246+
245247
L (DDie msg) -> fail (show msg)
246248

247249
R other -> DomainC (alg (runDomain . hdl) other ctx)

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

Lines changed: 13 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ module Analysis.Carrier.Store.Monovariant
2222
, module Analysis.Effect.Env
2323
-- * Running
2424
, runFiles
25+
, runFilesIndependent
2526
) where
2627

2728
import Analysis.Effect.Env
@@ -92,10 +93,18 @@ instance Has (State (MStore value)) sig m
9293
-- Running
9394

9495
runFiles
95-
:: (forall sig m . Has (State (MStore value)) sig m => File term -> m (File result))
96+
:: Algebra sig m
97+
=> (forall sig m . Has (State (MStore value)) sig m => File term -> m (File result))
9698
-> [File term]
97-
-> (MStore value, [File result])
99+
-> m (MStore value, [File result])
98100
runFiles runFile
99-
= run
100-
. runStoreState
101+
= runStoreState
101102
. traverse runFile
103+
104+
runFilesIndependent
105+
:: Algebra sig m
106+
=> (forall sig m . Has (State (MStore value)) sig m => File term -> m (File result))
107+
-> [File term]
108+
-> m [(MStore value, File result)]
109+
runFilesIndependent runFile
110+
= traverse (runStoreState . runFile)

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

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,8 @@ module Analysis.Effect.Domain
2121
, dif
2222
-- * Strings
2323
, dstring
24+
-- * Statements
25+
, (>>>)
2426
-- * Exceptions
2527
, ddie
2628
-- * Domain effect
@@ -79,6 +81,15 @@ dstring :: Has (Dom val) sig m => Text -> m val
7981
dstring = send . DString
8082

8183

84+
-- Statements
85+
86+
-- | Combine the results of adjacent statements.
87+
--
88+
-- This exists to allow e.g. collecting analyses to see the results of earlier statements when processing later ones, without requiring @val@ to be a 'Semigroup'. For example, concrete and typechecking domains would likely ignore the first parameter and return the second, while a domain counting the number of visited instructions would return the sum of both.
89+
(>>>) :: Has (Dom val) sig m => val -> val -> m val
90+
t >>> u = send (t :>>> u)
91+
92+
8293
-- Exceptions
8394

8495
ddie :: Has (Dom val) sig m => val -> m val
@@ -96,4 +107,5 @@ data Dom val m k where
96107
DBool :: Bool -> Dom val m val
97108
DIf :: val -> m val -> m val -> Dom val m val
98109
DString :: Text -> Dom val m val
110+
(:>>>) :: val -> val -> Dom val m val
99111
DDie :: val -> Dom val m val

0 commit comments

Comments
 (0)