git.iko.soy/elk
on 88fce69 help sign in
elk/compiler/Transform/SortDefinitions.hs
207 lines 6.8 kB history raw
2{-# OPTIONS -Wall #-}
4module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where
6import Control.Monad.State
7import Control.Applicative ((<$>))
8import qualified Data.Set as Set
9import qualified Data.Map as Map
10import qualified SourceSyntax.Type as ST
11import SourceSyntax.Everything
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 GLShader _ _ -> return expr
106 -- Actually do some reordering
107 Let defs body ->
108 do body' <- reorder body
110 -- Sort defs into strongly connected components.This
111 -- allows the programmer to write definitions in whatever
112 -- order they please, we can still define things in order
113 -- and generalize polymorphic functions when appropriate.
114 sccs <- Graph.stronglyConnComp <$> buildDefDict defs
115 let defss = map Graph.flattenSCC sccs
117 -- remove let-bound variables from the context
118 let getPatterns def =
119 case def of
120 Def pattern _ -> pattern
121 TypeAnnotation name _ -> PVar name
122 forM (map getPatterns defs) $ \pattern -> do
123 bound (boundVars pattern)
124 mapM free (ctors pattern)
126 let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)
127 L _ let' = foldr addDefs body' defss
129 return let'
131 where
132 toDefs def =
133 case def of
134 (pattern, expr, Nothing) -> [ Def pattern expr ]
135 (PVar name, expr, Just tipe) ->
136 [ TypeAnnotation name tipe, Def (PVar name) expr ]
137 _ -> error $ unlines
138 [ "The impossible occurred."
139 , "Please report an issue at <https://github.com/evancz/Elm/issues>."
140 , "Be very descriptive because something quite weird probably happened." ]
142reorderField (label, expr) =
143 (,) label `liftM` reorder expr
145reorderPair (e1,e2) =
146 (,) `liftM` reorder e1 `ap` reorder e2
148bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)
149bindingReorder (pattern,expr) =
150 do expr' <- reorder expr
151 bound (boundVars pattern)
152 mapM free (ctors pattern)
153 return (pattern, expr')
156type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)
158reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])
159reorderAndGetDependencies (pattern, expr, mType) =
160 do globalFrees <- get
161 -- work in a fresh environment
162 put Set.empty
163 expr' <- reorder expr
164 localFrees <- get
165 -- merge with global frees
166 modify (Set.union globalFrees)
167 return ((pattern, expr', mType), Set.toList localFrees)
170-- This also reorders the all of the sub-expressions in the Def list.
171buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]
172buildDefDict defs =
173 do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
174 return $ realDeps (addKey pdefsDeps)
176 where
177 getPDefs :: [Def t v] -> [PDef t v]
178 getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $
179 Map.toList $ go defs Map.empty Map.empty
180 where
181 go [] ds ts =
182 Map.unions [ Map.difference ds ts
183 , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]
185 go (def:defs) ds ts =
186 case def of
187 Def p e -> go defs (Map.insert p (e, Nothing) ds) ts
188 TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)
190 addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]
191 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
193 variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
194 variableToKey ((pattern, _, _), key, _) =
195 [ (var, key) | var <- Set.toList (boundVars pattern) ]
197 variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
198 variableToKeyMap pdefsDeps =
199 Map.fromList (concatMap variableToKey pdefsDeps)
201 realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
202 realDeps pdefsDeps = map convert pdefsDeps
203 where
204 varDict = variableToKeyMap pdefsDeps
205 convert (pdef, key, deps) =
206 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)