git.iko.soy/rowtype-yoga/purescript-native
on 24872f8 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) where
19import Data.Graph
20import Data.List (intersect)
22import Language.PureScript.Declarations
23import Language.PureScript.Names
24import Language.PureScript.Values
25import Language.PureScript.Scope (usedNames)
27createBindingGroups :: [Declaration] -> [Declaration]
28createBindingGroups ds =
29 let
30 values = filter isValueDecl ds
31 nonValues = filter (not . isValueDecl) ds
32 allIdents = map getIdent values
33 verts = map (\d -> (d, getIdent d, usedNames d `intersect` allIdents)) values
34 sorted = map toBindingGroup $ stronglyConnComp verts
35 in
36 map handleModuleDeclaration nonValues ++ sorted
38isValueDecl :: Declaration -> Bool
39isValueDecl (ValueDeclaration _ _ _ _) = True
40isValueDecl _ = False
42getIdent :: Declaration -> Ident
43getIdent (ValueDeclaration ident _ _ _) = ident
44getIdent _ = error "Expected ValueDeclaration"
46toBindingGroup :: SCC Declaration -> Declaration
47toBindingGroup (AcyclicSCC d) = d
48toBindingGroup (CyclicSCC [d]) = d
49toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration (map fromValueDecl ds')
51fromValueDecl :: Declaration -> (Ident, Value)
52fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
53fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
54fromValueDecl _ = error "Expected ValueDeclaration"
56handleModuleDeclaration :: Declaration -> Declaration
57handleModuleDeclaration (ModuleDeclaration name ds') = ModuleDeclaration name $ createBindingGroups ds'
58handleModuleDeclaration other = other