git.iko.soy/elk
on cf016ea help sign in
elk/compiler/Transform/SortDefinitions.hs
209 lines 6.9 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.Expression
12import SourceSyntax.Location
13import SourceSyntax.Pattern
14import qualified Data.Graph as Graph
15import qualified Data.Map as Map
16import qualified Data.Maybe as Maybe
18boundVars :: Pattern -> Set.Set String
19boundVars pattern =
20 case pattern of
21 PVar x -> Set.singleton x
22 PAlias x p -> Set.insert x (boundVars p)
23 PData _ ps -> Set.unions (map boundVars ps)
24 PRecord fields -> Set.fromList fields
25 PAnything -> Set.empty
26 PLiteral _ -> Set.empty
28ctors :: Pattern -> [String]
29ctors pattern =
30 case pattern of
31 PVar x -> []
32 PAlias x p -> ctors p
33 PData ctor ps -> ctor : concatMap ctors ps
34 PRecord fields -> []
35 PAnything -> []
36 PLiteral _ -> []
38free :: String -> State (Set.Set String) ()
39free x = modify (Set.insert x)
41bound :: Set.Set String -> State (Set.Set String) ()
42bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
44sortDefs :: LExpr t v -> LExpr t v
45sortDefs expr = evalState (reorder expr) Set.empty
47flattenLets defs lexpr@(L _ expr) =
48 case expr of
49 Let ds body -> flattenLets (defs ++ ds) body
50 _ -> (defs, lexpr)
53reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)
54reorder lexpr@(L s expr) =
55 L s `liftM`
56 case expr of
57 -- Be careful adding and restricting freeVars
58 Var x -> free x >> return expr
60 Lambda p e ->
61 uncurry Lambda `liftM` bindingReorder (p,e)
63 Binop op e1 e2 ->
64 do free op
65 Binop op `liftM` reorder e1 `ap` reorder e2
67 Case e cases ->
68 Case `liftM` reorder e `ap` mapM bindingReorder cases
70 Data name es ->
71 do free name
72 Data name `liftM` mapM reorder es
74 -- Just pipe the reorder though
75 Literal _ -> return expr
77 Range e1 e2 ->
78 Range `liftM` reorder e1 `ap` reorder e2
80 ExplicitList es ->
81 ExplicitList `liftM` mapM reorder es
83 App e1 e2 ->
84 App `liftM` reorder e1 `ap` reorder e2
86 MultiIf branches ->
87 MultiIf `liftM` mapM reorderPair branches
89 Access e lbl ->
90 Access `liftM` reorder e `ap` return lbl
92 Remove e lbl ->
93 Remove `liftM` reorder e `ap` return lbl
95 Insert e lbl v ->
96 Insert `liftM` reorder e `ap` return lbl `ap` reorder v
98 Modify e fields ->
99 Modify `liftM` reorder e `ap` mapM reorderField fields
101 Record fields ->
102 Record `liftM` mapM reorderField fields
104 Markdown uid md es -> Markdown uid md <$> mapM reorder es
106 GLShader _ _ -> return expr
108 -- Actually do some reordering
109 Let defs body ->
110 do body' <- reorder body
112 -- Sort defs into strongly connected components.This
113 -- allows the programmer to write definitions in whatever
114 -- order they please, we can still define things in order
115 -- and generalize polymorphic functions when appropriate.
116 sccs <- Graph.stronglyConnComp <$> buildDefDict defs
117 let defss = map Graph.flattenSCC sccs
119 -- remove let-bound variables from the context
120 let getPatterns def =
121 case def of
122 Def pattern _ -> pattern
123 TypeAnnotation name _ -> PVar name
124 forM (map getPatterns defs) $ \pattern -> do
125 bound (boundVars pattern)
126 mapM free (ctors pattern)
128 let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)
129 L _ let' = foldr addDefs body' defss
131 return let'
133 where
134 toDefs def =
135 case def of
136 (pattern, expr, Nothing) -> [ Def pattern expr ]
137 (PVar name, expr, Just tipe) ->
138 [ TypeAnnotation name tipe, Def (PVar name) expr ]
139 _ -> error $ unlines
140 [ "The impossible occurred."
141 , "Please report an issue at <https://github.com/evancz/Elm/issues>."
142 , "Be very descriptive because something quite weird probably happened." ]
144reorderField (label, expr) =
145 (,) label `liftM` reorder expr
147reorderPair (e1,e2) =
148 (,) `liftM` reorder e1 `ap` reorder e2
150bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)
151bindingReorder (pattern,expr) =
152 do expr' <- reorder expr
153 bound (boundVars pattern)
154 mapM free (ctors pattern)
155 return (pattern, expr')
158type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)
160reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])
161reorderAndGetDependencies (pattern, expr, mType) =
162 do globalFrees <- get
163 -- work in a fresh environment
164 put Set.empty
165 expr' <- reorder expr
166 localFrees <- get
167 -- merge with global frees
168 modify (Set.union globalFrees)
169 return ((pattern, expr', mType), Set.toList localFrees)
172-- This also reorders the all of the sub-expressions in the Def list.
173buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]
174buildDefDict defs =
175 do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
176 return $ realDeps (addKey pdefsDeps)
178 where
179 getPDefs :: [Def t v] -> [PDef t v]
180 getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $
181 Map.toList $ go defs Map.empty Map.empty
182 where
183 go [] ds ts =
184 Map.unions [ Map.difference ds ts
185 , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]
187 go (def:defs) ds ts =
188 case def of
189 Def p e -> go defs (Map.insert p (e, Nothing) ds) ts
190 TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)
192 addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]
193 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
195 variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
196 variableToKey ((pattern, _, _), key, _) =
197 [ (var, key) | var <- Set.toList (boundVars pattern) ]
199 variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
200 variableToKeyMap pdefsDeps =
201 Map.fromList (concatMap variableToKey pdefsDeps)
203 realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
204 realDeps pdefsDeps = map convert pdefsDeps
205 where
206 varDict = variableToKeyMap pdefsDeps
207 convert (pdef, key, deps) =
208 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)