git.iko.soy/elk
on master help sign in
Switch to using new Def representation, get rid of `getPDefs` function which used to collect annotations and definitions.
06503feEvan Czaplicki
compiler/Transform/SortDefinitions.hs+46−102
compare with master
unifiedsplit
@@ -1,37 +1,25 @@
1−
1+{-# OPTIONS_GHC -Wall #-}
2−module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where
2+module Transform.SortDefinitions (sortDefs) where
3
3
4import Control.Monad.State
4import Control.Monad.State
5−import Control.Applicative ((<$>))
5+import Control.Applicative ((<$>),(<*>))
6−import qualified Data.Set as Set
7import qualified Data.Map as Map
6import qualified Data.Map as Map
8−import qualified SourceSyntax.Type as ST
9import SourceSyntax.Expression
7import SourceSyntax.Expression
10import SourceSyntax.Location
8import SourceSyntax.Location
11−import SourceSyntax.Pattern
9+import qualified SourceSyntax.Pattern as P
12import qualified Data.Graph as Graph
10import qualified Data.Graph as Graph
13−import qualified Data.Map as Map
11+import qualified Data.Set as Set
14import qualified Data.Maybe as Maybe
12import qualified Data.Maybe as Maybe
15
13
16−boundVars :: Pattern -> Set.Set String
17−boundVars pattern =
18− case pattern of
19− PVar x -> Set.singleton x
20− PAlias x p -> Set.insert x (boundVars p)
21− PData _ ps -> Set.unions (map boundVars ps)
22− PRecord fields -> Set.fromList fields
23− PAnything -> Set.empty
24− PLiteral _ -> Set.empty
25−
26−ctors :: Pattern -> [String]
14+ctors :: P.Pattern -> [String]
27ctors pattern =
15ctors pattern =
28 case pattern of
16 case pattern of
29− PVar x -> []
17+ P.PVar _ -> []
30− PAlias x p -> ctors p
18+ P.PAlias _ p -> ctors p
31− PData ctor ps -> ctor : concatMap ctors ps
19+ P.PData ctor ps -> ctor : concatMap ctors ps
32− PRecord fields -> []
20+ P.PRecord _ -> []
33− PAnything -> []
21+ P.PAnything -> []
34− PLiteral _ -> []
22+ P.PLiteral _ -> []
35
23
36free :: String -> State (Set.Set String) ()
24free :: String -> State (Set.Set String) ()
37free x = modify (Set.insert x)
25free x = modify (Set.insert x)
@@ -39,65 +27,59 @@ free x = modify (Set.insert x)
39bound :: Set.Set String -> State (Set.Set String) ()
27bound :: Set.Set String -> State (Set.Set String) ()
40bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
28bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
41
29
42−sortDefs :: LExpr t v -> LExpr t v
30+sortDefs :: LExpr -> LExpr
43sortDefs expr = evalState (reorder expr) Set.empty
31sortDefs expr = evalState (reorder expr) Set.empty
44
32
45−flattenLets defs lexpr@(L _ expr) =
46− case expr of
47− Let ds body -> flattenLets (defs ++ ds) body
48− _ -> (defs, lexpr)
49−
50−
51−reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)
33+reorder :: LExpr -> State (Set.Set String) LExpr
52−reorder lexpr@(L s expr) =
34+reorder (L s expr) =
53− L s `liftM`
35+ L s <$>
54 case expr of
36 case expr of
55 -- Be careful adding and restricting freeVars
37 -- Be careful adding and restricting freeVars
56 Var x -> free x >> return expr
38 Var x -> free x >> return expr
57
39
58 Lambda p e ->
40 Lambda p e ->
59− uncurry Lambda `liftM` bindingReorder (p,e)
41+ uncurry Lambda <$> bindingReorder (p,e)
60
42
61 Binop op e1 e2 ->
43 Binop op e1 e2 ->
62 do free op
44 do free op
63− Binop op `liftM` reorder e1 `ap` reorder e2
45+ Binop op <$> reorder e1 <*> reorder e2
64
46
65 Case e cases ->
47 Case e cases ->
66− Case `liftM` reorder e `ap` mapM bindingReorder cases
48+ Case <$> reorder e <*> mapM bindingReorder cases
67
49
68 Data name es ->
50 Data name es ->
69 do free name
51 do free name
70− Data name `liftM` mapM reorder es
52+ Data name <$> mapM reorder es
71
53
72 -- Just pipe the reorder though
54 -- Just pipe the reorder though
73 Literal _ -> return expr
55 Literal _ -> return expr
74
56
75 Range e1 e2 ->
57 Range e1 e2 ->
76− Range `liftM` reorder e1 `ap` reorder e2
58+ Range <$> reorder e1 <*> reorder e2
77
59
78 ExplicitList es ->
60 ExplicitList es ->
79− ExplicitList `liftM` mapM reorder es
61+ ExplicitList <$> mapM reorder es
80
62
81 App e1 e2 ->
63 App e1 e2 ->
82− App `liftM` reorder e1 `ap` reorder e2
64+ App <$> reorder e1 <*> reorder e2
83
65
84 MultiIf branches ->
66 MultiIf branches ->
85− MultiIf `liftM` mapM reorderPair branches
67+ MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches
86
68
87 Access e lbl ->
69 Access e lbl ->
88− Access `liftM` reorder e `ap` return lbl
70+ Access <$> reorder e <*> return lbl
89
71
90 Remove e lbl ->
72 Remove e lbl ->
91− Remove `liftM` reorder e `ap` return lbl
73+ Remove <$> reorder e <*> return lbl
92
74
93 Insert e lbl v ->
75 Insert e lbl v ->
94− Insert `liftM` reorder e `ap` return lbl `ap` reorder v
76+ Insert <$> reorder e <*> return lbl <*> reorder v
95
77
96 Modify e fields ->
78 Modify e fields ->
97− Modify `liftM` reorder e `ap` mapM reorderField fields
79+ Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields
98
80
99 Record fields ->
81 Record fields ->
100− Record `liftM` mapM reorderField fields
82+ Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields
101
83
102 Markdown uid md es -> Markdown uid md <$> mapM reorder es
84 Markdown uid md es -> Markdown uid md <$> mapM reorder es
103
85
@@ -113,48 +95,24 @@ reorder lexpr@(L s expr) =
113 let defss = map Graph.flattenSCC sccs
95 let defss = map Graph.flattenSCC sccs
114
96
115 -- remove let-bound variables from the context
97 -- remove let-bound variables from the context
116− let getPatterns def =
117− case def of
118− Def pattern _ -> pattern
119− TypeAnnotation name _ -> PVar name
120− forM (map getPatterns defs) $ \pattern -> do
98+ forM_ defs $ \(Definition pattern _ _) -> do
121− bound (boundVars pattern)
99+ bound (P.boundVars pattern)
122 mapM free (ctors pattern)
100 mapM free (ctors pattern)
123
101
124− let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)
125− L _ let' = foldr addDefs body' defss
102+ let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
126
103
127 return let'
104 return let'
128
105
129− where
130− toDefs def =
131− case def of
132− (pattern, expr, Nothing) -> [ Def pattern expr ]
133− (PVar name, expr, Just tipe) ->
134− [ TypeAnnotation name tipe, Def (PVar name) expr ]
135− _ -> error $ unlines
136− [ "The impossible occurred."
137− , "Please report an issue at <https://github.com/evancz/Elm/issues>."
138− , "Be very descriptive because something quite weird probably happened." ]
139−
140−reorderField (label, expr) =
141− (,) label `liftM` reorder expr
142−
143−reorderPair (e1,e2) =
144− (,) `liftM` reorder e1 `ap` reorder e2
145−
146−bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)
106+bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
147bindingReorder (pattern,expr) =
107bindingReorder (pattern,expr) =
148 do expr' <- reorder expr
108 do expr' <- reorder expr
149− bound (boundVars pattern)
109+ bound (P.boundVars pattern)
150− mapM free (ctors pattern)
110+ mapM_ free (ctors pattern)
151 return (pattern, expr')
111 return (pattern, expr')
152
112
153
113
154−type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)
155−
156−reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])
114+reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])
157−reorderAndGetDependencies (pattern, expr, mType) =
115+reorderAndGetDependencies (Definition pattern expr mType) =
158 do globalFrees <- get
116 do globalFrees <- get
159 -- work in a fresh environment
117 -- work in a fresh environment
160 put Set.empty
118 put Set.empty
@@ -162,44 +120,30 @@ reorderAndGetDependencies (pattern, expr, mType) =
162 localFrees <- get
120 localFrees <- get
163 -- merge with global frees
121 -- merge with global frees
164 modify (Set.union globalFrees)
122 modify (Set.union globalFrees)
165− return ((pattern, expr', mType), Set.toList localFrees)
123+ return (Definition pattern expr' mType, Set.toList localFrees)
166
124
167
125
168-- This also reorders the all of the sub-expressions in the Def list.
126-- This also reorders the all of the sub-expressions in the Def list.
169−buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]
127+buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]
170buildDefDict defs =
128buildDefDict defs =
171− do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
129+ do pdefsDeps <- mapM reorderAndGetDependencies defs
172 return $ realDeps (addKey pdefsDeps)
130 return $ realDeps (addKey pdefsDeps)
173
131
174 where
132 where
175− getPDefs :: [Def t v] -> [PDef t v]
176− getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $
177− Map.toList $ go defs Map.empty Map.empty
178− where
179− go [] ds ts =
180− Map.unions [ Map.difference ds ts
181− , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]
182−
183− go (def:defs) ds ts =
184− case def of
185− Def p e -> go defs (Map.insert p (e, Nothing) ds) ts
186− TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)
187−
188− addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]
133+ addKey :: [(Def, [String])] -> [(Def, Int, [String])]
189 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
134 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
190
135
191− variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
136+ variableToKey :: (Def, Int, [String]) -> [(String, Int)]
192− variableToKey ((pattern, _, _), key, _) =
137+ variableToKey (Definition pattern _ _, key, _) =
193− [ (var, key) | var <- Set.toList (boundVars pattern) ]
138+ [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
194
139
195− variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
140+ variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int
196 variableToKeyMap pdefsDeps =
141 variableToKeyMap pdefsDeps =
197 Map.fromList (concatMap variableToKey pdefsDeps)
142 Map.fromList (concatMap variableToKey pdefsDeps)
198
143
199− realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
144+ realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]
200 realDeps pdefsDeps = map convert pdefsDeps
145 realDeps pdefsDeps = map convert pdefsDeps
201 where
146 where
202 varDict = variableToKeyMap pdefsDeps
147 varDict = variableToKeyMap pdefsDeps
203 convert (pdef, key, deps) =
148 convert (pdef, key, deps) =
204 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
149 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
205−