7e08760 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #237 from garyb/master

7e08760Phil Freeman13 years ago

docgen/Main.hs+2−1

compare with golang

unifiedsplit

@@ -58,8 +58,9 @@ renderModules ms = do

58 headerLevel 1 "Module Documentation"

59 mapM_ renderModule ms

61+-- TODO: filter everything by exports

61renderModule :: P.Module -> Docs

62renderModule :: P.Module -> Docs

62−renderModule (P.Module moduleName ds) = do

63+renderModule (P.Module moduleName ds exps) = do

63 headerLevel 2 $ "Module " ++ P.runModuleName moduleName

64 headerLevel 2 $ "Module " ++ P.runModuleName moduleName

64 spacer

65 spacer

65 headerLevel 3 "Types"

66 headerLevel 3 "Types"

examples/failing/ExportExplicit.pursnew file+16

@@ -0,0 +1,16 @@

1+module M1 (X(..)) where

3+ data X = X | Y

4+ data Z = Z

6+module Main where

8+ import M1

10+ testX = X

11+ testY = Y

12+

13+ -- should fail as Z is not exported from M1

14+ testZ = Z

15+

16+ main = Debug.Trace.trace "Done"

examples/failing/ExportExplicit2.pursnew file+13

@@ -0,0 +1,13 @@

1+module M1 (x) where

3+ x = 1

4+ y = 0

6+module Main where

8+ import M1

10+ -- should fail as y is not exported from M1

11+ testY = y

12+

13+ main = Debug.Trace.trace "Done"

examples/failing/ExportExplicit3.pursnew file+5

@@ -0,0 +1,5 @@

1+-- should fail as z does not exist in the module

2+module M1 (x, y, z) where

4+ x = 1

5+ y = 2

examples/failing/ExportExplicit4.pursnew file+14

@@ -0,0 +1,14 @@

1+module M1 (X(X)) where

3+ data X = X | Y

5+module Main where

7+ import M1

9+ testX = X

10+

11+ -- should fail as Y constructor is not exported from M1

12+ testY = Y

13+

14+ main = Debug.Trace.trace "Done"

examples/failing/ExportExplicit5.pursnew file+5

@@ -0,0 +1,5 @@

1+-- should fail as Y is not a data constructor for X

2+module M1 (X(Y)) where

4+ data X = X

5+ data Y = Y

examples/failing/ExportExplicit6.pursnew file+13

@@ -0,0 +1,13 @@

1+module M1 (X(..)) where

3+ data X = X | Y

4+ data Z = Z

6+module Main where

8+ import M1

10+ -- should fail as Z is not exported from M1

11+ testZ = M1.Z

12+

13+ main = Debug.Trace.trace "Done"

examples/passing/ExportExplicit.pursnew file+16

@@ -0,0 +1,16 @@

1+module M1 (X(X), Z(..), foo) where

3+ data X = X | Y

4+ data Z = Z

6+ foo = 0

8+module Main where

10+ import M1

11+

12+ testX = X

13+ testZ = Z

14+ testFoo = foo

15+

16+ main = Debug.Trace.trace "Done"

psci/Main.hs+3−2

@@ -161,6 +161,7 @@ quitMessage = "See ya!"

161

162-- |

163-- Loads module, function, and file completions.

164+-- TODO: filter names to only include exported decls

164--

165--

165completion :: CompletionFunc (StateT PSCiState IO)

166completion :: CompletionFunc (StateT PSCiState IO)

166completion = completeWord Nothing " \t\n\r" findCompletions

167completion = completeWord Nothing " \t\n\r" findCompletions

@@ -176,7 +177,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions

176 getDeclName _ = Nothing

177 getDeclName _ = Nothing

177 names :: [P.Module] -> [String]

178 names :: [P.Module] -> [String]

