git.iko.soy/elk
on 07187bd help sign in
elk/compiler/Transform/SortDefinitions.hs
201 lines 6.8 kB history raw
2module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where
4import Control.Monad.State
5import Control.Applicative ((<$>))
6import qualified Data.Set as Set
7import qualified Data.Map as Map
8import qualified SourceSyntax.Type as ST
9import SourceSyntax.Everything
10import qualified Data.Graph as Graph
11import qualified Data.Map as Map
12import qualified Data.Maybe as Maybe
14boundVars :: Pattern -> Set.Set String
15boundVars pattern =
16 case pattern of
17 PVar x -> Set.singleton x
18 PAlias x p -> Set.insert x (boundVars p)
19 PData _ ps -> Set.unions (map boundVars ps)
20 PRecord fields -> Set.fromList fields
21 PAnything -> Set.empty
22 PLiteral _ -> Set.empty
24ctors :: Pattern -> [String]
25ctors pattern =
26 case pattern of
27 PVar x -> []
28 PAlias x p -> ctors p
29 PData ctor ps -> ctor : concatMap ctors ps
30 PRecord fields -> []
31 PAnything -> []
32 PLiteral _ -> []
34free :: String -> State (Set.Set String) ()
35free x = modify (Set.insert x)
37bound :: Set.Set String -> State (Set.Set String) ()
38bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
40sortDefs :: LExpr t v -> LExpr t v
41sortDefs expr = evalState (reorder expr) Set.empty
43flattenLets defs lexpr@(L _ expr) =
44 case expr of
45 Let ds body -> flattenLets (defs ++ ds) body
46 _ -> (defs, lexpr)
49reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)
50reorder lexpr@(L s expr) =
51 L s `liftM`
52 case expr of
53 -- Be careful adding and restricting freeVars
54 Var x -> free x >> return expr
56 Lambda p e ->
57 uncurry Lambda `liftM` bindingReorder (p,e)
59 Binop op e1 e2 ->
60 do free op
61 Binop op `liftM` reorder e1 `ap` reorder e2
63 Case e cases ->
64 Case `liftM` reorder e `ap` mapM bindingReorder cases
66 Data name es ->
67 do free name
68 Data name `liftM` mapM reorder es
70 -- Just pipe the reorder though
71 Literal _ -> return expr
73 Range e1 e2 ->
74 Range `liftM` reorder e1 `ap` reorder e2
76 ExplicitList es ->
77 ExplicitList `liftM` mapM reorder es
79 App e1 e2 ->
80 App `liftM` reorder e1 `ap` reorder e2
82 MultiIf branches ->
83 MultiIf `liftM` mapM reorderPair branches
85 Access e lbl ->
86 Access `liftM` reorder e `ap` return lbl
88 Remove e lbl ->
89 Remove `liftM` reorder e `ap` return lbl
91 Insert e lbl v ->
92 Insert `liftM` reorder e `ap` return lbl `ap` reorder v
94 Modify e fields ->
95 Modify `liftM` reorder e `ap` mapM reorderField fields
97 Record fields ->
98 Record `liftM` mapM reorderField fields
100 Markdown uid md es -> Markdown uid md <$> mapM reorder es
102 -- Actually do some reordering
103 Let defs body ->
104 do body' <- reorder body
106 -- Sort defs into strongly connected components.This
107 -- allows the programmer to write definitions in whatever
108 -- order they please, we can still define things in order
109 -- and generalize polymorphic functions when appropriate.
110 sccs <- Graph.stronglyConnComp <$> buildDefDict defs
111 let defss = map Graph.flattenSCC sccs
113 -- remove let-bound variables from the context
114 let getPatterns def =
115 case def of
116 Def pattern _ -> pattern
117 TypeAnnotation name _ -> PVar name
118 forM (map getPatterns defs) $ \pattern -> do
119 bound (boundVars pattern)
120 mapM free (ctors pattern)
122 let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)
123 where
124 toDefs (pattern, expr, Nothing) = [ Def pattern expr ]
125 toDefs (PVar name, expr, Just tipe) =
126 [ TypeAnnotation name tipe, Def (PVar name) expr ]
127 -- This case really shouldn't happen since we've
128 -- removed everything but Def's and PVars above.
129 toDefs (_,_,_) = error "The impossible occurred. Please report an issue at https://github.com/evancz/Elm/issues describing what led to this error message."
131 L _ let' = foldr addDefs body' defss
133 return let'
136reorderField (label, expr) =
137 (,) label `liftM` reorder expr
139reorderPair (e1,e2) =
140 (,) `liftM` reorder e1 `ap` reorder e2
142bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)
143bindingReorder (pattern,expr) =
144 do expr' <- reorder expr
145 bound (boundVars pattern)
146 mapM free (ctors pattern)
147 return (pattern, expr')
150type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)
152reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])
153reorderAndGetDependencies (pattern, expr, mType) =
154 do globalFrees <- get
155 -- work in a fresh environment
156 put Set.empty
157 expr' <- reorder expr
158 localFrees <- get
159 -- merge with global frees
160 modify (Set.union globalFrees)
161 return ((pattern, expr', mType), Set.toList localFrees)
164-- This also reorders the all of the sub-expressions in the Def list.
165buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]
166buildDefDict defs =
167 do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
168 return $ realDeps (addKey pdefsDeps)
170 where
171 getPDefs :: [Def t v] -> [PDef t v]
172 getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $
173 Map.toList $ go defs Map.empty Map.empty
174 where
175 go [] ds ts =
176 Map.unions [ Map.difference ds ts
177 , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]
179 go (def:defs) ds ts =
180 case def of
181 Def p e -> go defs (Map.insert p (e, Nothing) ds) ts
182 TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)
184 addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]
185 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
187 variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
188 variableToKey ((pattern, _, _), key, _) =
189 [ (var, key) | var <- Set.toList (boundVars pattern) ]
191 variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
192 variableToKeyMap pdefsDeps =
193 Map.fromList (concatMap variableToKey pdefsDeps)
195 realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
196 realDeps pdefsDeps = map convert pdefsDeps
197 where
198 varDict = variableToKeyMap pdefsDeps
199 convert (pdef, key, deps) =
200 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)