@@ -1,5 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2−module Transform.SortDefinitions (sortDefs) where
2+module Canonicalize.Sort (definitions) where
33
44import Control.Monad.State
55import Control.Applicative ((<$>),(<*>))
@@ -15,31 +15,11 @@ import qualified AST.Variable as V
1515import qualified Reporting.Annotation as A
1616
1717
18−ctors :: P.CanonicalPattern -> [String]
19−ctors (A.A _ pattern) =
20− case pattern of
21− P.Var _ ->
22− []
23−
24− P.Alias _ p ->
25− ctors p
26−
27− P.Record _ ->
28− []
29−
30− P.Anything ->
31− []
32−
33− P.Literal _ ->
34− []
18+-- STARTING POINT
3519
36− P.Data (V.Canonical home name) ps ->
37− case home of
38− V.Local -> name : rest
39− V.BuiltIn -> rest
40− V.Module _ -> rest
41− where
42− rest = concatMap ctors ps
20+definitions :: Canonical.Expr -> Canonical.Expr
21+definitions expression =
22+ evalState (reorder expression) Set.empty
4323
4424
4525free :: String -> State (Set.Set String) ()
@@ -55,17 +35,7 @@ freeIfLocal (V.Canonical home name) =
5535 V.Module _ -> return ()
5636
5737
58−bound :: P.CanonicalPattern -> State (Set.Set String) ()
59−bound pattern =
60− let boundVars = P.boundVarSet pattern
61− in
62− modify (\freeVars -> Set.difference freeVars boundVars)
63−
64−
65−sortDefs :: Canonical.Expr -> Canonical.Expr
66−sortDefs expression =
67− evalState (reorder expression) Set.empty
68−
38+-- REORDER EXPRESSIONS
6939
7040reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
7141reorder (A.A ann expression) =
@@ -147,7 +117,7 @@ reorder (A.A ann expression) =
147117 -- allows the programmer to write definitions in whatever
148118 -- order they please, we can still define things in order
149119 -- and generalize polymorphic functions when appropriate.
150− sccs <- Graph.stronglyConnComp <$> buildDefDict defs
120+ sccs <- Graph.stronglyConnComp <$> buildDefGraph defs
151121 let defss = map Graph.flattenSCC sccs
152122
153123 -- remove let-bound variables from the context
@@ -161,35 +131,57 @@ reorder (A.A ann expression) =
161131 return let'
162132
163133
134+ctors :: P.CanonicalPattern -> [String]
135+ctors (A.A _ pattern) =
136+ case pattern of
137+ P.Var _ ->
138+ []
139+
140+ P.Alias _ p ->
141+ ctors p
142+
143+ P.Record _ ->
144+ []
145+
146+ P.Anything ->
147+ []
148+
149+ P.Literal _ ->
150+ []
151+
152+ P.Data (V.Canonical home name) ps ->
153+ case home of
154+ V.Local -> name : rest
155+ V.BuiltIn -> rest
156+ V.Module _ -> rest
157+ where
158+ rest = concatMap ctors ps
159+
160+
161+bound :: P.CanonicalPattern -> State (Set.Set String) ()
162+bound pattern =
163+ let boundVars = P.boundVarSet pattern
164+ in
165+ modify (\freeVars -> Set.difference freeVars boundVars)
166+
167+
164168bindingReorder
165169 :: (P.CanonicalPattern, Canonical.Expr)
166170 -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
167−bindingReorder (pattern,expr) =
171+bindingReorder (pattern, expr) =
168172 do expr' <- reorder expr
169173 bound pattern
170174 mapM_ free (ctors pattern)
171175 return (pattern, expr')
172176
173177
174−reorderAndGetDependencies
175− :: Canonical.Def
176− -> State (Set.Set String) (Canonical.Def, [String])
177−reorderAndGetDependencies (Canonical.Definition pattern expr mType) =
178− do globalFrees <- get
179− -- work in a fresh environment
180− put Set.empty
181− expr' <- reorder expr
182− localFrees <- get
183− -- merge with global frees
184− modify (Set.union globalFrees)
185− return (Canonical.Definition pattern expr' mType, Set.toList localFrees)
186−
178+-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS
187179
188180-- This also reorders the all of the sub-expressions in the Def list.
189−buildDefDict
181+buildDefGraph
190182 :: [Canonical.Def]
191183 -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
192−buildDefDict defs =
184+buildDefGraph defs =
193185 do pdefsDeps <- mapM reorderAndGetDependencies defs
194186 return $ realDeps (addKey pdefsDeps)
195187 where
@@ -212,3 +204,17 @@ buildDefDict defs =
212204 varDict = variableToKeyMap pdefsDeps
213205 convert (pdef, key, deps) =
214206 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
207+
208+
209+reorderAndGetDependencies
210+ :: Canonical.Def
211+ -> State (Set.Set String) (Canonical.Def, [String])
212+reorderAndGetDependencies (Canonical.Definition pattern expr mType) =
213+ do globalFrees <- get
214+ -- work in a fresh environment
215+ put Set.empty
216+ expr' <- reorder expr
217+ localFrees <- get
218+ -- merge with global frees
219+ modify (Set.union globalFrees)
220+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees)