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

Commit 3617455

Browse files
robrixrobrix
authored
Merge pull request #202 from github/gen-x
🔥 Naming, Name, & Gensym
2 parents 9199555 + ceb4791 commit 3617455

7 files changed

Lines changed: 78 additions & 160 deletions

File tree

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

Lines changed: 10 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -22,26 +22,25 @@ import Control.Effect.State
2222
import Control.Monad ((<=<), guard)
2323
import qualified Data.Core as Core
2424
import Data.File
25-
import Data.Foldable (foldl')
2625
import Data.Function (fix)
2726
import qualified Data.IntMap as IntMap
2827
import qualified Data.IntSet as IntSet
2928
import Data.Loc
3029
import qualified Data.Map as Map
3130
import Data.Monoid (Alt(..))
32-
import Data.Name hiding (fresh)
31+
import Data.Name
3332
import Data.Term
3433
import Data.Text (Text, pack)
3534
import Prelude hiding (fail)
3635

3736
type Precise = Int
38-
type Env = Map.Map Name Precise
37+
type Env = Map.Map User Precise
3938

4039
newtype FrameId = FrameId { unFrameId :: Precise }
4140
deriving (Eq, Ord, Show)
4241

4342
data Concrete
44-
= Closure Loc Name (Term Core.Core Name) Precise
43+
= Closure Loc User (Term Core.Core User) Precise
4544
| Unit
4645
| Bool Bool
4746
| String Text
@@ -65,22 +64,20 @@ type Heap = IntMap.IntMap Concrete
6564
--
6665
-- >>> map fileBody (snd (concrete [File (Loc "bool" emptySpan) (Core.bool True)]))
6766
-- [Right (Bool True)]
68-
concrete :: [File (Term Core.Core Name)] -> (Heap, [File (Either (Loc, String) Concrete)])
67+
concrete :: [File (Term Core.Core User)] -> (Heap, [File (Either (Loc, String) Concrete)])
6968
concrete
7069
= run
7170
. runFresh
72-
. runNaming
7371
. runHeap
7472
. traverse runFile
7573

7674
runFile :: ( Carrier sig m
7775
, Effect sig
7876
, Member Fresh sig
79-
, Member Naming sig
8077
, Member (Reader FrameId) sig
8178
, Member (State Heap) sig
8279
)
83-
=> File (Term Core.Core Name)
80+
=> File (Term Core.Core User)
8481
-> m (File (Either (Loc, String) Concrete))
8582
runFile file = traverse run file
8683
where run = runReader (fileLoc file)
@@ -143,7 +140,7 @@ concreteAnalysis = Analysis{..}
143140
assign addr (Obj (f frame))
144141

145142

146-
lookupConcrete :: Heap -> Name -> Concrete -> Maybe Precise
143+
lookupConcrete :: Heap -> User -> Concrete -> Maybe Precise
147144
lookupConcrete heap name = run . evalState IntSet.empty . runNonDet . inConcrete
148145
where -- look up the name in a concrete value
149146
inConcrete = inFrame <=< maybeA . objectFrame
@@ -171,7 +168,7 @@ runHeap m = do
171168
-- > λ let (heap, res) = concrete [ruby]
172169
-- > λ writeFile "/Users/rob/Desktop/heap.dot" (export (addressStyle heap) (heapAddressGraph heap))
173170
-- > λ :!dot -Tsvg < ~/Desktop/heap.dot > ~/Desktop/heap.svg
174-
heapGraph :: (Precise -> Concrete -> a) -> (Either Core.Edge Name -> Precise -> G.Graph a) -> Heap -> G.Graph a
171+
heapGraph :: (Precise -> Concrete -> a) -> (Either Core.Edge User -> Precise -> G.Graph a) -> Heap -> G.Graph a
175172
heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
176173
where graph k v rest = (G.vertex (vertex k v) `G.connect` outgoing v) `G.overlay` rest
177174
outgoing = \case
@@ -192,23 +189,21 @@ heapAddressGraph = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,)
192189
addressStyle :: Heap -> G.Style (EdgeType, Precise) Text
193190
addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
194191
where vertex (_, addr) = pack (show addr) <> " = " <> maybe "?" fromConcrete (IntMap.lookup addr heap)
195-
edgeAttributes _ (Slot name, _) = ["label" G.:= fromName name]
192+
edgeAttributes _ (Slot name, _) = ["label" G.:= name]
196193
edgeAttributes _ (Edge Core.Import, _) = ["color" G.:= "blue"]
197194
edgeAttributes _ (Edge Core.Lexical, _) = ["color" G.:= "green"]
198195
edgeAttributes _ _ = []
199196
fromConcrete = \case
200197
Unit -> "()"
201198
Bool b -> pack $ show b
202199
String s -> pack $ show s
203-
Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> fromName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
200+
Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
204201
Obj _ -> "{}"
205202
showPos (Pos l c) = pack (show l) <> ":" <> pack (show c)
206-
fromName (User s) = s
207-
fromName (Gen (Gensym ss i)) = foldl' (\ ss s -> ss <> "." <> s) (pack (show i)) ss
208203

