@@ -1,7 +1,7 @@
11{-# OPTIONS_GHC -Wall #-}
22module Canonicalize.Sort (definitions) where
33
4−import Control.Monad.State
4+import qualified Data.Foldable as F
55import qualified Data.Graph as Graph
66import qualified Data.Map as Map
77import qualified Data.Maybe as Maybe
@@ -12,71 +12,117 @@ import qualified AST.Expression.Canonical as Canonical
1212import qualified AST.Pattern as P
1313import qualified AST.Variable as V
1414import qualified Reporting.Annotation as A
15+import qualified Reporting.Error.Canonicalize as E
16+import qualified Reporting.Result as R
1517
1618
1719
18−-- STARTING POINT
20+-- SORT DEFINITIONS
1921
2022
21−definitions :: Canonical.Expr -> Canonical.Expr
23+definitions :: (Monoid i) => Canonical.Expr -> R.Result i w E.Error Canonical.Expr
2224definitions expression =
23− evalState (reorder expression) Set.empty
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 String
35+ , _delayed :: Set.Set String
36+ , _tags :: Set.Set String
37+ }
38+
2439
40+instance Monoid LocalVars where
41+ mempty =
42+ LocalVars Set.empty Set.empty Set.empty
2543
26−free :: String -> State (Set.Set String) ()
27−free x =
28− modify (Set.insert x)
44+ mappend (LocalVars i1 d1 t1) (LocalVars i2 d2 t2) =
45+ LocalVars (Set.union i1 i2) (Set.union d1 d2) (Set.union t1 t2)
2946
3047
31−freeIfLocal :: V.Canonical -> State (Set.Set String) ()
32−freeIfLocal (V.Canonical home name) =
48+addTag :: String -> 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 =
3355 case home of
34− V.Local -> free name
35− V.TopLevel _ -> free name
36− V.BuiltIn -> return ()
37− V.Module _ -> return ()
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 String -> 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
3886
3987
4088
4189-- REORDER EXPRESSIONS
4290
4391
44−reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
45−reorder (A.A ann expression) =
46− A.A ann <$>
92+reorder :: Canonical.Expr -> R.Result LocalVars w E.Error Canonical.Expr
93+reorder (A.A region expression) =
94+ A.A region <$>
4795 case expression of
48− -- Be careful adding and restricting freeVars
4996 Var var ->
50− do freeIfLocal var
51− return expression
97+ addImmediate var expression
5298
5399 Lambda pattern body ->
54− uncurry Lambda <$> bindingReorder (pattern,body)
100+ delay $
101+ bindingReorder Lambda (pattern, body)
55102
56103 Binop op leftExpr rightExpr ->
57− do freeIfLocal op
58− Binop op <$> reorder leftExpr <*> reorder rightExpr
104+ do binop <- Binop op <$> reorder leftExpr <*> reorder rightExpr
105+ addImmediate op binop
59106
60107 Case expr cases ->
61− Case <$> reorder expr <*> mapM bindingReorder cases
108+ Case <$> reorder expr <*> traverse (bindingReorder (,)) cases
62109
63110 Data name exprs ->
64− do free name
65− Data name <$> mapM reorder exprs
111+ addTag name =<< (Data name <$> traverse reorder exprs)
66112
67113 -- Just pipe the reorder though
68114 Literal _ ->
69115 return expression
70116
71117 ExplicitList es ->
72− ExplicitList <$> mapM reorder es
118+ ExplicitList <$> traverse reorder es
73119
74120 App func arg ->
75121 App <$> reorder func <*> reorder arg
76122
77123 If branches finally ->
78124 If
79− <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
125+ <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
80126 <*> reorder finally
81127
82128 Access record field ->
@@ -87,11 +133,11 @@ reorder (A.A ann expression) =
87133 Update record fields ->
88134 Update
89135 <$> reorder record
90− <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
136+ <*> traverse (traverse reorder) fields
91137
92138 Record fields ->
93139 Record
94− <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
140+ <$> traverse (traverse reorder) fields
95141
96142 Cmd _ ->
97143 return expression
@@ -116,117 +162,185 @@ reorder (A.A ann expression) =
116162
117163 -- Actually do some reordering
118164 Let defs body ->
119− do body' <- reorder 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 (Let defGroup expr)) newBody defGroups
175+
176+
177+
178+-- BINDINGS
179+
180+
181+bindingReorder
182+ :: (P.Canonical -> Canonical.Expr -> a)
183+ -> (P.Canonical, Canonical.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
120188
121− -- Sort defs into strongly connected components.This
122− -- allows the programmer to write definitions in whatever
123− -- order they please, we can still define things in order
124− -- and generalize polymorphic functions when appropriate.
125− sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
126− let defss = map Graph.flattenSCC sccs
127189
128− -- remove let-bound variables from the context
129− forM_ defs $ \(Canonical.Def _ pattern _ _) -> do
130− bound pattern
131− mapM free (ctors pattern)
132190
133− let (A.A _ let') =
134− foldr (\ds bod -> A.A ann (Let ds bod)) body' defss
191+-- FREE CONSTRUCTORS
135192
136− return let'
137193
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
138197
139−ctors :: P.Canonical -> [String]
140−ctors (A.A _ pattern) =
198+
199+getPatternTags :: P.Canonical -> Set.Set String
200+getPatternTags (A.A _ pattern) =
141201 case pattern of
142202 P.Var _ ->
143− []
203+ Set.empty
144204
145− P.Alias _ p ->
146− ctors p
205+ P.Alias _ subPattern ->
206+ getPatternTags subPattern
147207
148208 P.Record _ ->
149− []
209+ Set.empty
150210
151211 P.Anything ->
152− []
212+ Set.empty
153213
154214 P.Literal _ ->
155− []
215+ Set.empty
156216
157− P.Data (V.Canonical home name) ps ->
217+ P.Data (V.Canonical home name) patterns ->
218+ let
219+ freeCtors =
220+ Set.unions (map getPatternTags patterns)
221+ in
158222 case home of
159− V.Local -> name : rest
160− V.TopLevel _ -> name : rest
161− V.BuiltIn -> rest
162− V.Module _ -> rest
163− where
164− rest = concatMap ctors ps
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+
165239
240+reorderDefs
241+ :: [Canonical.Def]
242+ -> R.Result () w E.Error (Set.Set String, [[Canonical.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
166248
167−bound :: P.Canonical -> State (Set.Set String) ()
168−bound pattern =
249+
250+toRawNode :: Int -> Canonical.Def -> R.Result () w E.Error (Canonical.Def, Int, LocalVars)
251+toRawNode index (Canonical.Def region pattern body maybeType) =
169252 let
170− boundVars =
171− P.boundVarSet pattern
253+ (R.Result localVars warnings answer) =
254+ addPatternTags pattern =<< reorder body
255+
256+ toRawNodeHelp newBody =
257+ ( Canonical.Def region pattern newBody maybeType, index, localVars )
172258 in
173− modify (\freeVars -> Set.difference freeVars boundVars)
259+ toRawNodeHelp <$> R.Result () warnings answer
174260
175261
176−bindingReorder
177− :: (P.Canonical, Canonical.Expr)
178− -> State (Set.Set String) (P.Canonical, Canonical.Expr)
179−bindingReorder (pattern, expr) =
180− do expr' <- reorder expr
181− bound pattern
182− mapM_ free (ctors pattern)
183− return (pattern, expr')
184−
185−
186−
187−-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
188−
189−
190−-- This also reorders the all of the sub-expressions in the Def list.
191−buildDefGraph
192− :: [Canonical.Def]
193− -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
194−buildDefGraph defs =
195− do pdefsDeps <- mapM reorderAndGetDependencies defs
196− return $ realDeps (addKey pdefsDeps)
197− where
198− addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
199− addKey =
200− zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
201−
202− variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
203− variableToKey (Canonical.Def _ pattern _ _, key, _) =
204− [ (var, key) | var <- P.boundVarList pattern ]
205−
206− variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
207− variableToKeyMap pdefsDeps =
208− Map.fromList (concatMap variableToKey pdefsDeps)
209−
210− realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
211− realDeps pdefsDeps =
212− map convert pdefsDeps
213− where
214− varDict =
215− variableToKeyMap pdefsDeps
216−
217− convert (pdef, key, deps) =
218− (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
219−
220−
221−reorderAndGetDependencies
222− :: Canonical.Def
223− -> State (Set.Set String) (Canonical.Def, [String])
224−reorderAndGetDependencies (Canonical.Def facts pattern expr mType) =
225− do globalFrees <- get
226− -- work in a fresh environment
227− put Set.empty
228− expr' <- reorder expr
229− localFrees <- get
230− -- merge with global frees
231− modify (Set.union globalFrees)
232− return (Canonical.Def facts pattern expr' mType, Set.toList localFrees)
262+toBoundVarDict :: [(Canonical.Def, Int, a)] -> Map.Map String Int
263+toBoundVarDict defAndDeps =
264+ Map.fromList (concatMap toBoundVarDictHelp defAndDeps)
265+
266+
267+toBoundVarDictHelp :: (Canonical.Def, Int, a) -> [(String, Int)]
268+toBoundVarDictHelp (Canonical.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 -> [String])
278+ -> Map.Map String Int
279+ -> (Canonical.Def, Int, deps)
280+ -> (Canonical.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 -> [String]
290+immediateOnly (LocalVars immediate _ _) =
291+ Set.toList immediate
292+
293+
294+allVars :: LocalVars -> [String]
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 String Int
305+ -> [(Canonical.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 Canonical.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@(Canonical.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 String Int
334+ -> [(Canonical.Def, Int, LocalVars)]
335+ -> ( Set.Set String, [[Canonical.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 )