178 names ms = nub [ show qual

179 names ms = nub [ show qual

179− | P.Module moduleName ds <- ms

180+ | P.Module moduleName ds _ <- ms

180 , ident <- mapMaybe getDeclName ds

181 , ident <- mapMaybe getDeclName ds

181 , qual <- [ P.Qualified Nothing ident

182 , qual <- [ P.Qualified Nothing ident

182 , P.Qualified (Just moduleName) ident]

183 , P.Qualified (Just moduleName) ident]

@@ -207,7 +208,7 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB

207 mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing mainValue

208 mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing mainValue

208 decls = if exec then [itDecl, mainDecl] else [itDecl]

209 decls = if exec then [itDecl, mainDecl] else [itDecl]

209 in

210 in

210− P.Module moduleName $ map importDecl imports ++ decls

211+ P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing

211

212

212-- |

213-- |

213-- Takes a value declaration and evaluates it with the current state.

214-- Takes a value declaration and evaluates it with the current state.

purescript.cabal+1

@@ -64,6 +64,7 @@ library

64 Language.PureScript.Pretty.Kinds

65 Language.PureScript.Pretty.Types

66 Language.PureScript.Pretty.Values

67+ Language.PureScript.Prim

67 Language.PureScript.TypeChecker

68 Language.PureScript.TypeChecker

68 Language.PureScript.TypeChecker.Kinds

69 Language.PureScript.TypeChecker.Kinds

69 Language.PureScript.TypeChecker.Monad

70 Language.PureScript.TypeChecker.Monad

src/Language/PureScript.hs+3−3

@@ -33,7 +33,7 @@ import Language.PureScript.DeadCodeElimination as P

33import Data.List (intercalate)

34import Data.Maybe (mapMaybe)

35import Control.Monad.State.Lazy

36−import Control.Applicative ((<$>))

36+import Control.Applicative ((<$>), (<*>), pure)

37import qualified Data.Map as M

39-- |

@@ -59,9 +59,9 @@ compile :: Options -> [Module] -> Either String (String, String, Environment)

59compile opts ms = do

60 sorted <- sortModules ms

61 desugared <- desugar sorted

62− (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName' decls) -> do

62+ (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName' decls exps) -> do

63 modify (\s -> s { checkCurrentModule = Just moduleName' })

64− Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls

64+ Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls <*> pure exps

65 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

66 let entryPoints = moduleNameFromString `map` optionsModules opts

67 let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped

src/Language/PureScript/CodeGen/Externs.hs+2−1

@@ -27,9 +27,10 @@ import Data.List (intercalate)

28-- |

29-- Generate foreign imports for all declarations in a module

30+-- TODO: only expose items listed in "exps"

30--

31--

31moduleToPs :: Module -> Environment -> String

32moduleToPs :: Module -> Environment -> String

32−moduleToPs (Module mn decls) env =

33+moduleToPs (Module mn decls exps) env =

33 "module " ++ runModuleName mn ++ " where\n" ++

34 "module " ++ runModuleName mn ++ " where\n" ++

34 (intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)

35 (intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)

src/Language/PureScript/CodeGen/JS.hs+8−10

@@ -43,13 +43,14 @@ import Language.PureScript.CodeGen.JS.AST as AST

43import Language.PureScript.Types

44import Language.PureScript.CodeGen.Optimize

45import Language.PureScript.CodeGen.Common

46+import Language.PureScript.Prim

47-- |

48-- |

48-- Generate code in the simplified Javascript intermediate representation for all declarations in a

49-- Generate code in the simplified Javascript intermediate representation for all declarations in a

49-- module.

50-- module.

50--

51--

51moduleToJs :: Options -> Module -> Environment -> Maybe JS

52moduleToJs :: Options -> Module -> Environment -> Maybe JS

52−moduleToJs opts (Module name decls) env =

53+moduleToJs opts (Module name decls exps) env =

53 case jsDecls of

54 case jsDecls of

54 [] -> Nothing

55 [] -> Nothing

55 _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $

56 _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $

@@ -63,17 +64,14 @@ moduleToJs opts (Module name decls) env =

63--

64--

64declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

65declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

65declToJs opts mp (ValueDeclaration ident _ _ val) e =

66declToJs opts mp (ValueDeclaration ident _ _ val) e =

66− Just [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))

67+ Just $ export ident $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))

67− , setExportProperty ident (var ident) ]

68declToJs opts mp (BindingGroupDeclaration vals) e =

69 Just $ concatMap (\(ident, val) ->

70− [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))

70+ export ident $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))

71− , setExportProperty ident (var ident) ]

72 ) vals

71 ) vals

73declToJs _ mp (DataDeclaration _ _ ctors) _ =

72declToJs _ mp (DataDeclaration _ _ ctors) _ =

74 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

73 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

75− [ JSVariableIntroduction ctor (Just (go pn 0 tys []))

74+ export (Escaped ctor) $ JSVariableIntroduction ctor (Just (go pn 0 tys []))

76− , setExportProperty (Escaped ctor) (JSVar ctor) ]

77 where

75 where

78 go pn _ [] values =

76 go pn _ [] values =

79 JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]

77 JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]

@@ -83,15 +81,15 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =

83declToJs opts mp (DataBindingGroupDeclaration ds) e =

81declToJs opts mp (DataBindingGroupDeclaration ds) e =

84 Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

82 Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

85declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ =

83declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ =

86− Just [js, setExportProperty ident (var ident)]

84+ Just $ export ident js

87declToJs _ _ _ _ = Nothing

85declToJs _ _ _ _ = Nothing

89-- |

87-- |

90-- Generate code in the simplified Javascript intermediate representation for exporting a

88-- Generate code in the simplified Javascript intermediate representation for exporting a

91-- declaration from a module.

89-- declaration from a module.

92--

90--

93−setExportProperty :: Ident -> JS -> JS

91+export :: Ident -> JS -> [JS]

94−setExportProperty ident = JSAssignment (accessor ident (JSVar "module"))

92+export ident value = [ value, JSAssignment (accessor ident (JSVar "module")) (var ident) ]

96-- |

94-- |

97-- Generate code in the simplified Javascript intermediate representation for a variable based on a

95-- Generate code in the simplified Javascript intermediate representation for a variable based on a

src/Language/PureScript/CodeGen/Optimize.hs+1

@@ -47,6 +47,7 @@ import Language.PureScript.CodeGen.JS.AST

47import Language.PureScript.Options

48import Language.PureScript.CodeGen.Common (identToJs)

49import Language.PureScript.Types

50+import Language.PureScript.Prim

51-- |

52-- |

52-- Apply a series of optimizer passes to simplified Javascript code

53-- Apply a series of optimizer passes to simplified Javascript code

src/Language/PureScript/DeadCodeElimination.hs+2−2

@@ -35,12 +35,12 @@ eliminateDeadCode env entryPoints ms =

