@@ -1,37 +1,25 @@
1−
2−module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.SortDefinitions (sortDefs) where
33
44import Control.Monad.State
5−import Control.Applicative ((<$>))
6−import qualified Data.Set as Set
5+import Control.Applicative ((<$>),(<*>))
76import qualified Data.Map as Map
8−import qualified SourceSyntax.Type as ST
97import SourceSyntax.Expression
108import SourceSyntax.Location
11−import SourceSyntax.Pattern
9+import qualified SourceSyntax.Pattern as P
1210import qualified Data.Graph as Graph
13−import qualified Data.Map as Map
11+import qualified Data.Set as Set
1412import qualified Data.Maybe as Maybe
1513
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]
2715ctors pattern =
2816 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 _ -> []
17+ P.PVar _ -> []
18+ P.PAlias _ p -> ctors p
19+ P.PData ctor ps -> ctor : concatMap ctors ps
20+ P.PRecord _ -> []
21+ P.PAnything -> []
22+ P.PLiteral _ -> []
3523
3624free :: String -> State (Set.Set String) ()
3725free x = modify (Set.insert x)
@@ -39,65 +27,59 @@ free x = modify (Set.insert x)
3927bound :: Set.Set String -> State (Set.Set String) ()
4028bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
4129
42−sortDefs :: LExpr t v -> LExpr t v
30+sortDefs :: LExpr -> LExpr
4331sortDefs expr = evalState (reorder expr) Set.empty
4432
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)
52−reorder lexpr@(L s expr) =
53− L s `liftM`
33+reorder :: LExpr -> State (Set.Set String) LExpr
34+reorder (L s expr) =
35+ L s <$>
5436 case expr of
5537 -- Be careful adding and restricting freeVars
5638 Var x -> free x >> return expr
5739
5840 Lambda p e ->
59− uncurry Lambda `liftM` bindingReorder (p,e)
41+ uncurry Lambda <$> bindingReorder (p,e)
6042
6143 Binop op e1 e2 ->
6244 do free op
63− Binop op `liftM` reorder e1 `ap` reorder e2
45+ Binop op <$> reorder e1 <*> reorder e2
6446
6547 Case e cases ->
66− Case `liftM` reorder e `ap` mapM bindingReorder cases
48+ Case <$> reorder e <*> mapM bindingReorder cases
6749
6850 Data name es ->
6951 do free name
70− Data name `liftM` mapM reorder es
52+ Data name <$> mapM reorder es
7153
7254 -- Just pipe the reorder though
7355 Literal _ -> return expr
7456
7557 Range e1 e2 ->
76− Range `liftM` reorder e1 `ap` reorder e2
58+ Range <$> reorder e1 <*> reorder e2
7759
7860 ExplicitList es ->
79− ExplicitList `liftM` mapM reorder es
61+ ExplicitList <$> mapM reorder es
8062
8163 App e1 e2 ->
82− App `liftM` reorder e1 `ap` reorder e2
64+ App <$> reorder e1 <*> reorder e2
8365
8466 MultiIf branches ->
85− MultiIf `liftM` mapM reorderPair branches
67+ MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches
8668
8769 Access e lbl ->
88− Access `liftM` reorder e `ap` return lbl
70+ Access <$> reorder e <*> return lbl
8971
9072 Remove e lbl ->
91− Remove `liftM` reorder e `ap` return lbl
73+ Remove <$> reorder e <*> return lbl
9274
9375 Insert e lbl v ->
94− Insert `liftM` reorder e `ap` return lbl `ap` reorder v
76+ Insert <$> reorder e <*> return lbl <*> reorder v
9577
9678 Modify e fields ->
97− Modify `liftM` reorder e `ap` mapM reorderField fields
79+ Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields
9880
9981 Record fields ->
100− Record `liftM` mapM reorderField fields
82+ Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields
10183
10284 Markdown uid md es -> Markdown uid md <$> mapM reorder es
10385
@@ -113,48 +95,24 @@ reorder lexpr@(L s expr) =
11395 let defss = map Graph.flattenSCC sccs
11496
11597 -- 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)
98+ forM_ defs $ \(Definition pattern _ _) -> do
99+ bound (P.boundVars pattern)
122100 mapM free (ctors pattern)
123101
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
126103
127104 return let'
128105
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)
147107bindingReorder (pattern,expr) =
148108 do expr' <- reorder expr
149− bound (boundVars pattern)
150− mapM free (ctors pattern)
109+ bound (P.boundVars pattern)
110+ mapM_ free (ctors pattern)
151111 return (pattern, expr')
152112
153113
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])
157−reorderAndGetDependencies (pattern, expr, mType) =
114+reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])
115+reorderAndGetDependencies (Definition pattern expr mType) =
158116 do globalFrees <- get
159117 -- work in a fresh environment
160118 put Set.empty
@@ -162,44 +120,30 @@ reorderAndGetDependencies (pattern, expr, mType) =
162120 localFrees <- get
163121 -- merge with global frees
164122 modify (Set.union globalFrees)
165− return ((pattern, expr', mType), Set.toList localFrees)
123+ return (Definition pattern expr' mType, Set.toList localFrees)
166124
167125
168126-- 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])]
170128buildDefDict defs =
171− do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
129+ do pdefsDeps <- mapM reorderAndGetDependencies defs
172130 return $ realDeps (addKey pdefsDeps)
173131
174132 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])]
189134 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
190135
191− variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
192− variableToKey ((pattern, _, _), key, _) =
193− [ (var, key) | var <- Set.toList (boundVars pattern) ]
136+ variableToKey :: (Def, Int, [String]) -> [(String, Int)]
137+ variableToKey (Definition pattern _ _, key, _) =
138+ [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
194139
195− variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
140+ variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int
196141 variableToKeyMap pdefsDeps =
197142 Map.fromList (concatMap variableToKey pdefsDeps)
198143
199− realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
144+ realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]
200145 realDeps pdefsDeps = map convert pdefsDeps
201146 where
202147 varDict = variableToKeyMap pdefsDeps
203148 convert (pdef, key, deps) =
204149 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
205−