git.iko.soy/elk
on d1a85fe help sign in
elk/compiler/Transform/SortDefinitions.hs
153 lines 4.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.SortDefinitions (sortDefs) where
4import Control.Monad.State
5import Control.Applicative ((<$>),(<*>))
6import qualified Data.Map as Map
7import SourceSyntax.Expression
8import SourceSyntax.Location
9import qualified SourceSyntax.Pattern as P
10import qualified Data.Graph as Graph
11import qualified Data.Set as Set
12import qualified Data.Maybe as Maybe
14ctors :: P.Pattern -> [String]
15ctors pattern =
16 case pattern of
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 _ -> []
24free :: String -> State (Set.Set String) ()
25free x = modify (Set.insert x)
27bound :: Set.Set String -> State (Set.Set String) ()
28bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
30sortDefs :: LExpr -> LExpr
31sortDefs expr = evalState (reorder expr) Set.empty
33reorder :: LExpr -> State (Set.Set String) LExpr
34reorder (L s expr) =
35 L s <$>
36 case expr of
37 -- Be careful adding and restricting freeVars
38 Var x -> free x >> return expr
40 Lambda p e ->
41 uncurry Lambda <$> bindingReorder (p,e)
43 Binop op e1 e2 ->
44 do free op
45 Binop op <$> reorder e1 <*> reorder e2
47 Case e cases ->
48 Case <$> reorder e <*> mapM bindingReorder cases
50 Data name es ->
51 do free name
52 Data name <$> mapM reorder es
54 -- Just pipe the reorder though
55 Literal _ -> return expr
57 Range e1 e2 ->
58 Range <$> reorder e1 <*> reorder e2
60 ExplicitList es ->
61 ExplicitList <$> mapM reorder es
63 App e1 e2 ->
64 App <$> reorder e1 <*> reorder e2
66 MultiIf branches ->
67 MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches
69 Access e lbl ->
70 Access <$> reorder e <*> return lbl
72 Remove e lbl ->
73 Remove <$> reorder e <*> return lbl
75 Insert e lbl v ->
76 Insert <$> reorder e <*> return lbl <*> reorder v
78 Modify e fields ->
79 Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields
81 Record fields ->
82 Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields
84 Markdown uid md es -> Markdown uid md <$> mapM reorder es
86 PortOut name st signal -> PortOut name st <$> reorder signal
88 PortIn name st tt handler -> PortIn name st tt <$> reorder handler
90 -- Actually do some reordering
91 Let defs body ->
92 do body' <- reorder body
94 -- Sort defs into strongly connected components.This
95 -- allows the programmer to write definitions in whatever
96 -- order they please, we can still define things in order
97 -- and generalize polymorphic functions when appropriate.
98 sccs <- Graph.stronglyConnComp <$> buildDefDict defs
99 let defss = map Graph.flattenSCC sccs
101 -- remove let-bound variables from the context
102 forM_ defs $ \(Definition pattern _ _) -> do
103 bound (P.boundVars pattern)
104 mapM free (ctors pattern)
106 let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
108 return let'
110bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
111bindingReorder (pattern,expr) =
112 do expr' <- reorder expr
113 bound (P.boundVars pattern)
114 mapM_ free (ctors pattern)
115 return (pattern, expr')
118reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])
119reorderAndGetDependencies (Definition pattern expr mType) =
120 do globalFrees <- get
121 -- work in a fresh environment
122 put Set.empty
123 expr' <- reorder expr
124 localFrees <- get
125 -- merge with global frees
126 modify (Set.union globalFrees)
127 return (Definition pattern expr' mType, Set.toList localFrees)
130-- This also reorders the all of the sub-expressions in the Def list.
131buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]
132buildDefDict defs =
133 do pdefsDeps <- mapM reorderAndGetDependencies defs
134 return $ realDeps (addKey pdefsDeps)
136 where
137 addKey :: [(Def, [String])] -> [(Def, Int, [String])]
138 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
140 variableToKey :: (Def, Int, [String]) -> [(String, Int)]
141 variableToKey (Definition pattern _ _, key, _) =
142 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
144 variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int
145 variableToKeyMap pdefsDeps =
146 Map.fromList (concatMap variableToKey pdefsDeps)
148 realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]
149 realDeps pdefsDeps = map convert pdefsDeps
150 where
151 varDict = variableToKeyMap pdefsDeps
152 convert (pdef, key, deps) =
153 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)