35 let declarations = concatMap (declarationsByModule env) ms

36 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

37 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

38− in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds)

38+ in flip map ms $ \(Module moduleName ds exps) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds) exps

40type Key = (ModuleName, Either Ident ProperName)

42declarationsByModule :: Environment -> Module -> [(Key, [Key])]

43−declarationsByModule env (Module moduleName ds) = concatMap go ds

43+declarationsByModule env (Module moduleName ds _) = concatMap go ds

44 where

45 go :: Declaration -> [(Key, [Key])]

46 go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]

src/Language/PureScript/Declarations.hs+13−12

@@ -40,9 +40,10 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)

40data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

42-- |

43−-- A module declaration, consisting of a module name and a list of declarations

43+-- A module declaration, consisting of a module name, a list of declarations, and a list of the

44+-- declarations that are explicitly imported. If the export list is Nothing, everything is exported.

44--

45--

45−data Module = Module ModuleName [Declaration] deriving (Show, D.Data, D.Typeable)

46+data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)

47-- |

48-- |

48-- The type of a foreign import

49-- The type of a foreign import

@@ -66,22 +67,22 @@ data ForeignImportType

66 | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)

67 | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)

68-- |

69-- |

69−-- An item in a list of explicit imports

70+-- An item in a list of explicit imports or exports

70--

71--

71−data ImportType

72+data DeclarationRef

72 -- |

73 -- |

73− -- A type constructor import

74+ -- A type constructor with data constructors

74 --

75 --

75− = TypeImport ProperName (Maybe [ProperName])

76+ = TypeRef ProperName (Maybe [ProperName])

76 -- |

77 -- |

77− -- A declaration import

78+ -- A value

78 --

79 --

79− | NameImport Ident

80+ | ValueRef Ident

80 -- |

81 -- |

81− -- A type class import

82+ -- A type class

82 --

83 --

83− | TypeClassImport ProperName

84+ | TypeClassRef ProperName

84− deriving (Show, D.Data, D.Typeable)

85+ deriving (Show, Eq, D.Data, D.Typeable)

86-- |

87-- |

87-- The data type of declarations

88-- The data type of declarations

@@ -126,7 +127,7 @@ data Declaration

126 -- |

127 -- |

127 -- A module import (module name, optional set of identifiers to import)

128 -- A module import (module name, optional set of identifiers to import)

128 --

129 --

129− | ImportDeclaration ModuleName (Maybe [ImportType])

130+ | ImportDeclaration ModuleName (Maybe [DeclarationRef])

130 -- |

131 -- |

131 -- A type class declaration (name, argument, member declarations)

132 -- A type class declaration (name, argument, member declarations)

132 --

133 --

src/Language/PureScript/ModuleDependencies.hs+1−1

@@ -51,7 +51,7 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp

51 imports _ = []

53getModuleName :: Module -> ModuleName

54−getModuleName (Module mn _) = mn

54+getModuleName (Module mn _ _) = mn

56-- |

57-- Convert a strongly connected component of the module graph to a module

src/Language/PureScript/Parser/Declarations.hs+6−5

@@ -88,14 +88,14 @@ parseImportDeclaration = do

88 reserved "import"

89 indented

90 moduleName' <- moduleName

91− idents <- P.optionMaybe $ parens $ commaSep1 parseExplicitImport

91+ idents <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef

92 return $ ImportDeclaration moduleName' idents

94−parseExplicitImport :: P.Parsec String ParseState ImportType

94+parseDeclarationRef :: P.Parsec String ParseState DeclarationRef

95−parseExplicitImport = NameImport <$> parseIdent

95+parseDeclarationRef = ValueRef <$> parseIdent

96 <|> do name <- properName

97 dctors <- P.optionMaybe $ parens (Just <$> commaSep1 properName <|> lexeme (P.string "..") *> pure Nothing)

98− return $ maybe (TypeClassImport name) (TypeImport name) dctors

98+ return $ maybe (TypeClassRef name) (TypeRef name) dctors

100parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

101parseTypeClassDeclaration = do

@@ -146,9 +146,10 @@ parseModule = do

146 reserved "module"

147 indented

148 name <- moduleName

149+ exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef

149 _ <- lexeme $ P.string "where"

150 _ <- lexeme $ P.string "where"

150 decls <- mark (P.many (same *> parseDeclaration))

151 decls <- mark (P.many (same *> parseDeclaration))

151− return $ Module name decls

152+ return $ Module name decls exports

152

153

153-- |

154-- |

154-- Parse a collection of modules

155-- Parse a collection of modules

src/Language/PureScript/Parser/Types.hs+5−2

@@ -19,13 +19,16 @@ module Language.PureScript.Parser.Types (

19 parseTypeAtom

20) where

22+import Control.Applicative

23+import Control.Monad (when, unless)

24+

22import Language.PureScript.Types

25import Language.PureScript.Types

23import Language.PureScript.Parser.State

26import Language.PureScript.Parser.State

24import Language.PureScript.Parser.Common

27import Language.PureScript.Parser.Common

25−import Control.Applicative

28+import Language.PureScript.Prim

29+

26import qualified Text.Parsec as P

30import qualified Text.Parsec as P

27import qualified Text.Parsec.Expr as P

31import qualified Text.Parsec.Expr as P

28−import Control.Monad (when, unless)

