git.iko.soy/rowtype-yoga/purescript-native
on a7335ba help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/BindingGroups.hs
98 lines 3.5 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.BindingGroups
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15module Language.PureScript.BindingGroups (
16 createBindingGroups,
17 createBindingGroupsModule
18) where
20import Data.Data
21import Data.Graph
22import Data.Generics
23import Data.List (nub, intersect)
25import Language.PureScript.Declarations
26import Language.PureScript.Names
27import Language.PureScript.Values
28import Language.PureScript.Types
30createBindingGroupsModule :: [Module] -> [Module]
31createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)
33createBindingGroups :: [Declaration] -> [Declaration]
34createBindingGroups ds =
35 let
36 values = filter isValueDecl ds
37 dataDecls = filter isDataDecl ds
38 nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds
39 allProperNames = map getProperName dataDecls
40 dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls
41 dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts
42 allIdents = map getIdent values
43 valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values
44 bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
45 in
46 dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls
48usedIdents :: (Data d) => d -> [Ident]
49usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)
50 where
51 namesV :: Value -> [Ident]
52 namesV (Var (Qualified Nothing name)) = [name]
53 namesV _ = []
54 namesS :: Statement -> [Ident]
55 namesS (VariableIntroduction name _) = [name]
56 namesS _ = []
58usedProperNames :: (Data d) => d -> [ProperName]
59usedProperNames = nub . everything (++) (mkQ [] names)
60 where
61 names :: Type -> [ProperName]
62 names (TypeConstructor (Qualified Nothing name)) = [name]
63 names _ = []
65isValueDecl :: Declaration -> Bool
66isValueDecl (ValueDeclaration _ _ _ _) = True
67isValueDecl _ = False
69isDataDecl :: Declaration -> Bool
70isDataDecl (DataDeclaration _ _ _) = True
71isDataDecl _ = False
73getIdent :: Declaration -> Ident
74getIdent (ValueDeclaration ident _ _ _) = ident
75getIdent _ = error "Expected ValueDeclaration"
77getProperName :: Declaration -> ProperName
78getProperName (DataDeclaration pn _ _) = pn
79getProperName _ = error "Expected DataDeclaration"
81toBindingGroup :: SCC Declaration -> Declaration
82toBindingGroup (AcyclicSCC d) = d
83toBindingGroup (CyclicSCC [d]) = d
84toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'
86toDataBindingGroup :: SCC Declaration -> Declaration
87toDataBindingGroup (AcyclicSCC d) = d
88toDataBindingGroup (CyclicSCC [d]) = d
89toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'
91fromValueDecl :: Declaration -> (Ident, Value)
92fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
93fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
94fromValueDecl _ = error "Expected ValueDeclaration"
96fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe PolyType)])
97fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)
98fromDataDecl _ = error "Expected DataDeclaration"