git.iko.soy/elk
on b97576d help sign in
elk/src/Canonicalize/Sort.hs
345 lines 8.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Sort (definitions) where
4import qualified Data.Foldable as F
5import qualified Data.Graph as Graph
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.Set as Set
10import qualified AST.Expression.Canonical as C
11import qualified AST.Pattern as P
12import qualified AST.Variable as V
13import qualified Reporting.Annotation as A
14import qualified Reporting.Error.Canonicalize as E
15import qualified Reporting.Result as R
19-- SORT DEFINITIONS
22definitions :: (Monoid i) => C.Expr -> R.Result i w E.Error C.Expr
23definitions expression =
24 let
25 (R.Result _ warnings answer) =
26 reorder expression
27 in
28 R.Result mempty warnings answer
31data LocalVars =
32 LocalVars
33 { _immediate :: Set.Set String
34 , _delayed :: Set.Set String
35 , _tags :: Set.Set String
36 }
39instance Monoid LocalVars where
40 mempty =
41 LocalVars Set.empty Set.empty Set.empty
43 mappend (LocalVars i1 d1 t1) (LocalVars i2 d2 t2) =
44 LocalVars (Set.union i1 i2) (Set.union d1 d2) (Set.union t1 t2)
47addTag :: String -> a -> R.Result LocalVars w e a
48addTag name value =
49 R.accumulate (LocalVars Set.empty Set.empty (Set.singleton name)) value
52addImmediate :: V.Canonical -> a -> R.Result LocalVars w e a
53addImmediate (V.Canonical home name) value =
54 case home of
55 V.Local ->
56 R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value
58 V.TopLevel _ ->
59 R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value
61 V.BuiltIn ->
62 return value
64 V.Module _ ->
65 return value
68capture :: P.Canonical -> R.Result LocalVars w e a -> R.Result LocalVars w e a
69capture pattern result =
70 captureVars (P.boundVarSet pattern) result
73captureVars :: Set.Set String -> R.Result LocalVars w e a -> R.Result LocalVars w e a
74captureVars bound (R.Result (LocalVars immediate delayed tags) warnings result) =
75 let
76 localVars =
77 LocalVars (Set.difference immediate bound) (Set.difference delayed bound) tags
78 in
79 R.Result localVars warnings result
82delay :: R.Result LocalVars w e a -> R.Result LocalVars w e a
83delay (R.Result (LocalVars immediate delayed tags) warnings result) =
84 R.Result (LocalVars Set.empty (Set.union immediate delayed) tags) warnings result
88-- REORDER EXPRESSIONS
91reorder :: C.Expr -> R.Result LocalVars w E.Error C.Expr
92reorder (A.A region expression) =
93 A.A region <$>
94 case expression of
95 C.Var var ->
96 addImmediate var expression
98 C.Lambda pattern body ->
99 delay $
100 bindingReorder C.Lambda (pattern, body)
102 C.Binop op leftExpr rightExpr ->
103 do binop <- C.Binop op <$> reorder leftExpr <*> reorder rightExpr
104 addImmediate op binop
106 C.Case expr cases ->
107 C.Case <$> reorder expr <*> traverse (bindingReorder (,)) cases
109 C.Ctor name exprs ->
110 addTag name =<< (C.Ctor name <$> traverse reorder exprs)
112 -- Just pipe the reorder though
113 C.Literal _ ->
114 return expression
116 C.List es ->
117 C.List <$> traverse reorder es
119 C.App func arg ->
120 C.App <$> reorder func <*> reorder arg
122 C.If branches finally ->
123 C.If
124 <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
125 <*> reorder finally
127 C.Access record field ->
128 C.Access
129 <$> reorder record
130 <*> return field
132 C.Update record fields ->
133 C.Update
134 <$> reorder record
135 <*> traverse (traverse reorder) fields
137 C.Record fields ->
138 C.Record
139 <$> traverse (traverse reorder) fields
141 C.Cmd _ ->
142 return expression
144 C.Sub _ ->
145 return expression
147 C.OutgoingPort _ _ ->
148 return expression
150 C.IncomingPort _ _ ->
151 return expression
153 C.Program _ _ ->
154 error "DANGER - Program AST nodes should not be in def sorting."
156 C.SaveEnv _ _ ->
157 return expression
159 C.GLShader _ _ _ ->
160 return expression
162 -- Actually do some reordering
163 C.Let defs body ->
164 case reorderDefs defs of
165 R.Result () warnings (R.Err errors) ->
166 R.Result mempty warnings (R.Err errors)
168 R.Result () warnings (R.Ok (boundVars, defGroups, defLocals)) ->
169 captureVars boundVars $
170 do _ <- R.Result mempty warnings (R.Ok ())
171 newBody <- reorder body
172 R.accumulate defLocals $ A.drop $
173 foldr (\defGroup expr -> A.A region (C.Let defGroup expr)) newBody defGroups
177-- BINDINGS
180bindingReorder
181 :: (P.Canonical -> C.Expr -> a)
182 -> (P.Canonical, C.Expr)
183 -> R.Result LocalVars w E.Error a
184bindingReorder func (pattern, expr) =
185 do answer <- func pattern <$> capture pattern (reorder expr)
186 addPatternTags pattern answer
190-- FREE CONSTRUCTORS
193addPatternTags :: P.Canonical -> a -> R.Result LocalVars w e a
194addPatternTags pattern value =
195 R.accumulate (LocalVars Set.empty Set.empty (getPatternTags pattern)) value
198getPatternTags :: P.Canonical -> Set.Set String
199getPatternTags (A.A _ pattern) =
200 case pattern of
201 P.Var _ ->
202 Set.empty
204 P.Alias _ subPattern ->
205 getPatternTags subPattern
207 P.Record _ ->
208 Set.empty
210 P.Anything ->
211 Set.empty
213 P.Literal _ ->
214 Set.empty
216 P.Data (V.Canonical home name) patterns ->
217 let
218 freeCtors =
219 Set.unions (map getPatternTags patterns)
220 in
221 case home of
222 V.Local ->
223 Set.insert name freeCtors
225 V.TopLevel _ ->
226 Set.insert name freeCtors
228 V.BuiltIn ->
229 freeCtors
231 V.Module _ ->
232 freeCtors
236-- REORDER DEFINITIONS
239reorderDefs
240 :: [C.Def]
241 -> R.Result () w E.Error (Set.Set String, [[C.Def]], LocalVars)
242reorderDefs defs =
243 do rawNodes <- sequenceA $ zipWith toRawNode [0..] defs
244 let boundVarDict = toBoundVarDict rawNodes
245 _ <- detectLoops boundVarDict rawNodes
246 return $ groupDefs boundVarDict rawNodes
249toRawNode :: Int -> C.Def -> R.Result () w E.Error (C.Def, Int, LocalVars)
250toRawNode index (C.Def region pattern body maybeType) =
251 let
252 (R.Result localVars warnings answer) =
253 addPatternTags pattern =<< reorder body
255 toRawNodeHelp newBody =
256 ( C.Def region pattern newBody maybeType, index, localVars )
257 in
258 toRawNodeHelp <$> R.Result () warnings answer
261toBoundVarDict :: [(C.Def, Int, a)] -> Map.Map String Int
262toBoundVarDict defAndDeps =
263 Map.fromList (concatMap toBoundVarDictHelp defAndDeps)
266toBoundVarDictHelp :: (C.Def, Int, a) -> [(String, Int)]
267toBoundVarDictHelp (C.Def _ pattern _ _, key, _) =
268 map (\(A.A _ name) -> (name, key)) (P.boundVars pattern)
272-- BUILD GRAPHS
275toNode
276 :: (deps -> [String])
277 -> Map.Map String Int
278 -> (C.Def, Int, deps)
279 -> (C.Def, Int, [Int])
280toNode toVars boundVarDict (def, index, deps) =
281 let
282 localDeps =
283 Maybe.mapMaybe (\var -> Map.lookup var boundVarDict) (toVars deps)
284 in
285 ( def, index, localDeps )
288immediateOnly :: LocalVars -> [String]
289immediateOnly (LocalVars immediate _ _) =
290 Set.toList immediate
293allVars :: LocalVars -> [String]
294allVars (LocalVars immediate delayed tags) =
295 Set.toList immediate ++ Set.toList delayed ++ Set.toList tags
299-- DETECT LOOPS
302detectLoops
303 :: Map.Map String Int
304 -> [(C.Def, Int, LocalVars)]
305 -> R.Result () w E.Error ()
306detectLoops boundVarDict rawNodes =
307 F.traverse_ detectLoopsHelp $
308 Graph.stronglyConnComp $
309 map (toNode immediateOnly boundVarDict) rawNodes
312detectLoopsHelp :: Graph.SCC C.Def -> R.Result () w E.Error ()
313detectLoopsHelp scc =
314 case scc of
315 Graph.AcyclicSCC _ ->
316 R.ok ()
318 Graph.CyclicSCC defs ->
319 case defs of
320 [] ->
321 R.ok ()
323 def@(C.Def region (A.A nameRegion _) _ _) : rest ->
324 R.throw region $ E.BadRecursion nameRegion def rest
328-- GROUP DEFINITIONS
331groupDefs
332 :: Map.Map String Int
333 -> [(C.Def, Int, LocalVars)]
334 -> ( Set.Set String, [[C.Def]], LocalVars )
335groupDefs boundVarDict rawNodes =
336 let
337 allLocalVars =
338 mconcat (map (\(_, _, localVars) -> localVars) rawNodes)
340 defGroups =
341 map Graph.flattenSCC $
342 Graph.stronglyConnComp $
343 map (toNode allVars boundVarDict) rawNodes
344 in
345 ( Map.keysSet boundVarDict, defGroups, allLocalVars )