git.iko.soy/elk
on 578dfb8 help sign in
elk/compiler/Transform/SortDefinitions.hs
205 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.Expression
10import SourceSyntax.Location
11import SourceSyntax.Pattern
12import qualified Data.Graph as Graph
13import qualified Data.Map as Map
14import qualified Data.Maybe as Maybe
16boundVars :: Pattern -> Set.Set String
17boundVars 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
26ctors :: Pattern -> [String]
27ctors pattern =
28 case pattern of
29 PVar x -> []
30 PAlias x p -> ctors p
31 PData ctor ps -> ctor : concatMap ctors ps
32 PRecord fields -> []
33 PAnything -> []
34 PLiteral _ -> []
36free :: String -> State (Set.Set String) ()
37free x = modify (Set.insert x)
39bound :: Set.Set String -> State (Set.Set String) ()
40bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
42sortDefs :: LExpr t v -> LExpr t v
43sortDefs expr = evalState (reorder expr) Set.empty
45flattenLets defs lexpr@(L _ expr) =
46 case expr of
47 Let ds body -> flattenLets (defs ++ ds) body
48 _ -> (defs, lexpr)
51reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)
52reorder lexpr@(L s expr) =
53 L s `liftM`
54 case expr of
55 -- Be careful adding and restricting freeVars
56 Var x -> free x >> return expr
58 Lambda p e ->
59 uncurry Lambda `liftM` bindingReorder (p,e)
61 Binop op e1 e2 ->
62 do free op
63 Binop op `liftM` reorder e1 `ap` reorder e2
65 Case e cases ->
66 Case `liftM` reorder e `ap` mapM bindingReorder cases
68 Data name es ->
69 do free name
70 Data name `liftM` mapM reorder es
72 -- Just pipe the reorder though
73 Literal _ -> return expr
75 Range e1 e2 ->
76 Range `liftM` reorder e1 `ap` reorder e2
78 ExplicitList es ->
79 ExplicitList `liftM` mapM reorder es
81 App e1 e2 ->
82 App `liftM` reorder e1 `ap` reorder e2
84 MultiIf branches ->
85 MultiIf `liftM` mapM reorderPair branches
87 Access e lbl ->
88 Access `liftM` reorder e `ap` return lbl
90 Remove e lbl ->
91 Remove `liftM` reorder e `ap` return lbl
93 Insert e lbl v ->
94 Insert `liftM` reorder e `ap` return lbl `ap` reorder v
96 Modify e fields ->
97 Modify `liftM` reorder e `ap` mapM reorderField fields
99 Record fields ->
100 Record `liftM` mapM reorderField fields
102 Markdown uid md es -> Markdown uid md <$> mapM reorder es
104 -- Actually do some reordering
105 Let defs body ->
106 do body' <- reorder body
108 -- Sort defs into strongly connected components.This
109 -- allows the programmer to write definitions in whatever
110 -- order they please, we can still define things in order
111 -- and generalize polymorphic functions when appropriate.
112 sccs <- Graph.stronglyConnComp <$> buildDefDict defs
113 let defss = map Graph.flattenSCC sccs
115 -- 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
121 bound (boundVars pattern)
122 mapM free (ctors pattern)
124 let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)
125 L _ let' = foldr addDefs body' defss
127 return let'
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." ]
140reorderField (label, expr) =
141 (,) label `liftM` reorder expr
143reorderPair (e1,e2) =
144 (,) `liftM` reorder e1 `ap` reorder e2
146bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)
147bindingReorder (pattern,expr) =
148 do expr' <- reorder expr
149 bound (boundVars pattern)
150 mapM free (ctors pattern)
151 return (pattern, expr')
154type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)
156reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])
157reorderAndGetDependencies (pattern, expr, mType) =
158 do globalFrees <- get
159 -- work in a fresh environment
160 put Set.empty
161 expr' <- reorder expr
162 localFrees <- get
163 -- merge with global frees
164 modify (Set.union globalFrees)
165 return ((pattern, expr', mType), Set.toList localFrees)
168-- This also reorders the all of the sub-expressions in the Def list.
169buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]
170buildDefDict defs =
171 do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
172 return $ realDeps (addKey pdefsDeps)
174 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 ]
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)
188 addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]
189 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
191 variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
192 variableToKey ((pattern, _, _), key, _) =
193 [ (var, key) | var <- Set.toList (boundVars pattern) ]
195 variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
196 variableToKeyMap pdefsDeps =
197 Map.fromList (concatMap variableToKey pdefsDeps)
199 realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
200 realDeps pdefsDeps = map convert pdefsDeps
201 where
202 varDict = variableToKeyMap pdefsDeps
203 convert (pdef, key, deps) =
204 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)