2014-01-03 09:07:13 +00:00
|
|
|
{-# OPTIONS_GHC -Wall #-}
|
|
|
|
module Transform.SortDefinitions (sortDefs) where
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
import Control.Monad.State
|
2014-01-03 09:07:13 +00:00
|
|
|
import Control.Applicative ((<$>),(<*>))
|
2013-07-04 15:24:04 +00:00
|
|
|
import qualified Data.Map as Map
|
2013-12-22 23:18:16 +00:00
|
|
|
import SourceSyntax.Expression
|
|
|
|
import SourceSyntax.Location
|
2014-01-03 09:07:13 +00:00
|
|
|
import qualified SourceSyntax.Pattern as P
|
2013-07-12 20:24:12 +00:00
|
|
|
import qualified Data.Graph as Graph
|
2014-01-03 09:07:13 +00:00
|
|
|
import qualified Data.Set as Set
|
2013-07-12 20:24:12 +00:00
|
|
|
import qualified Data.Maybe as Maybe
|
2013-07-04 15:24:04 +00:00
|
|
|
|
2014-01-03 09:07:13 +00:00
|
|
|
ctors :: P.Pattern -> [String]
|
2013-07-29 13:29:23 +00:00
|
|
|
ctors pattern =
|
|
|
|
case pattern of
|
2014-01-03 09:07:13 +00:00
|
|
|
P.PVar _ -> []
|
|
|
|
P.PAlias _ p -> ctors p
|
|
|
|
P.PData ctor ps -> ctor : concatMap ctors ps
|
|
|
|
P.PRecord _ -> []
|
|
|
|
P.PAnything -> []
|
|
|
|
P.PLiteral _ -> []
|
2013-07-29 13:29:23 +00:00
|
|
|
|
2013-07-12 20:24:12 +00:00
|
|
|
free :: String -> State (Set.Set String) ()
|
2013-07-04 15:24:04 +00:00
|
|
|
free x = modify (Set.insert x)
|
2013-07-12 20:24:12 +00:00
|
|
|
|
|
|
|
bound :: Set.Set String -> State (Set.Set String) ()
|
2013-07-04 15:24:04 +00:00
|
|
|
bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
|
|
|
|
|
2014-01-03 09:07:13 +00:00
|
|
|
sortDefs :: LExpr -> LExpr
|
2013-07-12 20:24:12 +00:00
|
|
|
sortDefs expr = evalState (reorder expr) Set.empty
|
2013-07-04 15:24:04 +00:00
|
|
|
|
2014-01-03 09:07:13 +00:00
|
|
|
reorder :: LExpr -> State (Set.Set String) LExpr
|
|
|
|
reorder (L s expr) =
|
|
|
|
L s <$>
|
2013-07-04 15:24:04 +00:00
|
|
|
case expr of
|
|
|
|
-- Be careful adding and restricting freeVars
|
|
|
|
Var x -> free x >> return expr
|
|
|
|
|
|
|
|
Lambda p e ->
|
2014-01-03 09:07:13 +00:00
|
|
|
uncurry Lambda <$> bindingReorder (p,e)
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
Binop op e1 e2 ->
|
|
|
|
do free op
|
2014-01-03 09:07:13 +00:00
|
|
|
Binop op <$> reorder e1 <*> reorder e2
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
Case e cases ->
|
2014-01-03 09:07:13 +00:00
|
|
|
Case <$> reorder e <*> mapM bindingReorder cases
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
Data name es ->
|
|
|
|
do free name
|
2014-01-03 09:07:13 +00:00
|
|
|
Data name <$> mapM reorder es
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
-- Just pipe the reorder though
|
|
|
|
Literal _ -> return expr
|
|
|
|
|
|
|
|
Range e1 e2 ->
|
2014-01-03 09:07:13 +00:00
|
|
|
Range <$> reorder e1 <*> reorder e2
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
ExplicitList es ->
|
2014-01-03 09:07:13 +00:00
|
|
|
ExplicitList <$> mapM reorder es
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
App e1 e2 ->
|
2014-01-03 09:07:13 +00:00
|
|
|
App <$> reorder e1 <*> reorder e2
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
MultiIf branches ->
|
2014-01-03 09:07:13 +00:00
|
|
|
MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
Access e lbl ->
|
2014-01-03 09:07:13 +00:00
|
|
|
Access <$> reorder e <*> return lbl
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
Remove e lbl ->
|
2014-01-03 09:07:13 +00:00
|
|
|
Remove <$> reorder e <*> return lbl
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
Insert e lbl v ->
|
2014-01-03 09:07:13 +00:00
|
|
|
Insert <$> reorder e <*> return lbl <*> reorder v
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
Modify e fields ->
|
2014-01-03 09:07:13 +00:00
|
|
|
Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields
|
2013-07-04 15:24:04 +00:00
|
|
|
|
|
|
|
Record fields ->
|
2014-01-03 09:07:13 +00:00
|
|
|
Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields
|
2013-07-04 15:24:04 +00:00
|
|
|
|
2013-10-25 15:36:30 +00:00
|
|
|
Markdown uid md es -> Markdown uid md <$> mapM reorder es
|
2013-07-04 15:24:04 +00:00
|
|
|
|
2013-07-12 20:24:12 +00:00
|
|
|
-- Actually do some reordering
|
|
|
|
Let defs body ->
|
|
|
|
do body' <- reorder body
|
|
|
|
|
|
|
|
-- Sort defs into strongly connected components.This
|
|
|
|
-- allows the programmer to write definitions in whatever
|
|
|
|
-- order they please, we can still define things in order
|
|
|
|
-- and generalize polymorphic functions when appropriate.
|
|
|
|
sccs <- Graph.stronglyConnComp <$> buildDefDict defs
|
|
|
|
let defss = map Graph.flattenSCC sccs
|
|
|
|
|
|
|
|
-- remove let-bound variables from the context
|
2014-01-03 09:07:13 +00:00
|
|
|
forM_ defs $ \(Definition pattern _ _) -> do
|
|
|
|
bound (P.boundVars pattern)
|
2013-07-29 13:29:23 +00:00
|
|
|
mapM free (ctors pattern)
|
2013-07-12 20:24:12 +00:00
|
|
|
|
2014-01-03 09:07:13 +00:00
|
|
|
let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
|
2013-07-12 20:24:12 +00:00
|
|
|
|
|
|
|
return let'
|
|
|
|
|
2014-01-03 09:07:13 +00:00
|
|
|
bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
|
2013-07-04 15:24:04 +00:00
|
|
|
bindingReorder (pattern,expr) =
|
|
|
|
do expr' <- reorder expr
|
2014-01-03 09:07:13 +00:00
|
|
|
bound (P.boundVars pattern)
|
|
|
|
mapM_ free (ctors pattern)
|
2013-07-04 15:24:04 +00:00
|
|
|
return (pattern, expr')
|
|
|
|
|
2013-07-12 20:24:12 +00:00
|
|
|
|
2014-01-03 09:07:13 +00:00
|
|
|
reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])
|
|
|
|
reorderAndGetDependencies (Definition pattern expr mType) =
|
2013-07-12 20:24:12 +00:00
|
|
|
do globalFrees <- get
|
|
|
|
-- work in a fresh environment
|
|
|
|
put Set.empty
|
|
|
|
expr' <- reorder expr
|
|
|
|
localFrees <- get
|
|
|
|
-- merge with global frees
|
|
|
|
modify (Set.union globalFrees)
|
2014-01-03 09:07:13 +00:00
|
|
|
return (Definition pattern expr' mType, Set.toList localFrees)
|
2013-07-12 20:24:12 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- This also reorders the all of the sub-expressions in the Def list.
|
2014-01-03 09:07:13 +00:00
|
|
|
buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]
|
2013-07-12 20:24:12 +00:00
|
|
|
buildDefDict defs =
|
2014-01-03 09:07:13 +00:00
|
|
|
do pdefsDeps <- mapM reorderAndGetDependencies defs
|
2013-07-12 20:24:12 +00:00
|
|
|
return $ realDeps (addKey pdefsDeps)
|
|
|
|
|
|
|
|
where
|
2014-01-03 09:07:13 +00:00
|
|
|
addKey :: [(Def, [String])] -> [(Def, Int, [String])]
|
2013-07-12 20:24:12 +00:00
|
|
|
addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
|
|
|
|
|
2014-01-03 09:07:13 +00:00
|
|
|
variableToKey :: (Def, Int, [String]) -> [(String, Int)]
|
|
|
|
variableToKey (Definition pattern _ _, key, _) =
|
|
|
|
[ (var, key) | var <- Set.toList (P.boundVars pattern) ]
|
2013-07-12 20:24:12 +00:00
|
|
|
|
2014-01-03 09:07:13 +00:00
|
|
|
variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int
|
2013-07-12 20:24:12 +00:00
|
|
|
variableToKeyMap pdefsDeps =
|
|
|
|
Map.fromList (concatMap variableToKey pdefsDeps)
|
|
|
|
|
2014-01-03 09:07:13 +00:00
|
|
|
realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]
|
2013-07-12 20:24:12 +00:00
|
|
|
realDeps pdefsDeps = map convert pdefsDeps
|
|
|
|
where
|
|
|
|
varDict = variableToKeyMap pdefsDeps
|
|
|
|
convert (pdef, key, deps) =
|
|
|
|
(pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
|