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.
commit5c2aa36858c20b225fbc9a20b58516210902e7be authorPhil Freeman <paf31@cantab.net> dateTue 15 Apr 2014, 19:00 (13 years ago) parentb6682df
2 files changed+28−3
compare with golang
unifiedsplit
src/Language/PureScript/Declarations.hs+21 src/Language/PureScript/Sugar/BindingGroups.hs+7−3
src/Language/PureScript/Declarations.hs+21
@@ -16,6 +16,8 @@
1616
1717module Language.PureScript.Declarations where
1818
19+import Data.Monoid (Monoid(..), mconcat)
20+
1921import Language.PureScript.Types
2022import Language.PureScript.Names
2123import Language.PureScript.Kinds
@@ -562,3 +564,22 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
562564 j' e@(DoNotationBind b v) = j e <> h' b <> g' v
563565 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
564566 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 (
2222) where
2323
2424import Data.Graph
25−import Data.Generics
25+import Data.Generics (mkM)
2626import Data.Generics.Extras
2727import Data.List (nub, intersect)
2828import Data.Maybe (isJust, mapMaybe)
@@ -90,7 +90,9 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
9090collapseBindingGroupsForValue other = other
9191
9292usedIdents :: 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
9496 where
9597 usedNames :: Value -> [Ident]
9698 usedNames (Var (Qualified Nothing name)) = [name]
@@ -98,7 +100,9 @@ usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)
98100 usedNames _ = []
99101
100102usedProperNames :: ModuleName -> Declaration -> [ProperName]
101−usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)
103+usedProperNames moduleName =
104+ let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
105+ in nub . f
102106 where
103107 usedNames :: Type -> [ProperName]
104108 usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->