30parseNumber :: P.Parsec String ParseState Type

33parseNumber :: P.Parsec String ParseState Type

31parseNumber = const tyNumber <$> reserved "Number"

34parseNumber = const tyNumber <$> reserved "Number"

src/Language/PureScript/Pretty/Types.hs+1

@@ -28,6 +28,7 @@ import Control.Monad.Unify

29import Language.PureScript.Types

30import Language.PureScript.Pretty.Common

31+import Language.PureScript.Prim

32typeLiterals :: Pattern () Type String

33typeLiterals :: Pattern () Type String

33typeLiterals = mkPattern match

34typeLiterals = mkPattern match

src/Language/PureScript/Prim.hsnew file+69

@@ -0,0 +1,69 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Prim

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.Prim where

16+

17+import Language.PureScript.Kinds

18+import Language.PureScript.Names

19+import Language.PureScript.Types

20+

21+import qualified Data.Map as M

22+

23+-- |

24+-- Type constructor for functions

25+--

26+tyFunction :: Type

27+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")

28+

29+-- |

30+-- Type constructor for strings

31+--

32+tyString :: Type

33+tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")

34+

35+-- |

36+-- Type constructor for numbers

37+--

38+tyNumber :: Type

39+tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")

40+

41+-- |

42+-- Type constructor for booleans

43+--

44+tyBoolean :: Type

45+tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")

46+

47+-- |

48+-- Type constructor for arrays

49+--

50+tyArray :: Type

51+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")

52+

53+-- |

54+-- Smart constructor for function types

55+--

56+function :: Type -> Type -> Type

57+function t1 = TypeApp (TypeApp tyFunction t1)

58+

59+-- |

60+-- The primitive types in the external javascript environment with their associated kinds.

61+--

62+primTypes :: M.Map (Qualified ProperName) Kind

63+primTypes = M.fromList [ (primName "Function" , FunKind Star (FunKind Star Star))

64+ , (primName "Array" , FunKind Star Star)

65+ , (primName "String" , Star)

66+ , (primName "Number" , Star)

67+ , (primName "Boolean" , Star) ]

68+ where

69+ primName name = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName name)

src/Language/PureScript/Sugar/BindingGroups.hs+3−3

@@ -25,7 +25,7 @@ import Data.Data

25import Data.Graph

26import Data.Generics

27import Data.List (nub, intersect)

28−import Control.Applicative ((<$>))

28+import Control.Applicative ((<$>), (<*>), pure)

30import Language.PureScript.Declarations

31import Language.PureScript.Names

@@ -36,13 +36,13 @@ import Language.PureScript.Types

36-- Replace all sets of mutually-recursive declarations in a module with binding groups

37--

38createBindingGroupsModule :: [Module] -> Either String [Module]

39−createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups name ds

39+createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps

41-- |

42-- Collapse all binding groups in a module to individual declarations

43--

44collapseBindingGroupsModule :: [Module] -> [Module]

45−collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)

45+collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps

47-- |

48-- Replace all sets of mutually-recursive declarations with binding groups

src/Language/PureScript/Sugar/CaseDeclarations.hs+2−2

@@ -35,7 +35,7 @@ import Language.PureScript.Scope

35-- Replace all top-level binders in a module with case expressions.

36--

37desugarCasesModule :: [Module] -> Either String [Module]

38−desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> (desugarCases . desugarAbs $ ds)

38+desugarCasesModule ms = forM ms $ \(Module name ds exps) -> Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps

40desugarAbs :: [Declaration] -> [Declaration]

41desugarAbs = everywhere (mkT replace)

@@ -54,7 +54,7 @@ desugarCases :: [Declaration] -> Either String [Declaration]

54desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

55 where

56 desugarRest :: [Declaration] -> Either String [Declaration]

57− desugarRest ((TypeInstanceDeclaration name constraints className tys ds) : rest) =

57+ desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

58 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest

59 desugarRest (d : ds) = (:) d <$> desugarRest ds

60 desugarRest [] = pure []

src/Language/PureScript/Sugar/Names.hs+146−54

@@ -20,18 +20,19 @@ import Data.Maybe (fromMaybe)

20import Data.Data

21import Data.Generics (extM, mkM, everywhereM)

