git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add function to accumulate values over types appearing inside a value/declaration/binder.
5c2aa36Phil Freeman
src/Language/PureScript/Declarations.hs+21
compare with golang
unifiedsplit
@@ -16,6 +16,8 @@
16
16
17module Language.PureScript.Declarations where
17module Language.PureScript.Declarations where
18
18
19+import Data.Monoid (Monoid(..), mconcat)
20+
19import Language.PureScript.Types
21import Language.PureScript.Types
20import Language.PureScript.Names
22import Language.PureScript.Names
21import Language.PureScript.Kinds
23import Language.PureScript.Kinds
@@ -562,3 +564,22 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
562 j' e@(DoNotationBind b v) = j e <> h' b <> g' v
564 j' e@(DoNotationBind b v) = j e <> h' b <> g' v
563 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
565 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
564 j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1
566 j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1
567+
568+accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
569+accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
570+ where
571+ forDecls (DataDeclaration _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
572+ forDecls (ExternDeclaration _ _ _ ty) = f ty
573+ forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
574+ forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
575+ forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
576+ forDecls (TypeSynonymDeclaration _ _ ty) = f ty
577+ forDecls (TypeDeclaration _ ty) = f ty
578+ forDecls _ = mempty
579+
580+ forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)
581+ forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
582+ forValues (TypedValue _ _ ty) = f ty
583+ forValues _ = mempty
584+
585+
src/Language/PureScript/Sugar/BindingGroups.hs+7−3
@@ -22,7 +22,7 @@ module Language.PureScript.Sugar.BindingGroups (
22) where
22) where
23
23
24import Data.Graph
24import Data.Graph
25−import Data.Generics
25+import Data.Generics (mkM)
26import Data.Generics.Extras
26import Data.Generics.Extras
27import Data.List (nub, intersect)
27import Data.List (nub, intersect)
28import Data.Maybe (isJust, mapMaybe)
28import Data.Maybe (isJust, mapMaybe)
@@ -90,7 +90,9 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
90collapseBindingGroupsForValue other = other
90collapseBindingGroupsForValue other = other
91
91
92usedIdents :: ModuleName -> Declaration -> [Ident]
92usedIdents :: ModuleName -> Declaration -> [Ident]
93−usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)
93+usedIdents moduleName =
94+ let (f, _, _, _, _) = everythingOnValues (++) (const []) usedNames (const []) (const []) (const [])
95+ in nub . f
94 where
96 where
95 usedNames :: Value -> [Ident]
97 usedNames :: Value -> [Ident]
96 usedNames (Var (Qualified Nothing name)) = [name]
98 usedNames (Var (Qualified Nothing name)) = [name]
@@ -98,7 +100,9 @@ usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)
98 usedNames _ = []
100 usedNames _ = []
99
101
100usedProperNames :: ModuleName -> Declaration -> [ProperName]
102usedProperNames :: ModuleName -> Declaration -> [ProperName]
101−usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)
103+usedProperNames moduleName =
104+ let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
105+ in nub . f
102 where
106 where
103 usedNames :: Type -> [ProperName]
107 usedNames :: Type -> [ProperName]
104 usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
108 usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->