git.iko.soy/elk
on eb97f2a help sign in
elk/src/Canonicalize/Sort.hs
346 lines 8.5 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 AST.Expression.General (Expr'(..))
11import qualified AST.Expression.Canonical as Canonical
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) => Canonical.Expr -> R.Result i w E.Error Canonical.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 String
35 , _delayed :: Set.Set String
36 , _tags :: Set.Set String
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 :: String -> 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 String -> 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 :: Canonical.Expr -> R.Result LocalVars w E.Error Canonical.Expr
93reorder (A.A region expression) =
94 A.A region <$>
95 case expression of
96 Var var ->
97 addImmediate var expression
99 Lambda pattern body ->
100 delay $
101 bindingReorder Lambda (pattern, body)
103 Binop op leftExpr rightExpr ->
104 do binop <- Binop op <$> reorder leftExpr <*> reorder rightExpr
105 addImmediate op binop
107 Case expr cases ->
108 Case <$> reorder expr <*> traverse (bindingReorder (,)) cases
110 Data name exprs ->
111 addTag name =<< (Data name <$> traverse reorder exprs)
113 -- Just pipe the reorder though
114 Literal _ ->
115 return expression
117 ExplicitList es ->
118 ExplicitList <$> traverse reorder es
120 App func arg ->
121 App <$> reorder func <*> reorder arg
123 If branches finally ->
124 If
125 <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
126 <*> reorder finally
128 Access record field ->
129 Access
130 <$> reorder record
131 <*> return field
133 Update record fields ->
134 Update
135 <$> reorder record
136 <*> traverse (traverse reorder) fields
138 Record fields ->
139 Record
140 <$> traverse (traverse reorder) fields
142 Cmd _ ->
143 return expression
145 Sub _ ->
146 return expression
148 OutgoingPort _ _ ->
149 return expression
151 IncomingPort _ _ ->
152 return expression
154 Program _ _ ->
155 error "DANGER - Program AST nodes should not be in def sorting."
157 SaveEnv _ _ ->
158 return expression
160 GLShader _ _ _ ->
161 return expression
163 -- Actually do some reordering
164 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 (Let defGroup expr)) newBody defGroups
178-- BINDINGS
181bindingReorder
182 :: (P.Canonical -> Canonical.Expr -> a)
183 -> (P.Canonical, Canonical.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 String
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.Data (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 :: [Canonical.Def]
242 -> R.Result () w E.Error (Set.Set String, [[Canonical.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 -> Canonical.Def -> R.Result () w E.Error (Canonical.Def, Int, LocalVars)
251toRawNode index (Canonical.Def region pattern body maybeType) =
252 let
253 (R.Result localVars warnings answer) =
254 addPatternTags pattern =<< reorder body
256 toRawNodeHelp newBody =
257 ( Canonical.Def region pattern newBody maybeType, index, localVars )
258 in
259 toRawNodeHelp <$> R.Result () warnings answer
262toBoundVarDict :: [(Canonical.Def, Int, a)] -> Map.Map String Int
263toBoundVarDict defAndDeps =
264 Map.fromList (concatMap toBoundVarDictHelp defAndDeps)
267toBoundVarDictHelp :: (Canonical.Def, Int, a) -> [(String, Int)]
268toBoundVarDictHelp (Canonical.Def _ pattern _ _, key, _) =
269 map (\(A.A _ name) -> (name, key)) (P.boundVars pattern)
273-- BUILD GRAPHS
276toNode
277 :: (deps -> [String])
278 -> Map.Map String Int
279 -> (Canonical.Def, Int, deps)
280 -> (Canonical.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 -> [String]
290immediateOnly (LocalVars immediate _ _) =
291 Set.toList immediate
294allVars :: LocalVars -> [String]
295allVars (LocalVars immediate delayed tags) =
296 Set.toList immediate ++ Set.toList delayed ++ Set.toList tags
300-- DETECT LOOPS
303detectLoops
304 :: Map.Map String Int
305 -> [(Canonical.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 Canonical.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@(Canonical.Def region (A.A nameRegion _) _ _) : rest ->
325 R.throw region $ E.BadRecursion nameRegion def rest
329-- GROUP DEFINITIONS
332groupDefs
333 :: Map.Map String Int
334 -> [(Canonical.Def, Int, LocalVars)]
335 -> ( Set.Set String, [[Canonical.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 )