@@ -47,35 +47,41 @@ createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> cre
4747collapseBindingGroupsModule :: [Module] -> [Module]
4848collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps
4949
50−-- |
51−-- Replace all sets of mutually-recursive declarations with binding groups
52−--
5350createBindingGroups :: 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
51+createBindingGroups moduleName decls = do
52+ (Let result _) <- createBindingGroupsForValue (Let decls (StringLiteral (error "Placeholder string literal was used in createBindingGroups.")))
53+ return result
54+
7655 where
77− go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val
78− go other = return other
56+ createBindingGroupsForValue :: Expr -> Either ErrorStack Expr
57+ createBindingGroupsForValue =
58+ let (_, f, _) = everywhereOnValuesTopDownM return go return
59+ in f
60+ where
61+ go (Let ds val) = flip Let val <$> handleDecls ds
62+ go other = return other
63+
64+ -- |
65+ -- Replace all sets of mutually-recursive declarations with binding groups
66+ --
67+ handleDecls :: [Declaration] -> Either ErrorStack [Declaration]
68+ handleDecls ds = do
69+ let values = filter isValueDecl ds
70+ dataDecls = filter isDataDecl ds
71+ allProperNames = map getProperName dataDecls
72+ dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
73+ dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
74+ let allIdents = map getIdent values
75+ valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
76+ bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
77+ return $ filter isImportDecl ds ++
78+ filter isExternDataDecl ds ++
79+ filter isExternInstanceDecl ds ++
80+ dataBindingGroupDecls ++
81+ filter isTypeClassDeclaration ds ++
82+ filter isFixityDecl ds ++
83+ filter isExternDecl ds ++
84+ bindingGroupDecls
7985
8086-- |
8187-- Collapse all binding groups to individual declarations