git.iko.soy/rowtype-yoga/purescript-native
on ea3e968 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/BindingGroups.hs
58 lines 1.9 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.Graph
21import Data.List (intersect)
23import Language.PureScript.Declarations
24import Language.PureScript.Names
25import Language.PureScript.Values
26import Language.PureScript.Scope (usedNames)
28createBindingGroupsModule :: [Module] -> [Module]
29createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)
31createBindingGroups :: [Declaration] -> [Declaration]
32createBindingGroups ds =
33 let
34 values = filter isValueDecl ds
35 nonValues = filter (not . isValueDecl) ds
36 allIdents = map getIdent values
37 verts = map (\d -> (d, getIdent d, usedNames d `intersect` allIdents)) values
38 sorted = map toBindingGroup $ stronglyConnComp verts
39 in
40 nonValues ++ sorted
42isValueDecl :: Declaration -> Bool
43isValueDecl (ValueDeclaration _ _ _ _) = True
44isValueDecl _ = False
46getIdent :: Declaration -> Ident
47getIdent (ValueDeclaration ident _ _ _) = ident
48getIdent _ = error "Expected ValueDeclaration"
50toBindingGroup :: SCC Declaration -> Declaration
51toBindingGroup (AcyclicSCC d) = d
52toBindingGroup (CyclicSCC [d]) = d
53toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration (map fromValueDecl ds')
55fromValueDecl :: Declaration -> (Ident, Value)
56fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
57fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
58fromValueDecl _ = error "Expected ValueDeclaration"