209204
data EdgeType
210205
= Edge Core.Edge
211-
| Slot Name
206+
| Slot User
212207
| Value Concrete
213208
deriving (Eq, Ord, Show)
214209

‎semantic-core/src/Analysis/Eval.hs‎

Lines changed: 23 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -20,20 +20,25 @@ import Data.Functor
2020
import Data.Loc
2121
import Data.Maybe (fromJust)
2222
import Data.Name
23+
import Data.Scope
2324
import Data.Term
2425
import Data.Text (Text)
2526
import GHC.Stack
2627
import Prelude hiding (fail)
2728

28-
eval :: (Carrier sig m, Member Naming sig, Member (Reader Loc) sig, MonadFail m) => Analysis address value m -> (Term Core Name -> m value) -> Term Core Name -> m value
29+
eval :: ( Carrier sig m
30+
, Member (Reader Loc) sig
31+
, MonadFail m
32+
)
33+
=> Analysis address value m
34+
-> (Term Core User -> m value)
35+
-> (Term Core User -> m value)
2936
eval Analysis{..} eval = \case
3037
Var n -> lookupEnv' n >>= deref' n
3138
Term c -> case c of
32-
Let n -> alloc (User n) >>= bind (User n) >> unit
39+
Let n -> alloc n >>= bind n >> unit
3340
a :>> b -> eval a >> eval b
34-
Lam _ b -> do
35-
n <- Gen <$> fresh
36-
abstract eval n (instantiate (const (pure n)) b)
41+
Lam (Ignored n) b -> abstract eval n (instantiate1 (pure n) b)
3742
f :$ a -> do
3843
f' <- eval f
3944
a' <- eval a
@@ -66,8 +71,8 @@ eval Analysis{..} eval = \case
6671
Var n -> lookupEnv' n
6772
Term c -> case c of
6873
Let n -> do
69-
addr <- alloc (User n)
70-
addr <$ bind (User n) addr
74+
addr <- alloc n
75+
addr <$ bind n addr
7176
If c t e -> do
7277
c' <- eval c >>= asBool
7378
if c' then ref t else ref e
@@ -109,8 +114,11 @@ prog4 = fromBody $ block
109114
prog5 :: File (Term Core User)
110115
prog5 = fromBody $ block
111116
[ let' "mkPoint" .= lam' "_x" (lam' "_y" (block
112-
[ let' "x" .= pure "_x"
113-
, let' "y" .= pure "_y"]))
117+
[ let' "this" .= Core.frame
118+
, pure "this" Core.... let' "x" .= pure "_x"
119+
, pure "this" Core.... let' "y" .= pure "_y"
120+
, pure "this"
121+
]))
114122
, let' "point" .= pure "mkPoint" $$ Core.bool True $$ Core.bool False
115123
, pure "point" Core.... pure "x"
116124
, pure "point" Core.... pure "y" .= pure "point" Core.... pure "x"
@@ -120,9 +128,7 @@ prog6 :: [File (Term Core User)]
120128
prog6 =
121129
[ File (Loc "dep" (locSpan (fromJust here))) $ block
122130
[ let' "dep" .= Core.frame
123-
, pure "dep" Core.... block
124-
[ let' "var" .= Core.bool True
125-
]
131+
, pure "dep" Core.... (let' "var" .= Core.bool True)
126132
]
127133
, File (Loc "main" (locSpan (fromJust here))) $ block
128134
[ load (Core.string "dep")
@@ -203,13 +209,13 @@ ruby = fromBody . ann . block $
203209

204210

205211
data Analysis address value m = Analysis
206-
{ alloc :: Name -> m address
207-
, bind :: Name -> address -> m ()
208-
, lookupEnv :: Name -> m (Maybe address)
212+
{ alloc :: User -> m address
213+
, bind :: User -> address -> m ()
214+
, lookupEnv :: User -> m (Maybe address)
209215
, deref :: address -> m (Maybe value)
210216
, assign :: address -> value -> m ()
211-
, abstract :: (Term Core Name -> m value) -> Name -> Term Core Name -> m value
212-
, apply :: (Term Core Name -> m value) -> value -> value -> m value
217+
, abstract :: (Term Core User -> m value) -> User -> Term Core User -> m value
218+
, apply :: (Term Core User -> m value) -> value -> value -> m value
213219
, unit :: m value
214220
, bool :: Bool -> m value
215221
, asBool :: value -> m Bool

‎semantic-core/src/Analysis/ImportGraph.hs‎

Lines changed: 10 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,6 @@ import Data.Loc
2222
import qualified Data.Map as Map
2323
import Data.Name
2424
import qualified Data.Set as Set
25-
import Data.Stack
2625
import Data.Term
2726
import Data.Text (Text)
2827
import Prelude hiding (fail)
@@ -42,29 +41,27 @@ instance Monoid Value where
4241
mempty = Value Abstract mempty
4342

4443
data Semi
45-
= Closure Loc Name (Term Core.Core Name) Name
44+
= Closure Loc User (Term Core.Core User) User
4645
-- FIXME: Bound String values.
4746
| String Text
4847
| Abstract
4948
deriving (Eq, Ord, Show)
5049

5150

52-
importGraph :: [File (Term Core.Core Name)] -> (Heap Name Value, [File (Either (Loc, String) Value)])
51+
importGraph :: [File (Term Core.Core User)] -> (Heap User Value, [File (Either (Loc, String) Value)])
5352
importGraph
5453
= run
5554
. runFresh
56-
. runNaming
57-
. runHeap (Gen (Gensym (Nil :> "root") 0))
55+
. runHeap "__semantic_root"
5856
. traverse runFile
5957

6058
runFile :: ( Carrier sig m
6159
, Effect sig
6260
, Member Fresh sig
63-
, Member Naming sig
64-
, Member (Reader (FrameId Name)) sig
65-
, Member (State (Heap Name Value)) sig
61+
, Member (Reader (FrameId User)) sig
62+
, Member (State (Heap User Value)) sig
6663
)
67-
=> File (Term Core.Core Name)
64+
=> File (Term Core.Core User)
6865
-> m (File (Either (Loc, String) Value))
6966
runFile file = traverse run file
7067
where run = runReader (fileLoc file)
@@ -75,12 +72,12 @@ runFile file = traverse run file
7572
-- FIXME: decompose into a product domain and two atomic domains
7673
importGraphAnalysis :: ( Alternative m
7774
, Carrier sig m
78-
, Member (Reader (FrameId Name)) sig
75+
, Member (Reader (FrameId User)) sig
7976
, Member (Reader Loc) sig
80-
, Member (State (Heap Name Value)) sig
77+
, Member (State (Heap User Value)) sig
8178
, MonadFail m
8279
)
83-
=> Analysis Name Value m
80+
=> Analysis User Value m
8481
importGraphAnalysis = Analysis{..}
8582
where alloc = pure
8683
bind _ _ = pure ()
@@ -104,7 +101,7 @@ importGraphAnalysis = Analysis{..}
104101
asString (Value (String s) _) = pure s
105102
asString _ = pure mempty
106103
frame = pure mempty
107-
edge Core.Import (User to) = do -- FIXME: figure out some other way to do this
104+
edge Core.Import to = do -- FIXME: figure out some other way to do this
108105
Loc{locPath=from} <- ask
109106
() <$ pure (Value Abstract (Map.singleton from (Set.singleton to)))
110107
edge _ _ = pure ()

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

Lines changed: 14 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,6 @@ import Data.Maybe (fromJust, fromMaybe)
3131
import Data.Name as Name
3232
import Data.Scope
3333
import qualified Data.Set as Set
34-
import Data.Stack
3534
import Data.Term
3635
import Data.Void
3736
import GHC.Generics (Generic1)
@@ -83,28 +82,26 @@ generalize :: Term Monotype Meta -> Term (Polytype :+: Monotype) Void
8382
generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm R ty)))
8483

8584

86-
typecheckingFlowInsensitive :: [File (Term Core.Core Name)] -> (Heap Name (Term Monotype Meta), [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))])
85+
typecheckingFlowInsensitive :: [File (Term Core.Core User)] -> (Heap User (Term Monotype Meta), [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))])
8786
typecheckingFlowInsensitive
8887
= run
8988
. runFresh
90-
. runNaming
91-
. runHeap (Gen (Gensym (Nil :> "root") 0))
89+
. runHeap "__semantic_root"
9290
. fmap (fmap (fmap (fmap generalize)))
9391
. traverse runFile
9492

