git.iko.soy/elk
on 4cd5aec help sign in
elk/src/Canonicalize/Sort.hs
346 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
9import Data.Text (Text)
11import qualified AST.Expression.Canonical as C
12import qualified AST.Pattern as P
13import qualified AST.Variable as V
14import qualified Reporting.Annotation as A
15import qualified Reporting.Error.Canonicalize as E
16import qualified Reporting.Result as R
20-- SORT DEFINITIONS
23definitions :: (Monoid i) => C.Expr -> R.Result i w E.Error C.Expr
24definitions expression =
25 let
26 (R.Result _ warnings answer) =
27 reorder expression
28 in
29 R.Result mempty warnings answer
32data LocalVars =
33 LocalVars
34 { _immediate :: Set.Set Text
35 , _delayed :: Set.Set Text
36 , _tags :: Set.Set Text
37 }
40instance Monoid LocalVars where
41 mempty =
42 LocalVars Set.empty Set.empty Set.empty
44 mappend (LocalVars i1 d1 t1) (LocalVars i2 d2 t2) =
45 LocalVars (Set.union i1 i2) (Set.union d1 d2) (Set.union t1 t2)
48addTag :: Text -> a -> R.Result LocalVars w e a
49addTag name value =
50 R.accumulate (LocalVars Set.empty Set.empty (Set.singleton name)) value
53addImmediate :: V.Canonical -> a -> R.Result LocalVars w e a
54addImmediate (V.Canonical home name) value =
55 case home of
56 V.Local ->
57 R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value
59 V.TopLevel _ ->
60 R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value
62 V.BuiltIn ->
63 return value
65 V.Module _ ->
66 return value
69capture :: P.Canonical -> R.Result LocalVars w e a -> R.Result LocalVars w e a
70capture pattern result =
71 captureVars (P.boundVarSet pattern) result
74captureVars :: Set.Set Text -> R.Result LocalVars w e a -> R.Result LocalVars w e a
75captureVars 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
83delay :: R.Result LocalVars w e a -> R.Result LocalVars w e a
84delay (R.Result (LocalVars immediate delayed tags) warnings result) =
85 R.Result (LocalVars Set.empty (Set.union immediate delayed) tags) warnings result
89-- REORDER EXPRESSIONS
92reorder :: C.Expr -> R.Result LocalVars w E.Error C.Expr
93reorder (A.A region expression) =
94 A.A region <$>
95 case expression of
96 C.Var var ->
97 addImmediate var expression
99 C.Lambda pattern body ->
100 delay $
101 bindingReorder C.Lambda (pattern, body)
103 C.Binop op leftExpr rightExpr ->
104 do binop <- C.Binop op <$> reorder leftExpr <*> reorder rightExpr
105 addImmediate op binop
107 C.Case expr cases ->
108 C.Case <$> reorder expr <*> traverse (bindingReorder (,)) cases
110 C.Ctor ctor@(V.Canonical _ name) exprs ->
111 addTag name =<< (C.Ctor ctor <$> traverse reorder exprs)
113 -- Just pipe the reorder though
114 C.Literal _ ->
115 return expression
117 C.List es ->
118 C.List <$> traverse reorder es
120 C.App func arg ->
121 C.App <$> reorder func <*> reorder arg
123 C.If branches finally ->
124 C.If
125 <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
126 <*> reorder finally
128 C.Access record field ->
129 C.Access
130 <$> reorder record
131 <*> return field
133 C.Update record fields ->
134 C.Update
135 <$> reorder record
136 <*> traverse (traverse reorder) fields
138 C.Record fields ->
139 C.Record
140 <$> traverse (traverse reorder) fields
142 C.Cmd _ _ ->
143 return expression
145 C.Sub _ _ ->
146 return expression
148 C.OutgoingPort _ _ ->
149 return expression
151 C.IncomingPort _ _ ->
152 return expression
154 C.Program _ _ ->
155 error "DANGER - Program AST nodes should not be in def sorting."
157 C.SaveEnv _ _ ->
158 return expression
160 C.GLShader _ _ _ ->
161 return expression
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)
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
178-- BINDINGS
181bindingReorder
182 :: (P.Canonical -> C.Expr -> a)
183 -> (P.Canonical, C.Expr)
184 -> R.Result LocalVars w E.Error a
185bindingReorder func (pattern, expr) =
186 do answer <- func pattern <$> capture pattern (reorder expr)
187 addPatternTags pattern answer
191-- FREE CONSTRUCTORS
194addPatternTags :: P.Canonical -> a -> R.Result LocalVars w e a
195addPatternTags pattern value =
196 R.accumulate (LocalVars Set.empty Set.empty (getPatternTags pattern)) value
199getPatternTags :: P.Canonical -> Set.Set Text
200getPatternTags (A.A _ pattern) =
201 case pattern of
202 P.Var _ ->
203 Set.empty
205 P.Alias _ subPattern ->
206 getPatternTags subPattern
208 P.Record _ ->
209 Set.empty
211 P.Anything ->
212 Set.empty
214 P.Literal _ ->
215 Set.empty
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
226 V.TopLevel _ ->
227 Set.insert name freeCtors
229 V.BuiltIn ->
230 freeCtors
232 V.Module _ ->
233 freeCtors
237-- REORDER DEFINITIONS
240reorderDefs
241 :: [C.Def]
242 -> R.Result () w E.Error (Set.Set Text, [[C.Def]], LocalVars)
243reorderDefs defs =
244 do rawNodes <- sequenceA $ zipWith toRawNode [0..] defs
245 let boundVarDict = toBoundVarDict rawNodes
246 _ <- detectLoops boundVarDict rawNodes
247 return $ groupDefs boundVarDict rawNodes
250toRawNode :: Int -> C.Def -> R.Result () w E.Error (C.Def, Int, LocalVars)
251toRawNode index (C.Def region pattern body maybeType) =
252 let
253 (R.Result localVars warnings answer) =
254 addPatternTags pattern =<< reorder body
256 toRawNodeHelp newBody =
257 ( C.Def region pattern newBody maybeType, index, localVars )
258 in
259 toRawNodeHelp <$> R.Result () warnings answer
262toBoundVarDict :: [(C.Def, Int, a)] -> Map.Map Text Int
263toBoundVarDict defAndDeps =
264 Map.fromList (concatMap toBoundVarDictHelp defAndDeps)
267toBoundVarDictHelp :: (C.Def, Int, a) -> [(Text, Int)]
268toBoundVarDictHelp (C.Def _ pattern _ _, key, _) =
269 map (\(A.A _ name) -> (name, key)) (P.boundVars pattern)
273-- BUILD GRAPHS
276toNode
277 :: (deps -> [Text])
278 -> Map.Map Text Int
279 -> (C.Def, Int, deps)
280 -> (C.Def, Int, [Int])
281toNode 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 )
289immediateOnly :: LocalVars -> [Text]
290immediateOnly (LocalVars immediate _ _) =
291 Set.toList immediate
294allVars :: LocalVars -> [Text]
295allVars (LocalVars immediate delayed tags) =
296 Set.toList immediate ++ Set.toList delayed ++ Set.toList tags
300-- DETECT LOOPS
303detectLoops
304 :: Map.Map Text Int
305 -> [(C.Def, Int, LocalVars)]
306 -> R.Result () w E.Error ()
307detectLoops boundVarDict rawNodes =
308 F.traverse_ detectLoopsHelp $
309 Graph.stronglyConnComp $
310 map (toNode immediateOnly boundVarDict) rawNodes
313detectLoopsHelp :: Graph.SCC C.Def -> R.Result () w E.Error ()
314detectLoopsHelp scc =
315 case scc of
316 Graph.AcyclicSCC _ ->
317 R.ok ()
319 Graph.CyclicSCC defs ->
320 case defs of
321 [] ->
322 R.ok ()
324 def@(C.Def region (A.A nameRegion _) _ _) : rest ->
325 R.throw region $ E.BadRecursion nameRegion def rest
329-- GROUP DEFINITIONS
332groupDefs
333 :: Map.Map Text Int
334 -> [(C.Def, Int, LocalVars)]
335 -> ( Set.Set Text, [[C.Def]], LocalVars )
336groupDefs boundVarDict rawNodes =
337 let
338 allLocalVars =
339 mconcat (map (\(_, _, localVars) -> localVars) rawNodes)
341 defGroups =
342 map Graph.flattenSCC $
343 Graph.stronglyConnComp $
344 map (toNode allVars boundVarDict) rawNodes
345 in
346 ( Map.keysSet boundVarDict, defGroups, allLocalVars )