22import Data.Generics.Extras (mkS, extS, everywhereWithContextM')

23+import Data.List (find)

24import Control.Applicative (Applicative(..), (<$>), (<*>))

25import Control.Applicative (Applicative(..), (<$>), (<*>))

25import Control.Monad (foldM)

26import Control.Monad (foldM)

26import Control.Monad.Error

27import Control.Monad.Error

28import qualified Data.Map as M

29import qualified Data.Map as M

29−import qualified Data.Set as S

31import Language.PureScript.Declarations

32import Language.PureScript.Names

33import Language.PureScript.Types

34import Language.PureScript.Values

35+import Language.PureScript.Prim

36-- |

37-- |

37-- The global export environment - every declaration exported from every module.

38-- The global export environment - every declaration exported from every module.

@@ -45,14 +46,14 @@ data Exports = Exports

45 -- |

46 -- |

46 -- The types exported from each module

47 -- The types exported from each module

47 --

48 --

48− { exportedTypes :: S.Set (ProperName, [ProperName])

49+ { exportedTypes :: [(ProperName, [ProperName])]

49 -- |

50 -- |

50 -- The classes exported from each module

51 -- The classes exported from each module

51 --

52 --

52− , exportedTypeClasses :: S.Set ProperName

53+ , exportedTypeClasses :: [ProperName]

53 -- |

54 -- |

54 -- The values exported from each module

55 -- The values exported from each module

55− , exportedValues :: S.Set Ident

56+ , exportedValues :: [Ident]

56 --

57 --

57 } deriving (Show)

58 } deriving (Show)

@@ -92,7 +93,7 @@ updateExportedModule env mn update = do

92-- Adds an empty module to an ExportEnvironment.

93-- Adds an empty module to an ExportEnvironment.

93--

94--

94addEmptyModule :: ExportEnvironment -> ModuleName -> ExportEnvironment

95addEmptyModule :: ExportEnvironment -> ModuleName -> ExportEnvironment

95−addEmptyModule env name = M.insert name (Exports S.empty S.empty S.empty) env

96+addEmptyModule env name = M.insert name (Exports [] [] []) env

97-- |

98-- |

98-- Adds a type belonging to a module to the export environment.

99-- Adds a type belonging to a module to the export environment.

@@ -119,13 +120,14 @@ addValue env mn name = updateExportedModule env mn $ \m -> do

119 return $ m { exportedValues = values }

120 return $ m { exportedValues = values }

120

121

121-- |

122-- |

122−-- Adds an export to a map of exports of that type.

123+-- Adds an entry to a list of exports unless it is already present, in which case an error is

124+-- returned.

123--

125--

124−addExport :: (Ord s, Show s) => S.Set s -> s -> Either String (S.Set s)

126+addExport :: (Eq a, Show a) => [a] -> a -> Either String [a]

125addExport exports name =

127addExport exports name =

126− if S.member name exports

128+ if name `elem` exports

127 then throwError $ "Multiple definitions for '" ++ show name ++ "'"

129 then throwError $ "Multiple definitions for '" ++ show name ++ "'"

128− else return $ S.insert name exports

130+ else return $ name : exports

129

131

130-- |

132-- |

131-- Replaces all local names with qualified names within a set of modules.

133-- Replaces all local names with qualified names within a set of modules.

@@ -137,22 +139,23 @@ desugarImports modules = do

137 where

139 where

138 renameInModule' exports m = rethrowForModule m $ do

140 renameInModule' exports m = rethrowForModule m $ do

139 imports <- resolveImports exports m

141 imports <- resolveImports exports m

140− renameInModule imports m

142+ renameInModule imports exports m

141

143

142-- |

144-- |

143-- Rethrow an error with the name of the current module in the case of a failure

145-- Rethrow an error with the name of the current module in the case of a failure

144--

146--

145rethrowForModule :: Module -> Either String a -> Either String a

147rethrowForModule :: Module -> Either String a -> Either String a

146−rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)

148+rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)

147

149

148-- |

150-- |

149−-- Replaces all local names with qualified names within a module.

151+-- Replaces all local names with qualified names within a module and checks that all existing

152+-- qualified names are valid.

150--

153--

151−renameInModule :: ImportEnvironment -> Module -> Either String Module

154+renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module

152−renameInModule imports (Module mn decls) =

155+renameInModule imports exports (Module mn decls exps) =

153− Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)

156+ Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps

154 where

157 where

155− updateDecl (TypeInstanceDeclaration name cs (Qualified Nothing cn) ts ds) =

158+ updateDecl (TypeInstanceDeclaration name cs cn ts ds) =

156 TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds

159 TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds

157 updateDecl d = return d

160 updateDecl d = return d

158

161

@@ -161,43 +164,81 @@ renameInModule imports (Module mn decls) =

161 ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

164 ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

162 where

165 where

163 bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)

166 bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)

164− bindFunctionArgs bound (Var (Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName ident)

167+ bindFunctionArgs bound (Var name@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name)

168+ bindFunctionArgs bound (Var name@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name)

165 bindFunctionArgs bound other = return (bound, other)

169 bindFunctionArgs bound other = return (bound, other)

166 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

170 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

167 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

171 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

168 updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name

172 updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name

169 updateVars other = return other

173 updateVars other = return other

170−

171− updateValue (Constructor (Qualified Nothing nm)) =

172− Constructor <$> updateDataConstructorName nm

174+ updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

173 updateValue v = return v

175 updateValue v = return v

174−

175− updateBinder (ConstructorBinder (Qualified Nothing nm) b) =

176− ConstructorBinder <$> updateDataConstructorName nm <*> pure b

176+ updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b

177 updateBinder v = return v

178− updateType (TypeConstructor (Qualified Nothing nm)) =

179− TypeConstructor <$> updateTypeName nm

178+ updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name

180− updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) =

181− SaturatedTypeSynonym <$> updateTypeName nm <*> mapM updateType tys

179+ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys

182− updateType (ConstrainedType cs t) =

183− ConstrainedType <$> updateConstraints cs <*> pure t

180+ updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t

184 updateType t = return t

181 updateType t = return t

185− updateConstraints = mapM updateConstraint

182+ updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

186− updateConstraint (Qualified Nothing nm, ts) = (,) <$> updateClassName nm <*> pure ts

183+

187− updateConstraint other = return other

188− updateTypeName = update "type" importedTypes

