@@ -1,11 +1,15 @@
11
2−module Transform.SortDefinitions (boundVars) where
2+module Transform.SortDefinitions (sortDefs) where
33
44import Control.Monad.State
5+import Control.Applicative ((<$>))
56import qualified Data.Set as Set
67import qualified Data.Map as Map
8+import qualified SourceSyntax.Type as ST
79import SourceSyntax.Everything
8−
10+import qualified Data.Graph as Graph
11+import qualified Data.Map as Map
12+import qualified Data.Maybe as Maybe
913
1014boundVars :: Pattern -> Set.Set String
1115boundVars pattern =
@@ -17,38 +21,19 @@ boundVars pattern =
1721 PAnything -> Set.empty
1822 PLiteral _ -> Set.empty
1923
24+free :: String -> State (Set.Set String) ()
2025free x = modify (Set.insert x)
26+
27+bound :: Set.Set String -> State (Set.Set String) ()
2128bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
2229
23−reorderAndGetDependencies pattern expr =
24− do globalFrees <- get
25− expr' <- reorder expr
26− localFrees <- get
27− modify (Set.union globalFrees)
28− let addDep var deps = Map.insert var localFrees deps
29− dependencies = Set.foldr addDep Map.empty (boundVars pattern)
30− return (expr', dependencies)
30+sortDefs :: LExpr t v -> LExpr t v
31+sortDefs expr = evalState (reorder expr) Set.empty
3132
3233reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)
3334reorder lexpr@(L a b expr) =
3435 L a b `liftM`
3536 case expr of
36−{--
37− -- Actually do some reordering
38− Let defs body ->
39− do -- swap in a fresh environment
40−
41− -- swap in the old environment
42− body' <- reorder body
43− bound (boundVars (patterns defs))
44− Let `liftM` defs' `ap` body'
45−
46− where
47− patterns = flip concatMap defs $
48− case def of
49− Def pattern _ -> [pattern]
50− TypeAnnotation _ _ -> []
51−--}
5237 -- Be careful adding and restricting freeVars
5338 Var x -> free x >> return expr
5439
@@ -98,6 +83,35 @@ reorder lexpr@(L a b expr) =
9883
9984 Markdown _ -> return expr
10085
86+ -- Actually do some reordering
87+ Let defs body ->
88+ do body' <- reorder body
89+
90+ -- Sort defs into strongly connected components.This
91+ -- allows the programmer to write definitions in whatever
92+ -- order they please, we can still define things in order
93+ -- and generalize polymorphic functions when appropriate.
94+ sccs <- Graph.stronglyConnComp <$> buildDefDict defs
95+ let defss = map Graph.flattenSCC sccs
96+
97+ -- remove let-bound variables from the context
98+ let getPatterns def =
99+ case def of
100+ Def pattern _ -> pattern
101+ TypeAnnotation name _ -> PVar name
102+ mapM (bound . boundVars . getPatterns) defs
103+
104+ let addDefs ds bod = L a b (Let (concatMap toDefs ds) bod)
105+ where
106+ toDefs (pattern, expr, Nothing) = [ Def pattern expr ]
107+ toDefs (PVar name, expr, Just tipe) =
108+ [ TypeAnnotation name tipe, Def (PVar name) expr ]
109+
110+ L _ _ let' = foldr addDefs body' defss
111+
112+ return let'
113+
114+
101115reorderField (label, expr) =
102116 (,) label `liftM` reorder expr
103117
@@ -110,3 +124,56 @@ bindingReorder (pattern,expr) =
110124 bound (boundVars pattern)
111125 return (pattern, expr')
112126
127+
128+type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)
129+
130+reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])
131+reorderAndGetDependencies (pattern, expr, mType) =
132+ do globalFrees <- get
133+ -- work in a fresh environment
134+ put Set.empty
135+ expr' <- reorder expr
136+ localFrees <- get
137+ -- merge with global frees
138+ modify (Set.union globalFrees)
139+ return ((pattern, expr', mType), Set.toList localFrees)
140+
141+
142+-- This also reorders the all of the sub-expressions in the Def list.
143+buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]
144+buildDefDict defs =
145+ do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
146+ return $ realDeps (addKey pdefsDeps)
147+
148+ where
149+ getPDefs :: [Def t v] -> [PDef t v]
150+ getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $
151+ Map.toList $ go defs Map.empty Map.empty
152+ where
153+ go [] ds ts =
154+ Map.unions [ Map.difference ds ts
155+ , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]
156+
157+ go (def:defs) ds ts =
158+ case def of
159+ Def p e -> go defs (Map.insert p (e, Nothing) ds) ts
160+ TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)
161+
162+ addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]
163+ addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
164+
165+ variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
166+ variableToKey ((pattern, _, _), key, _) =
167+ [ (var, key) | var <- Set.toList (boundVars pattern) ]
168+
169+ variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
170+ variableToKeyMap pdefsDeps =
171+ Map.fromList (concatMap variableToKey pdefsDeps)
172+
173+ realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
174+ realDeps pdefsDeps = map convert pdefsDeps
175+ where
176+ varDict = variableToKeyMap pdefsDeps
177+ convert (pdef, key, deps) =
178+ (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
179+