@@ -1,346 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Canonicalize.Sort (definitions) where
3−
4−import qualified Data.Foldable as F
5−import qualified Data.Graph as Graph
6−import qualified Data.Map as Map
7−import qualified Data.Maybe as Maybe
8−import qualified Data.Set as Set
9−import Data.Text (Text)
10−
11−import qualified AST.Expression.Canonical as C
12−import qualified AST.Pattern as P
13−import qualified AST.Variable as V
14−import qualified Reporting.Annotation as A
15−import qualified Reporting.Error.Canonicalize as E
16−import qualified Reporting.Result as R
17−
18−
19−
20−-- SORT DEFINITIONS
21−
22−
23−definitions :: (Monoid i) => C.Expr -> R.Result i w E.Error C.Expr
24−definitions expression =
25− let
26− (R.Result _ warnings answer) =
27− reorder expression
28− in
29− R.Result mempty warnings answer
30−
31−
32−data LocalVars =
33− LocalVars
34− { _immediate :: Set.Set Text
35− , _delayed :: Set.Set Text
36− , _tags :: Set.Set Text
37− }
38−
39−
40−instance Monoid LocalVars where
41− mempty =
42− LocalVars Set.empty Set.empty Set.empty
43−
44− mappend (LocalVars i1 d1 t1) (LocalVars i2 d2 t2) =
45− LocalVars (Set.union i1 i2) (Set.union d1 d2) (Set.union t1 t2)
46−
47−
48−addTag :: Text -> a -> R.Result LocalVars w e a
49−addTag name value =
50− R.accumulate (LocalVars Set.empty Set.empty (Set.singleton name)) value
51−
52−
53−addImmediate :: V.Canonical -> a -> R.Result LocalVars w e a
54−addImmediate (V.Canonical home name) value =
55− case home of
56− V.Local ->
57− R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value
58−
59− V.TopLevel _ ->
60− R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value
61−
62− V.BuiltIn ->
63− return value
64−
65− V.Module _ ->
66− return value
67−
68−
69−capture :: P.Canonical -> R.Result LocalVars w e a -> R.Result LocalVars w e a
70−capture pattern result =
71− captureVars (P.boundVarSet pattern) result
72−
73−
74−captureVars :: Set.Set Text -> R.Result LocalVars w e a -> R.Result LocalVars w e a
75−captureVars bound (R.Result (LocalVars immediate delayed tags) warnings result) =
76− let
77− localVars =
78− LocalVars (Set.difference immediate bound) (Set.difference delayed bound) tags
79− in
80− R.Result localVars warnings result
81−
82−
83−delay :: R.Result LocalVars w e a -> R.Result LocalVars w e a
84−delay (R.Result (LocalVars immediate delayed tags) warnings result) =
85− R.Result (LocalVars Set.empty (Set.union immediate delayed) tags) warnings result
86−
87−
88−
89−-- REORDER EXPRESSIONS
90−
91−
92−reorder :: C.Expr -> R.Result LocalVars w E.Error C.Expr
93−reorder (A.A region expression) =
94− A.A region <$>
95− case expression of
96− C.Var var ->
97− addImmediate var expression
98−
99− C.Lambda pattern body ->
100− delay $
101− bindingReorder C.Lambda (pattern, body)
102−
103− C.Binop op leftExpr rightExpr ->
104− do binop <- C.Binop op <$> reorder leftExpr <*> reorder rightExpr
105− addImmediate op binop
106−
107− C.Case expr cases ->
108− C.Case <$> reorder expr <*> traverse (bindingReorder (,)) cases
109−
110− C.Ctor ctor@(V.Canonical _ name) exprs ->
111− addTag name =<< (C.Ctor ctor <$> traverse reorder exprs)
112−
113− -- Just pipe the reorder though
114− C.Literal _ ->
115− return expression
116−
117− C.List es ->
118− C.List <$> traverse reorder es
119−
120− C.App func arg ->
121− C.App <$> reorder func <*> reorder arg
122−
123− C.If branches finally ->
124− C.If
125− <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
126− <*> reorder finally
127−
128− C.Access record field ->
129− C.Access
130− <$> reorder record
131− <*> return field
132−
133− C.Update record fields ->
134− C.Update
135− <$> reorder record
136− <*> traverse (traverse reorder) fields
137−
138− C.Record fields ->
139− C.Record
140− <$> traverse (traverse reorder) fields
141−
142− C.Cmd _ _ ->
143− return expression
144−
145− C.Sub _ _ ->
146− return expression
147−
148− C.OutgoingPort _ _ ->
149− return expression
150−
151− C.IncomingPort _ _ ->
152− return expression
153−
154− C.Program _ _ ->
155− error "DANGER - Program AST nodes should not be in def sorting."
156−
157− C.SaveEnv _ _ ->
158− return expression
159−
160− C.GLShader _ _ _ ->
161− return expression
162−
163− -- Actually do some reordering
164− C.Let defs body ->
165− case reorderDefs defs of
166− R.Result () warnings (R.Err errors) ->
167− R.Result mempty warnings (R.Err errors)
168−
169− R.Result () warnings (R.Ok (boundVars, defGroups, defLocals)) ->
170− captureVars boundVars $
171− do _ <- R.Result mempty warnings (R.Ok ())
172− newBody <- reorder body
173− R.accumulate defLocals $ A.drop $
174− foldr (\defGroup expr -> A.A region (C.Let defGroup expr)) newBody defGroups
175−
176−
177−
178−-- BINDINGS
179−
180−
181−bindingReorder
182− :: (P.Canonical -> C.Expr -> a)
183− -> (P.Canonical, C.Expr)
184− -> R.Result LocalVars w E.Error a
185−bindingReorder func (pattern, expr) =
186− do answer <- func pattern <$> capture pattern (reorder expr)
187− addPatternTags pattern answer
188−
189−
190−
191−-- FREE CONSTRUCTORS
192−
193−
194−addPatternTags :: P.Canonical -> a -> R.Result LocalVars w e a
195−addPatternTags pattern value =
196− R.accumulate (LocalVars Set.empty Set.empty (getPatternTags pattern)) value
197−
198−
199−getPatternTags :: P.Canonical -> Set.Set Text
200−getPatternTags (A.A _ pattern) =
201− case pattern of
202− P.Var _ ->
203− Set.empty
204−
205− P.Alias _ subPattern ->
206− getPatternTags subPattern
207−
208− P.Record _ ->
209− Set.empty
210−
211− P.Anything ->
212− Set.empty
213−
214− P.Literal _ ->
215− Set.empty
216−
217− P.Ctor (V.Canonical home name) patterns ->
218− let
219− freeCtors =
220− Set.unions (map getPatternTags patterns)
221− in
222− case home of
223− V.Local ->
224− Set.insert name freeCtors
225−
226− V.TopLevel _ ->
227− Set.insert name freeCtors
228−
229− V.BuiltIn ->
230− freeCtors
231−
232− V.Module _ ->
233− freeCtors
234−
235−
236−
237−-- REORDER DEFINITIONS
238−
239−
240−reorderDefs
241− :: [C.Def]
242− -> R.Result () w E.Error (Set.Set Text, [[C.Def]], LocalVars)
243−reorderDefs defs =
244− do rawNodes <- sequenceA $ zipWith toRawNode [0..] defs
245− let boundVarDict = toBoundVarDict rawNodes
246− _ <- detectLoops boundVarDict rawNodes
247− return $ groupDefs boundVarDict rawNodes
248−
249−
250−toRawNode :: Int -> C.Def -> R.Result () w E.Error (C.Def, Int, LocalVars)
251−toRawNode index (C.Def region pattern body maybeType) =
252− let
253− (R.Result localVars warnings answer) =
254− addPatternTags pattern =<< reorder body
255−
256− toRawNodeHelp newBody =
257− ( C.Def region pattern newBody maybeType, index, localVars )
258− in
259− toRawNodeHelp <$> R.Result () warnings answer
260−
261−
262−toBoundVarDict :: [(C.Def, Int, a)] -> Map.Map Text Int
263−toBoundVarDict defAndDeps =
264− Map.fromList (concatMap toBoundVarDictHelp defAndDeps)
265−
266−
267−toBoundVarDictHelp :: (C.Def, Int, a) -> [(Text, Int)]
268−toBoundVarDictHelp (C.Def _ pattern _ _, key, _) =
269− map (\(A.A _ name) -> (name, key)) (P.boundVars pattern)
270−
271−
272−
273−-- BUILD GRAPHS
274−
275−
276−toNode
277− :: (deps -> [Text])
278− -> Map.Map Text Int
279− -> (C.Def, Int, deps)
280− -> (C.Def, Int, [Int])
281−toNode toVars boundVarDict (def, index, deps) =
282− let
283− localDeps =
284− Maybe.mapMaybe (\var -> Map.lookup var boundVarDict) (toVars deps)
285− in
286− ( def, index, localDeps )
287−
288−
289−immediateOnly :: LocalVars -> [Text]
290−immediateOnly (LocalVars immediate _ _) =
291− Set.toList immediate
292−
293−
294−allVars :: LocalVars -> [Text]
295−allVars (LocalVars immediate delayed tags) =
296− Set.toList immediate ++ Set.toList delayed ++ Set.toList tags
297−
298−
299−
300−-- DETECT LOOPS
301−
302−
303−detectLoops
304− :: Map.Map Text Int
305− -> [(C.Def, Int, LocalVars)]
306− -> R.Result () w E.Error ()
307−detectLoops boundVarDict rawNodes =
308− F.traverse_ detectLoopsHelp $
309− Graph.stronglyConnComp $
310− map (toNode immediateOnly boundVarDict) rawNodes
311−
312−
313−detectLoopsHelp :: Graph.SCC C.Def -> R.Result () w E.Error ()
314−detectLoopsHelp scc =
315− case scc of
316− Graph.AcyclicSCC _ ->
317− R.ok ()
318−
319− Graph.CyclicSCC defs ->
320− case defs of
321− [] ->
322− R.ok ()
323−
324− def@(C.Def region (A.A nameRegion _) _ _) : rest ->
325− R.throw region $ E.BadRecursion nameRegion def rest
326−
327−
328−
329−-- GROUP DEFINITIONS
330−
331−
332−groupDefs
333− :: Map.Map Text Int
334− -> [(C.Def, Int, LocalVars)]
335− -> ( Set.Set Text, [[C.Def]], LocalVars )
336−groupDefs boundVarDict rawNodes =
337− let
338− allLocalVars =
339− mconcat (map (\(_, _, localVars) -> localVars) rawNodes)
340−
341− defGroups =
342− map Graph.flattenSCC $
343− Graph.stronglyConnComp $
344− map (toNode allVars boundVarDict) rawNodes
345− in
346− ( Map.keysSet boundVarDict, defGroups, allLocalVars )