184+ updateTypeName (Qualified Nothing name) = update "type" importedTypes name

185+ updateTypeName (Qualified (Just mn) name) = do

186+ modExports <- getExports mn

187+ case name `lookup` exportedTypes modExports of

188+ Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn) name) ++ "'"

189+ _ -> return $ Qualified (Just mn) name

190+

191+ updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name

192+ updateDataConstructorName (Qualified (Just mn) name) = do

193+ modExports <- getExports mn

194+ let allDcons = join $ snd `map` exportedTypes modExports

195+ if name `elem` allDcons

196+ then return $ Qualified (Just mn) name

197+ else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn) name) ++ "'"

198+

189− updateClassName = update "type class" importedTypeClasses

199+ updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name

200+ updateClassName (Qualified (Just mn) name) = check "type class" exportedTypeClasses mn name

201+

190− updateValueName = update "value" importedValues

202+ updateValueName (Qualified Nothing name) = update "value" importedValues name

191− updateDataConstructorName = update "data constructor" importedDataConstructors

203+ updateValueName (Qualified (Just mn) name) = check "value" exportedValues mn name

204+

205+ -- Replace an unqualified name with a qualified

206+ update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)

192− update t get nm = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show nm ++ "'") return $ M.lookup nm (get imports)

207+ update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)

208+

209+ -- Check that a qualified name is valid

210+ check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)

211+ check t get mn name = do

212+ modExports <- getExports mn

213+ if name `elem` get modExports

214+ then return $ Qualified (Just mn) name

215+ else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn) name) ++ "'"

216+

217+ -- Gets the exports for a module, or an error message if the module doesn't exist

218+ getExports :: ModuleName -> Either String Exports

219+ getExports mn = maybe (throwError $ "Unknown module '" ++ show mn ++ "'") return $ M.lookup mn exports

193

220

194-- |

221-- |

195-- Finds all exported declarations in a set of modules.

222-- Finds all exported declarations in a set of modules.

196--

223--

197findExports :: [Module] -> Either String ExportEnvironment

224findExports :: [Module] -> Either String ExportEnvironment

198−findExports = foldM addModule M.empty

225+findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports

199 where

226 where

227+

228+ -- The exported types from the Prim module

229+ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []

230+ where

231+ mkTypeEntry (Qualified _ name) = (name, [])

232+

233+ -- Add all of the exported declarations from a module to the global export environment

234+ addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment

200− addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds

235+ addModule env m@(Module mn ds Nothing) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds

236+ addModule env m@(Module mn ds (Just exps)) = rethrowForModule m $ do

237+ env' <- foldM (addDecl mn) (addEmptyModule env mn) ds

238+ filterExports mn exps env'

239+

240+ -- Add a declaration from a module to the global export environment

241+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment

201 addDecl mn env (TypeClassDeclaration tcn _ ds) = do

242 addDecl mn env (TypeClassDeclaration tcn _ ds) = do

202 env' <- addTypeClass env mn tcn

243 env' <- addTypeClass env mn tcn

203 foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds

244 foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds

@@ -208,10 +249,61 @@ findExports = foldM addModule M.empty

208 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

249 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

209 addDecl _ env _ = return env

250 addDecl _ env _ = return env

210

251

252+-- |

253+-- Filters the exports for a module to ensure only explicit exports are kept in the global exports

254+-- environment.

255+--

256+filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment

257+filterExports mn exps env = do

258+ let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

259+ moduleExports' <- filterModule exps moduleExports

260+ return $ M.insert mn moduleExports' env

261+ where

262+

263+ -- Filter the exports for the specific module

264+ filterModule :: [DeclarationRef] -> Exports -> Either String Exports

265+ filterModule exps exported = do

266+ types <- foldM (filterTypes $ exportedTypes exported) [] exps

267+ values <- foldM (filterValues $ exportedValues exported) [] exps

268+ classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps

269+ return exported { exportedTypes = types, exportedTypeClasses = classes, exportedValues = values }

270+

271+ -- Ensure the exported types and data constructors exist in the module and add them to the set of

272+ -- exports

273+ filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either String [(ProperName, [ProperName])]

274+ filterTypes exps result (TypeRef name expDcons) = do

