22 | 22 |
|
23 | 23 |
emptyScope :: Scope
|
24 | 24 |
emptyScope = Scope
|
25 | |
{ boundVars = Set.fromList $ Map.keys initialScope -- Add builtins to bound vars
|
|
25 |
{ boundVars = Set.fromList $ Map.keys initialScope
|
26 | 26 |
, freeVars = Set.empty
|
27 | 27 |
}
|
28 | 28 |
|
|
37 | 37 |
|
38 | 38 |
convertAST :: AST -> ScopeM
|
39 | 39 |
convertAST = \case
|
40 | |
Atom name -> do
|
41 | |
scope <- ask
|
42 | |
if Set.member name (boundVars scope)
|
43 | |
then return $ Right (Var name, scope)
|
44 | |
else return $ Left $ "Unbound variable: " ++ name
|
|
40 |
Atom name -> do
|
|
41 |
scope <- ask
|
|
42 |
if Set.member name (boundVars scope)
|
|
43 |
then return $ Right (Var name, scope)
|
|
44 |
else return $ Left $ "Unbound variable: " ++ name
|
45 | 45 |
|
46 | |
Number n -> do
|
47 | |
scope <- ask
|
48 | |
return $ Right (Literal $ VNum n, scope)
|
|
46 |
Number n -> do
|
|
47 |
scope <- ask
|
|
48 |
return $ Right (Literal $ VNum n, scope)
|
49 | 49 |
|
50 | |
String s -> do
|
51 | |
scope <- ask
|
52 | |
return $ Right (Literal $ VString s, scope)
|
|
50 |
String s -> do
|
|
51 |
scope <- ask
|
|
52 |
return $ Right (Literal $ VString s, scope)
|
53 | 53 |
|
54 | |
Quote declaredFreeVars body -> do
|
55 | |
scope <- ask
|
56 | |
-- Put the declared free variables in scope before converting the body
|
57 | |
let declaredFreeVarsSet = Set.fromList declaredFreeVars
|
58 | |
let scope' = scope {
|
59 | |
boundVars = Set.union (boundVars scope) declaredFreeVarsSet
|
|
54 |
Quote declaredFreeVars body -> do
|
|
55 |
scope <- ask
|
|
56 |
let declaredFreeVarsSet = Set.fromList declaredFreeVars
|
|
57 |
let scope' = scope {
|
|
58 |
boundVars = Set.union (boundVars scope) declaredFreeVarsSet
|
60 | 59 |
}
|
61 | |
-- Convert the body with the extended scope
|
62 | |
case runReader (convertAST body) scope' of
|
63 | |
Left err -> return $ Left err
|
64 | |
Right (bodyABT, bodyScope) ->
|
65 | |
let
|
66 | |
finalScope = scope {
|
67 | |
boundVars = boundVars scope, -- Don't persist the temporary free vars
|
68 | |
freeVars = Set.union (freeVars scope)
|
69 | |
(Set.difference (freeVars bodyScope) declaredFreeVarsSet)
|
70 | |
}
|
71 | |
undeclaredFreeVars =
|
72 | |
Set.difference (collectUnboundVars bodyABT)
|
73 | |
(Set.union (boundVars scope) declaredFreeVarsSet)
|
74 | |
in
|
75 | |
if Set.null undeclaredFreeVars
|
76 | |
then return $ Right (Literal $ VABT declaredFreeVars bodyABT, finalScope)
|
77 | |
else return $ Left $ "Unbound variables in quoted ABT: " ++ (show undeclaredFreeVars)
|
|
60 |
case runReader (convertAST body) scope' of
|
|
61 |
Left err -> return $ Left err
|
|
62 |
Right (bodyABT, bodyScope) ->
|
|
63 |
let
|
|
64 |
finalScope = scope {
|
|
65 |
boundVars = boundVars scope,
|
|
66 |
freeVars = Set.union (freeVars scope)
|
|
67 |
(Set.difference (freeVars bodyScope) declaredFreeVarsSet)
|
|
68 |
}
|
|
69 |
undeclaredFreeVars =
|
|
70 |
Set.difference (collectUnboundVars bodyABT)
|
|
71 |
(Set.union (boundVars scope) declaredFreeVarsSet)
|
|
72 |
in
|
|
73 |
if Set.null undeclaredFreeVars
|
|
74 |
then return $ Right (Literal $ VABT declaredFreeVars bodyABT, finalScope)
|
|
75 |
else return $ Left $ "Unbound variables in quoted ABT: " ++ show undeclaredFreeVars
|
78 | 76 |
|
79 | |
Op name args -> do
|
80 | |
-- Convert each argument, collecting ABTs and scopes
|
81 | |
argResults <- sequence $ map convertAST args
|
82 | |
case sequence argResults of
|
83 | |
Left err -> return $ Left err
|
84 | |
Right argPairs ->
|
85 | |
-- Split into lists of ABTs and scopes
|
86 | |
let (argABTs, argScopes) = unzip argPairs
|
87 | |
-- Combine all scopes by unioning their free and bound variables
|
88 | |
finalScope = foldr (\s acc ->
|
89 | |
Scope {
|
90 | |
boundVars = Set.union (boundVars s) (boundVars acc),
|
91 | |
freeVars = Set.union (freeVars s) (freeVars acc)
|
92 | |
}) emptyScope argScopes
|
93 | |
in return $ Right (Operator "op" [Operator name argABTs], finalScope)
|
|
77 |
Lambda params body -> do
|
|
78 |
scope <- ask
|
|
79 |
let newBoundVars = Set.union (boundVars scope) (Set.fromList params)
|
|
80 |
let scopeWithParams = scope { boundVars = newBoundVars }
|
94 | 81 |
|
95 | |
Lambda params body -> do
|
96 | |
scope <- ask
|
97 | |
-- First extend scope with new bound variables
|
98 | |
let newBoundVars = Set.union (boundVars scope) (Set.fromList params)
|
99 | |
let scopeWithParams = scope { boundVars = newBoundVars }
|
100 | |
|
101 | |
-- Convert body with updated scope
|
102 | |
let bodyResult = runReader (convertAST body) scopeWithParams
|
103 | |
case bodyResult of
|
104 | |
Left err -> return $ Left err
|
105 | |
Right (bodyABT, bodyScope) ->
|
106 | |
-- Return final scope that:
|
107 | |
-- 1. Keeps the original bound vars plus the lambda parameters
|
108 | |
-- 2. Includes free vars from the body (except the parameters)
|
109 | |
let finalFreeVars = Set.difference (freeVars bodyScope) (Set.fromList params)
|
110 | |
finalScope = scope {
|
111 | |
boundVars = newBoundVars,
|
112 | |
freeVars = Set.union (freeVars scope) finalFreeVars
|
113 | |
}
|
114 | |
in return $ Right (foldr Binder bodyABT params, finalScope)
|
|
82 |
let bodyResult = runReader (convertAST body) scopeWithParams
|
|
83 |
case bodyResult of
|
|
84 |
Left err -> return $ Left err
|
|
85 |
Right (bodyABT, bodyScope) ->
|
|
86 |
let finalFreeVars = Set.difference (freeVars bodyScope) (Set.fromList params)
|
|
87 |
finalScope = scope {
|
|
88 |
boundVars = newBoundVars,
|
|
89 |
freeVars = Set.union (freeVars scope) finalFreeVars
|
|
90 |
}
|
|
91 |
in return $ Right (foldr Binder bodyABT params, finalScope)
|
115 | 92 |
|
116 | |
Let bindings body -> do
|
117 | |
scope <- ask
|
118 | |
-- Process bindings sequentially, building up scope and collecting ABTs
|
119 | |
let processBindings :: [(Name, AST)] -> Scope -> Either String ([ABT], Scope)
|
120 | |
processBindings [] currScope = Right ([], currScope)
|
121 | |
processBindings ((name, val):rest) currScope = do
|
122 | |
-- Convert the current binding's value using current scope
|
123 | |
case runReader (convertAST val) currScope of
|
124 | |
Left err -> Left err
|
|
93 |
Let name val body -> do
|
|
94 |
scope <- ask
|
|
95 |
-- First convert the value expression
|
|
96 |
valueResult <- local (const scope) $ convertAST val
|
|
97 |
case valueResult of
|
|
98 |
Left err -> return $ Left err
|
125 | 99 |
Right (valABT, valScope) -> do
|
126 | |
-- Add the new binding to scope for subsequent bindings
|
127 | |
let newScope = currScope {
|
128 | |
boundVars = Set.insert name (boundVars currScope),
|
129 | |
freeVars = Set.union (freeVars currScope) (freeVars valScope)
|
130 | |
}
|
131 | |
-- Process remaining bindings with updated scope
|
132 | |
case processBindings rest newScope of
|
133 | |
Left err -> Left err
|
134 | |
Right (restABTs, finalScope) ->
|
135 | |
Right (valABT : restABTs, finalScope)
|
|
100 |
-- Then convert body with the new binding in scope
|
|
101 |
let newBoundVars = Set.insert name (boundVars scope)
|
|
102 |
let scopeWithBinding = scope {
|
|
103 |
boundVars = newBoundVars,
|
|
104 |
freeVars = Set.union (freeVars scope) (freeVars valScope)
|
|
105 |
}
|
|
106 |
bodyResult <- local (const scopeWithBinding) $ convertAST body
|
|
107 |
case bodyResult of
|
|
108 |
Left err -> return $ Left err
|
|
109 |
Right (bodyABT, bodyScope) ->
|
|
110 |
let finalScope = scope {
|
|
111 |
boundVars = newBoundVars,
|
|
112 |
freeVars = Set.union (freeVars bodyScope)
|
|
113 |
(Set.difference (freeVars valScope) (Set.singleton name))
|
|
114 |
}
|
|
115 |
in return $ Right (
|
|
116 |
Operator "let" [
|
|
117 |
Binder name bodyABT,
|
|
118 |
Operator "values" [valABT]
|
|
119 |
],
|
|
120 |
finalScope)
|
136 | 121 |
|
137 | |
case processBindings bindings scope of
|
138 | |
Left err -> return $ Left err
|
139 | |
Right (bindingABTs, bindingsScope) -> do
|
140 | |
-- Convert body using final scope from bindings
|
141 | |
let bodyResult = runReader (convertAST body) bindingsScope
|
142 | |
case bodyResult of
|
143 | |
Left err -> return $ Left err
|
144 | |
Right (bodyABT, bodyScope) ->
|
145 | |
let names = map fst bindings
|
146 | |
finalScope = scope {
|
147 | |
boundVars = Set.union (boundVars scope) (Set.fromList names),
|
148 | |
freeVars = Set.union (freeVars bodyScope)
|
149 | |
(Set.difference (freeVars bindingsScope) (Set.fromList names))
|
150 | |
}
|
151 | |
in return $ Right (
|
152 | |
Operator "let"
|
153 | |
[ foldr Binder bodyABT names
|
154 | |
, Operator "values" bindingABTs
|
155 | |
],
|
156 | |
finalScope)
|
157 | |
|
158 | |
Apply (f:args) -> do
|
159 | |
scope <- ask
|
160 | |
-- Convert function and arguments while accumulating free variables
|
161 | |
let fResult = runReader (convertAST f) scope
|
162 | |
let argResults = map (\arg -> runReader (convertAST arg) scope) args
|
163 | |
|
164 | |
case sequence (fResult : argResults) of
|
165 | |
Left err -> return $ Left err
|
166 | |
Right results ->
|
167 | |
-- Combine free variables from all subexpressions
|
168 | |
let subFreeVars = Set.unions (map (freeVars . snd) results)
|
169 | |
subABTs = map fst results
|
170 | |
finalScope = scope { freeVars = Set.union (freeVars scope) subFreeVars }
|
171 | |
in return $ Right (Operator "apply" subABTs, finalScope)
|
172 | |
|
173 | |
Apply [] -> return $ Left "Empty apply not allowed"
|
|
122 |
Apply [] -> return $ Left "Empty apply not allowed"
|
|
123 |
Apply (f:args) -> do
|
|
124 |
scope <- ask
|
|
125 |
fResult <- local (const scope) $ convertAST f
|
|
126 |
argResults <- mapM (local (const scope) . convertAST) args
|
|
127 |
case sequence (fResult : argResults) of
|
|
128 |
Left err -> return $ Left err
|
|
129 |
Right results ->
|
|
130 |
let subFreeVars = Set.unions (map (freeVars . snd) results)
|
|
131 |
subABTs = map fst results
|
|
132 |
finalScope = scope { freeVars = Set.union (freeVars scope) subFreeVars }
|
|
133 |
in return $ Right (Operator "apply" subABTs, finalScope)⏎
|