@@ -14,6 +14,7 @@ import qualified AST.Expression.Canonical as Canonical
1414import qualified AST.Pattern as P
1515import qualified AST.Variable as V
1616
17+
1718ctors :: P.CanonicalPattern -> [String]
1819ctors pattern =
1920 case pattern of
@@ -30,45 +31,55 @@ ctors pattern =
3031 where
3132 rest = concatMap ctors ps
3233
34+
3335free :: String -> State (Set.Set String) ()
34−free x = modify (Set.insert x)
36+free x =
37+ modify (Set.insert x)
38+
3539
3640freeIfLocal :: V.Canonical -> State (Set.Set String) ()
3741freeIfLocal (V.Canonical home name) =
38− do case home of
39− V.Local -> free name
40− V.BuiltIn -> return ()
41− V.Module _ -> return ()
42+ case home of
43+ V.Local -> free name
44+ V.BuiltIn -> return ()
45+ V.Module _ -> return ()
46+
4247
4348bound :: Set.Set String -> State (Set.Set String) ()
44−bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
49+bound boundVars =
50+ modify (\freeVars -> Set.difference freeVars boundVars)
51+
4552
4653sortDefs :: Canonical.Expr -> Canonical.Expr
47−sortDefs expr = evalState (reorder expr) Set.empty
54+sortDefs expr =
55+ evalState (reorder expr) Set.empty
56+
4857
4958reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr
5059reorder (A ann expr) =
5160 A ann <$>
5261 case expr of
5362 -- Be careful adding and restricting freeVars
54− Var var -> freeIfLocal var >> return expr
63+ Var var ->
64+ freeIfLocal var >> return expr
5565
5666 Lambda p e ->
5767 uncurry Lambda <$> bindingReorder (p,e)
5868
5969 Binop op e1 e2 ->
60− do freeIfLocal op
61− Binop op <$> reorder e1 <*> reorder e2
70+ do freeIfLocal op
71+ Binop op <$> reorder e1 <*> reorder e2
6272
6373 Case e cases ->
6474 Case <$> reorder e <*> mapM bindingReorder cases
6575
6676 Data name es ->
67− do free name
68− Data name <$> mapM reorder es
77+ do free name
78+ Data name <$> mapM reorder es
6979
7080 -- Just pipe the reorder though
71− Literal _ -> return expr
81+ Literal _ ->
82+ return expr
7283
7384 Range e1 e2 ->
7485 Range <$> reorder e1 <*> reorder e2
@@ -97,62 +108,72 @@ reorder (A ann expr) =
97108 Record fields ->
98109 Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields
99110
100− GLShader _ _ _ -> return expr
111+ GLShader _ _ _ ->
112+ return expr
101113
102− PortOut name st signal -> PortOut name st <$> reorder signal
114+ PortOut name st signal ->
115+ PortOut name st <$> reorder signal
103116
104− PortIn name st -> return $ PortIn name st
117+ PortIn name st ->
118+ return $ PortIn name st
105119
106120 -- Actually do some reordering
107121 Let defs body ->
108− do body' <- reorder body
109−
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
116−
117− -- remove let-bound variables from the context
118− forM_ defs $ \(Canonical.Definition pattern _ _) -> do
119− bound (P.boundVars pattern)
120− mapM free (ctors pattern)
121−
122− let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss
123−
124− return let'
125−
126−bindingReorder :: (P.CanonicalPattern, Canonical.Expr)
127− -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
122+ do body' <- reorder body
123+
124+ -- Sort defs into strongly connected components.This
125+ -- allows the programmer to write definitions in whatever
126+ -- order they please, we can still define things in order
127+ -- and generalize polymorphic functions when appropriate.
128+ sccs <- Graph.stronglyConnComp <$> buildDefDict defs
129+ let defss = map Graph.flattenSCC sccs
130+
131+ -- remove let-bound variables from the context
132+ forM_ defs $ \(Canonical.Definition pattern _ _) -> do
133+ bound (P.boundVars pattern)
134+ mapM free (ctors pattern)
135+
136+ let A _ let' =
137+ foldr (\ds bod -> A ann (Let ds bod)) body' defss
138+
139+ return let'
140+
141+
142+bindingReorder
143+ :: (P.CanonicalPattern, Canonical.Expr)
144+ -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)
128145bindingReorder (pattern,expr) =
129− do expr' <- reorder expr
130− bound (P.boundVars pattern)
131− mapM_ free (ctors pattern)
132− return (pattern, expr')
146+ do expr' <- reorder expr
147+ bound (P.boundVars pattern)
148+ mapM_ free (ctors pattern)
149+ return (pattern, expr')
133150
134151
135−reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String])
152+reorderAndGetDependencies
153+ :: Canonical.Def
154+ -> State (Set.Set String) (Canonical.Def, [String])
136155reorderAndGetDependencies (Canonical.Definition pattern expr mType) =
137− do globalFrees <- get
138− -- work in a fresh environment
139− put Set.empty
140− expr' <- reorder expr
141− localFrees <- get
142− -- merge with global frees
143− modify (Set.union globalFrees)
144− return (Canonical.Definition pattern expr' mType, Set.toList localFrees)
156+ do globalFrees <- get
157+ -- work in a fresh environment
158+ put Set.empty
159+ expr' <- reorder expr
160+ localFrees <- get
161+ -- merge with global frees
162+ modify (Set.union globalFrees)
163+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees)
145164
146165
147166-- This also reorders the all of the sub-expressions in the Def list.
148−buildDefDict :: [Canonical.Def] -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
167+buildDefDict
168+ :: [Canonical.Def]
169+ -> State (Set.Set String) [(Canonical.Def, Int, [Int])]
149170buildDefDict defs =
150− do pdefsDeps <- mapM reorderAndGetDependencies defs
151− return $ realDeps (addKey pdefsDeps)
152−
171+ do pdefsDeps <- mapM reorderAndGetDependencies defs
172+ return $ realDeps (addKey pdefsDeps)
153173 where
154174 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]
155− addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
175+ addKey =
176+ zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
156177
157178 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
158179 variableToKey (Canonical.Definition pattern _ _, key, _) =
@@ -163,8 +184,9 @@ buildDefDict defs =
163184 Map.fromList (concatMap variableToKey pdefsDeps)
164185
165186 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]
166− realDeps pdefsDeps = map convert pdefsDeps
167− where
168− varDict = variableToKeyMap pdefsDeps
169− convert (pdef, key, deps) =
170− (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
187+ realDeps pdefsDeps =
188+ map convert pdefsDeps
189+ where
190+ varDict = variableToKeyMap pdefsDeps
191+ convert (pdef, key, deps) =
192+ (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)