275+ dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` exps

276+ dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

277+ return $ (name, dcons') : result

278+ filterTypes exps result _ = return result

279+

280+ -- Ensure the exported data constructors exists for a type and add them to the list of exports

281+ filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName]

282+ filterDcons tcon exps result name =

283+ if name `elem` exps

284+ then return $ name : result

285+ else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'"

286+

287+ -- Ensure the exported classes exist in the module and add them to the set of exports

288+ filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either String [ProperName]

289+ filterClasses exps result (TypeClassRef name) =

290+ if name `elem` exps

291+ then return $ name : result

292+ else throwError $ "Cannot export undefined type class '" ++ show name ++ "'"

293+ filterClasses exps result _ = return result

294+

295+ -- Ensure the exported values exist in the module and add them to the set of exports

296+ filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either String [Ident]

297+ filterValues exps result (ValueRef name) =

298+ if name `elem` exps

299+ then return $ name : result

300+ else throwError $ "Cannot export undefined value '" ++ show name ++ "'"

301+ filterValues exps result _ = return result

302+

211-- |

303-- |

212-- Type representing a set of declarations being explicitly imported from a module

304-- Type representing a set of declarations being explicitly imported from a module

213--

305--

214−type ExplicitImports = [ImportType]

306+type ExplicitImports = [DeclarationRef]

215

307

216-- |

308-- |

217-- Finds the imports within a module, mapping the imported module name to an optional set of

309-- Finds the imports within a module, mapping the imported module name to an optional set of

@@ -227,7 +319,7 @@ findImports = foldl findImports' M.empty

227-- Constructs a local environment for a module.

319-- Constructs a local environment for a module.

228--

320--

229resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment

321resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment

230−resolveImports env (Module currentModule decls) =

322+resolveImports env (Module currentModule decls _) =

231 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

323 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

232 where

324 where

233 -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported

325 -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported

@@ -249,34 +341,34 @@ resolveImport currentModule importModule exp imp i = case i of

249 -- Import everything from a module

341 -- Import everything from a module

250 importAll :: ImportEnvironment -> Either String ImportEnvironment

342 importAll :: ImportEnvironment -> Either String ImportEnvironment

251 importAll imp = do

343 importAll imp = do

252− imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeImport name (Just dctors))) imp (S.toList $ exportedTypes exp)

344+ imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imp (exportedTypes exp)

253− imp'' <- foldM (\m name -> importExplicit m (NameImport name)) imp' (S.toList $ exportedValues exp)

345+ imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exp)

254− foldM (\m name -> importExplicit m (TypeClassImport name)) imp'' (S.toList $ exportedTypeClasses exp)

346+ foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exp)

255

347

256 -- Import something explicitly

348 -- Import something explicitly

257− importExplicit :: ImportEnvironment -> ImportType -> Either String ImportEnvironment

349+ importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment

258− importExplicit imp (NameImport name) = do

350+ importExplicit imp (ValueRef name) = do

259 checkImportExists "value" values name

351 checkImportExists "value" values name

260 values' <- updateImports (importedValues imp) name

352 values' <- updateImports (importedValues imp) name

261 return $ imp { importedValues = values' }

353 return $ imp { importedValues = values' }

262− importExplicit imp (TypeImport name dctors) = do

354+ importExplicit imp (TypeRef name dctors) = do

263 checkImportExists "type" types name

355 checkImportExists "type" types name

264 types' <- updateImports (importedTypes imp) name

356 types' <- updateImports (importedTypes imp) name

265 let allDctors = allExportedDataConstructors name

357 let allDctors = allExportedDataConstructors name

266 dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

358 dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

267 dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'

359 dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'

268 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }

360 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }

269− importExplicit imp (TypeClassImport name) = do

361+ importExplicit imp (TypeClassRef name) = do

270 checkImportExists "type class" classes name

362 checkImportExists "type class" classes name

271 typeClasses' <- updateImports (importedTypeClasses imp) name

363 typeClasses' <- updateImports (importedTypeClasses imp) name

272 return $ imp { importedTypeClasses = typeClasses' }

364 return $ imp { importedTypeClasses = typeClasses' }

273

365

274 -- Find all exported data constructors for a given type

366 -- Find all exported data constructors for a given type

275 allExportedDataConstructors :: ProperName -> [ProperName]

367 allExportedDataConstructors :: ProperName -> [ProperName]

276− allExportedDataConstructors name = fromMaybe [] $ name `lookup` S.toList (exportedTypes exp)

368+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exp

277

369

278 -- Add something to the ImportEnvironment if it does not already exist there

370 -- Add something to the ImportEnvironment if it does not already exist there

279− updateImports :: (Ord id, Show id) => M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))

371+ updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))

280 updateImports m name = case M.lookup name m of

372 updateImports m name = case M.lookup name m of

281 Nothing -> return $ M.insert name (Qualified (Just importModule) name) m

373 Nothing -> return $ M.insert name (Qualified (Just importModule) name) m

282 Just x@(Qualified (Just mn) _) -> throwError $

374 Just x@(Qualified (Just mn) _) -> throwError $

@@ -286,18 +378,18 @@ resolveImport currentModule importModule exp imp i = case i of

286

378

287 -- The available values, types, and classes in the module being imported

379 -- The available values, types, and classes in the module being imported

288 values = exportedValues exp

380 values = exportedValues exp

289− types = fst `S.map` exportedTypes exp

381+ types = fst `map` exportedTypes exp

290 classes = exportedTypeClasses exp

382 classes = exportedTypeClasses exp

291

383

292 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

384 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

293 -- from

385 -- from

294 checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName

386 checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName

295− checkDctorExists names = checkImportExists "data constructor" (S.fromList names)

387+ checkDctorExists = checkImportExists "data constructor"

296

388

297 -- Check that an explicitly imported item exists in the module it is being imported from

389 -- Check that an explicitly imported item exists in the module it is being imported from

298− checkImportExists :: (Show a, Ord a, Eq a) => String -> S.Set a -> a -> Either String a

390+ checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either String a

299 checkImportExists t exports item =

391 checkImportExists t exports item =

300− if item `S.member` exports

392+ if item `elem` exports

301 then return item

393 then return item

302 else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"

394 else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"

303

395

src/Language/PureScript/Sugar/Operators.hs+2−2

@@ -49,11 +49,11 @@ rebracket :: [Module] -> Either String [Module]

49rebracket = go M.empty []

50 where

51 go _ rb [] = return . reverse $ rb

52− go m rb (Module name ds : ms) = do

52+ go m rb (Module name ds exps : ms) = do

53 m' <- M.union m <$> collectFixities m name ds

54 let opTable = customOperatorTable m'

55 ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds

56− go m' (Module name (G.everywhere (G.mkT removeParens) ds') : rb) ms

56+ go m' (Module name (G.everywhere (G.mkT removeParens) ds') exps : rb) ms

58removeParens :: Value -> Value

59removeParens (Parens val) = val

src/Language/PureScript/Sugar/TypeClasses.hs+2−1

@@ -25,6 +25,7 @@ import Language.PureScript.Types

25import Language.PureScript.Values

26import Language.PureScript.CodeGen.JS.AST

27import Language.PureScript.Sugar.CaseDeclarations

28+import Language.PureScript.Prim

29import qualified Data.Map as M

30import qualified Data.Map as M

@@ -47,7 +48,7 @@ desugarTypeClasses :: [Module] -> Either String [Module]

47desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

48desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

49desugarModule :: Module -> Desugar Module

50desugarModule :: Module -> Desugar Module

50−desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl name) decls

51+desugarModule (Module name decls exps) = Module name <$> concat <$> mapM (desugarDecl name) decls <*> pure exps

52-- |

53-- |

53-- Desugar type class and type class instance declarations

54-- Desugar type class and type class instance declarations

src/Language/PureScript/Sugar/TypeDeclarations.hs+1−1

@@ -30,7 +30,7 @@ import Language.PureScript.Values

30-- Replace all top level type declarations in a module with type annotations

31--

32desugarTypeDeclarationsModule :: [Module] -> Either String [Module]

33−desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds

33+desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> Module name <$> desugarTypeDeclarations ds <*> pure exps

35-- |

36-- Replace all top level type declarations with type annotations

src/Language/PureScript/TypeChecker.hs+1

@@ -37,6 +37,7 @@ import Language.PureScript.Values

37import Language.PureScript.Kinds

38import Language.PureScript.Declarations

39import Language.PureScript.Sugar.TypeClasses

40+import Language.PureScript.Prim

41addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

42addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

42addDataType moduleName name args dctors ctorKind = do

43addDataType moduleName name args dctors ctorKind = do

src/Language/PureScript/TypeChecker/Monad.hs+2−11

@@ -23,6 +23,7 @@ import Language.PureScript.Kinds

23import Language.PureScript.Values

24import Language.PureScript.Names

25import Language.PureScript.Declarations

26+import Language.PureScript.Prim

27import Data.Data

28import Data.Data

28import Data.Maybe

29import Data.Maybe

@@ -83,21 +84,11 @@ data Environment = Environment {

83 , typeClassDictionaries :: [TypeClassDictionaryInScope]

84 , typeClassDictionaries :: [TypeClassDictionaryInScope]

84 } deriving (Show)

85 } deriving (Show)

86−-- |

87−-- The basic types existing in the external javascript environment

88−--

89−jsTypes ::M.Map (Qualified ProperName) Kind

90−jsTypes = M.fromList [ (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Function"), FunKind Star (FunKind Star Star))

91− , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array"), FunKind Star Star)

92− , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "String"), Star)

93− , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Number"), Star)

94− , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean"), Star) ]

95−

96-- |

87-- |

97-- The initial environment with no values and only the default javascript types defined

88-- The initial environment with no values and only the default javascript types defined

98--

89--

99initEnvironment :: Environment

90initEnvironment :: Environment

100−initEnvironment = Environment M.empty jsTypes M.empty M.empty []

91+initEnvironment = Environment M.empty primTypes M.empty M.empty []

101

102-- |

93-- |

103-- Temporarily bind a collection of names to values

94-- Temporarily bind a collection of names to values

src/Language/PureScript/TypeChecker/Types.hs+1

@@ -56,6 +56,7 @@ import Language.PureScript.TypeChecker.Monad

56import Language.PureScript.TypeChecker.Kinds

57import Language.PureScript.TypeChecker.Synonyms

58import Language.PureScript.Pretty

59+import Language.PureScript.Prim

60import Control.Monad.State

61import Control.Monad.State

61import Control.Monad.Error

62import Control.Monad.Error

src/Language/PureScript/Types.hs−36

@@ -88,42 +88,6 @@ data Type

88 --

89 | PrettyPrintArray Type deriving (Show, Eq, Data, Typeable)

91−-- |

92−-- Type constructor for functions

93−--

94−tyFunction :: Type

95−tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")

96−

97−-- |

98−-- Type constructor for strings

99−--

100−tyString :: Type

101−tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")

102−

103−-- |

104−-- Type constructor for numbers

105−--

106−tyNumber :: Type

107−tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")

108−

109−-- |

110−-- Type constructor for booleans

111−--

112−tyBoolean :: Type

113−tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")

114−

115−-- |

116−-- Type constructor for arrays

117−--

118−tyArray :: Type

119−tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")

120−

121−-- |

122−-- Smart constructor for function types

123−--

124−function :: Type -> Type -> Type

125−function t1 = TypeApp (TypeApp tyFunction t1)

126−

127-- |

91-- |

128-- Convert a row to a list of pairs of labels and types

92-- Convert a row to a list of pairs of labels and types

129--

93--