git.iko.soy/elk
on e2aff93 help sign in
elk/compiler/Transform/SortDefinitions.hs
155 lines 5.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.SortDefinitions (sortDefs) where
4import Control.Monad.State
5import Control.Applicative ((<$>),(<*>))
6import Data.Traversable (traverse)
7import qualified Data.Map as Map
8import SourceSyntax.Expression
9import SourceSyntax.Location
10import qualified SourceSyntax.Pattern as P
11import qualified Data.Graph as Graph
12import qualified Data.Set as Set
13import qualified Data.Maybe as Maybe
15ctors :: P.Pattern -> [String]
16ctors pattern =
17 case pattern of
18 P.PVar _ -> []
19 P.PAlias _ p -> ctors p
20 P.PData ctor ps -> ctor : concatMap ctors ps
21 P.PRecord _ -> []
22 P.PAnything -> []
23 P.PLiteral _ -> []
25free :: String -> State (Set.Set String) ()
26free x = modify (Set.insert x)
28bound :: Set.Set String -> State (Set.Set String) ()
29bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
31sortDefs :: LExpr -> LExpr
32sortDefs expr = evalState (reorder expr) Set.empty
34reorder :: LExpr -> State (Set.Set String) LExpr
35reorder (L s expr) =
36 L s <$>
37 case expr of
38 -- Be careful adding and restricting freeVars
39 Var x -> free x >> return expr
41 Lambda p e ->
42 uncurry Lambda <$> bindingReorder (p,e)
44 Binop op e1 e2 ->
45 do free op
46 Binop op <$> reorder e1 <*> reorder e2
48 Case e cases ->
49 Case <$> reorder e <*> mapM bindingReorder cases
51 Data name es ->
52 do free name
53 Data name <$> mapM reorder es
55 -- Just pipe the reorder though
56 Literal _ -> return expr
58 Range e1 e2 ->
59 Range <$> reorder e1 <*> reorder e2
61 ExplicitList es ->
62 ExplicitList <$> mapM reorder es
64 App e1 e2 ->
65 App <$> reorder e1 <*> reorder e2
67 MultiIf branches ->
68 MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches
70 Access e lbl ->
71 Access <$> reorder e <*> return lbl
73 Remove e lbl ->
74 Remove <$> reorder e <*> return lbl
76 Insert e lbl v ->
77 Insert <$> reorder e <*> return lbl <*> reorder v
79 Modify e fields ->
80 Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields
82 Record fields ->
83 Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields
85 Markdown uid md es -> Markdown uid md <$> mapM reorder es
87 PortOut name st signal -> PortOut name st <$> reorder signal
89 PortIn name st tt handler ->
90 PortIn name st tt <$> traverse reorder handler
92 -- Actually do some reordering
93 Let defs body ->
94 do body' <- reorder body
96 -- Sort defs into strongly connected components.This
97 -- allows the programmer to write definitions in whatever
98 -- order they please, we can still define things in order
99 -- and generalize polymorphic functions when appropriate.
100 sccs <- Graph.stronglyConnComp <$> buildDefDict defs
101 let defss = map Graph.flattenSCC sccs
103 -- remove let-bound variables from the context
104 forM_ defs $ \(Definition pattern _ _) -> do
105 bound (P.boundVars pattern)
106 mapM free (ctors pattern)
108 let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
110 return let'
112bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
113bindingReorder (pattern,expr) =
114 do expr' <- reorder expr
115 bound (P.boundVars pattern)
116 mapM_ free (ctors pattern)
117 return (pattern, expr')
120reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])
121reorderAndGetDependencies (Definition pattern expr mType) =
122 do globalFrees <- get
123 -- work in a fresh environment
124 put Set.empty
125 expr' <- reorder expr
126 localFrees <- get
127 -- merge with global frees
128 modify (Set.union globalFrees)
129 return (Definition pattern expr' mType, Set.toList localFrees)
132-- This also reorders the all of the sub-expressions in the Def list.
133buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]
134buildDefDict defs =
135 do pdefsDeps <- mapM reorderAndGetDependencies defs
136 return $ realDeps (addKey pdefsDeps)
138 where
139 addKey :: [(Def, [String])] -> [(Def, Int, [String])]
140 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
142 variableToKey :: (Def, Int, [String]) -> [(String, Int)]
143 variableToKey (Definition pattern _ _, key, _) =
144 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
146 variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int
147 variableToKeyMap pdefsDeps =
148 Map.fromList (concatMap variableToKey pdefsDeps)
150 realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]
151 realDeps pdefsDeps = map convert pdefsDeps
152 where
153 varDict = variableToKeyMap pdefsDeps
154 convert (pdef, key, deps) =
155 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)