@@ -26,14 +26,14 @@ import Language.PureScript.Values
26import Language.PureScript.CodeGen.JS.AST
26import Language.PureScript.CodeGen.JS.AST
27import Language.PureScript.Sugar.CaseDeclarations
27import Language.PureScript.Sugar.CaseDeclarations
28import Language.PureScript.Prim
28import Language.PureScript.Prim
29−
29+import Language.PureScript.CodeGen.Common (identToJs)
30−import qualified Data.Map as M
32import Control.Applicative
31import Control.Applicative
33import Control.Monad.State
32import Control.Monad.State
34import Control.Arrow (second)
33import Control.Arrow (second)
34+import Data.Maybe (catMaybes)
36−import Language.PureScript.CodeGen.Common (identToJs)
36+import qualified Data.Map as M
38type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])
38type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])
@@ -47,7 +47,10 @@ desugarTypeClasses :: [Module] -> Either String [Module]
47desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
47desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
49desugarModule :: Module -> Desugar Module
49desugarModule :: Module -> Desugar Module
50−desugarModule (Module name decls exps) = Module name <$> concat <$> mapM (desugarDecl name) decls <*> pure exps
50+desugarModule (Module name decls (Just exps)) = do
51+ (newExpss, declss) <- unzip <$> mapM (desugarDecl name) decls
52+ return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
53+desugarModule _ = error "Exports should have been elaborated in name desugaring"
53-- Desugar type class and type class instance declarations
56-- Desugar type class and type class instance declarations
@@ -87,17 +90,17 @@ desugarModule (Module name decls exps) = Module name <$> concat <$> mapM (desuga
87-- __Test_Foo_array :: forall a. Foo a -> Foo [a]
90-- __Test_Foo_array :: forall a. Foo a -> Foo [a]
88-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }
91-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }
90−desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]
93+desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
91desugarDecl mn d@(TypeClassDeclaration name args members) = do
94desugarDecl mn d@(TypeClassDeclaration name args members) = do
92 let tys = map memberToNameAndType members
95 let tys = map memberToNameAndType members
93 modify (M.insert (mn, name) (args, tys))
96 modify (M.insert (mn, name) (args, tys))
94− return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members
97+ return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)
95desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
98desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
96 desugared <- lift $ desugarCases members
99 desugared <- lift $ desugarCases members
97 entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared
100 entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared
98 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
101 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
99− return $ d : entries ++ [dictDecl]
102+ return $ (Just $ TypeInstanceRef name className ty, d : entries ++ [dictDecl])
100−desugarDecl _ other = return [other]
103+desugarDecl _ other = return (Nothing, [other])
102memberToNameAndType :: Declaration -> (String, Type)
105memberToNameAndType :: Declaration -> (String, Type)
103memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)
106memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)