@@ -26,6 +26,7 @@ import Data.List (nub, intersect)
2626import Data.Maybe (isJust, mapMaybe)
2727import Data.Monoid ((<>))
2828import Control.Applicative ((<$>), (<*>), pure)
29+import Control.Monad ((<=<))
2930
3031import qualified Data.Set as S
3132
@@ -47,35 +48,37 @@ createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> cre
4748collapseBindingGroupsModule :: [Module] -> [Module]
4849collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps
4950
50−-- |
51−-- Replace all sets of mutually-recursive declarations with binding groups
52−--
5351createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]
54−createBindingGroups moduleName ds = do
55− values <- parU (filter isValueDecl ds) (createBindingGroupsForValue moduleName)
56− let dataDecls = filter isDataDecl ds
57− allProperNames = map getProperName dataDecls
58− dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
59− dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
60− let allIdents = map getIdent values
61− valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
62− bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
63− return $ filter isImportDecl ds ++
64− filter isExternDataDecl ds ++
65− filter isExternInstanceDecl ds ++
66− dataBindingGroupDecls ++
67− filter isTypeClassDeclaration ds ++
68− filter isFixityDecl ds ++
69− filter isExternDecl ds ++
70− bindingGroupDecls
71−
72−createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration
73−createBindingGroupsForValue moduleName =
74− let (f, _, _) = everywhereOnValuesTopDownM return go return
75− in f
52+createBindingGroups moduleName = mapM f <=< handleDecls
53+
7654 where
77− go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val
78− go other = return other
55+ (f, _, _) = everywhereOnValuesTopDownM return handleExprs return
56+
57+ handleExprs :: Expr -> Either ErrorStack Expr
58+ handleExprs (Let ds val) = flip Let val <$> handleDecls ds
59+ handleExprs other = return other
60+
61+ -- |
62+ -- Replace all sets of mutually-recursive declarations with binding groups
63+ --
64+ handleDecls :: [Declaration] -> Either ErrorStack [Declaration]
65+ handleDecls ds = do
66+ let values = filter isValueDecl ds
67+ dataDecls = filter isDataDecl ds
68+ allProperNames = map getProperName dataDecls
69+ dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
70+ dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
71+ let allIdents = map getIdent values
72+ valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
73+ bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
74+ return $ filter isImportDecl ds ++
75+ filter isExternDataDecl ds ++
76+ filter isExternInstanceDecl ds ++
77+ dataBindingGroupDecls ++
78+ filter isTypeClassDeclaration ds ++
79+ filter isFixityDecl ds ++
80+ filter isExternDecl ds ++
81+ bindingGroupDecls
7982
8083-- |
8184-- Collapse all binding groups to individual declarations
@@ -151,7 +154,6 @@ getProperName _ = error "Expected DataDeclaration"
151154--
152155toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration
153156toBindingGroup _ (AcyclicSCC d) = return d
154−toBindingGroup _ (CyclicSCC [d]) = return d
155157toBindingGroup moduleName (CyclicSCC ds') =
156158 -- Once we have a mutually-recursive group of declarations, we need to sort
157159 -- them further by their immediate dependencies (those outside function
@@ -181,7 +183,6 @@ toBindingGroup moduleName (CyclicSCC ds') =
181183 cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []
182184 cycleError _ _ = error "Expected ValueDeclaration"
183185
184−
185186toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration
186187toDataBindingGroup (AcyclicSCC d) = return d
187188toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of