9593
runFile :: ( Carrier sig m
9694
, Effect sig
9795
, Member Fresh sig
98-
, Member Naming sig
99-
, Member (State (Heap Name (Term Monotype Meta))) sig
96+
, Member (State (Heap User (Term Monotype Meta))) sig
10097
)
101-
=> File (Term Core.Core Name)
98+
=> File (Term Core.Core User)
10299
-> m (File (Either (Loc, String) (Term Monotype Meta)))
103100
runFile file = traverse run file
104101
where run
105102
= (\ m -> do
106103
(subst, t) <- m
107-
modify @(Heap Name (Term Monotype Meta)) (fmap (Set.map (substAll subst)))
104+
modify @(Heap User (Term Monotype Meta)) (fmap (Set.map (substAll subst)))
108105
pure (substAll subst <$> t))
109106
. runState (mempty :: Substitution)
110107
. runReader (fileLoc file)
@@ -119,7 +116,15 @@ runFile file = traverse run file
119116
v <$ for_ bs (unify v))
120117
. convergeTerm (fix (cacheTerm . eval typecheckingAnalysis))
121118

122-
typecheckingAnalysis :: (Alternative m, Carrier sig m, Member Fresh sig, Member (State (Set.Set Constraint)) sig, Member (State (Heap Name (Term Monotype Meta))) sig, MonadFail m) => Analysis Name (Term Monotype Meta) m
119+
typecheckingAnalysis
120+
:: ( Alternative m
121+
, Carrier sig m
122+
, Member Fresh sig
123+
, Member (State (Set.Set Constraint)) sig
124+
, Member (State (Heap User (Term Monotype Meta))) sig
125+
, MonadFail m
126+
)
127+
=> Analysis User (Term Monotype Meta) m
123128
typecheckingAnalysis = Analysis{..}
124129
where alloc = pure
125130
bind _ _ = pure ()

‎semantic-core/src/Data/Core.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -71,7 +71,7 @@ data Core f a
7171
deriving (Foldable, Functor, Generic1, Traversable)
7272

7373
infixr 1 :>>
74-
infixl 2 :$
74+
infixl 9 :$
7575
infixl 4 :.
7676
infix 3 :=
7777

@@ -139,7 +139,7 @@ unseqs = go
139139
($$) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a
140140
f $$ a = send (f :$ a)
141141

142-
infixl 2 $$
142+
infixl 9 $$
143143

144144
-- | Application of a function to a sequence of arguments.
145145
($$*) :: (Foldable t, Carrier sig m, Member Core sig) => m a -> t (m a) -> m a

0 commit comments

Comments
 (0)