b314ba1 · rowtype-yoga/purescript-native

purescript.cabal+1−1

compare with golang

unifiedsplit

@@ -29,6 +29,7 @@ library

29 Language.PureScript.Constants

30 Language.PureScript.Options

31 Language.PureScript.Declarations

32+ Language.PureScript.Environment

32 Language.PureScript.Kinds

33 Language.PureScript.Kinds

33 Language.PureScript.Names

34 Language.PureScript.Names

34 Language.PureScript.Types

35 Language.PureScript.Types

@@ -71,7 +72,6 @@ library

71 Language.PureScript.Pretty.Kinds

72 Language.PureScript.Pretty.Kinds

72 Language.PureScript.Pretty.Types

73 Language.PureScript.Pretty.Types

73 Language.PureScript.Pretty.Values

74 Language.PureScript.Pretty.Values

74− Language.PureScript.Prim

75 Language.PureScript.TypeChecker

76 Language.PureScript.TypeChecker.Kinds

77 Language.PureScript.TypeChecker.Monad

src/Language/PureScript.hs+1

@@ -28,6 +28,7 @@ import Language.PureScript.Pretty as P

28import Language.PureScript.Sugar as P

29import Language.PureScript.Options as P

30import Language.PureScript.ModuleDependencies as P

31+import Language.PureScript.Environment as P

31import Language.PureScript.DeadCodeElimination as P

32import Language.PureScript.DeadCodeElimination as P

32

33

33import qualified Language.PureScript.Constants as C

34import qualified Language.PureScript.Constants as C

src/Language/PureScript/CodeGen/Externs.hs+50−36

@@ -17,55 +17,69 @@ module Language.PureScript.CodeGen.Externs (

17 moduleToPs

18) where

19

20+import Data.Maybe (fromMaybe, mapMaybe)

20−import Data.List (intercalate)

21+import Data.List (intercalate, find)

21

22

22import qualified Data.Map as M

23import qualified Data.Map as M

23

24

24import Control.Monad.Writer

25import Control.Monad.Writer

25

26

26import Language.PureScript.Declarations

27import Language.PureScript.Declarations

27−import Language.PureScript.TypeChecker.Monad

28import Language.PureScript.Pretty

29import Language.PureScript.Names

30−import Language.PureScript.Types

30+import Language.PureScript.Values

31−import Language.PureScript.Kinds

31+import Language.PureScript.Environment

32

33-- |

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

35--

36moduleToPs :: Module -> Environment -> String

37+moduleToPs (Module _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"

37−moduleToPs (Module moduleName _ exts) env = intercalate "\n" . execWriter $ do

38+moduleToPs (Module moduleName _ (Just exts)) env = intercalate "\n" . execWriter $ do

38 tell ["module " ++ runModuleName moduleName ++ " where"]

39 tell ["module " ++ runModuleName moduleName ++ " where"]

39− let typesExported = getTypesExportedFrom moduleName exts env

40+ mapM_ exportToPs exts

40− forM_ typesExported $ \(pn, kind) ->

41− tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]

42− let namesExported = getNamesExportedFrom moduleName exts env

43− forM_ namesExported $ \(ident, ty) ->

44− tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]

45−

46−getNamesExportedFrom :: ModuleName -> Maybe [DeclarationRef] -> Environment -> [(Ident, Type)]

47−getNamesExportedFrom moduleName exps env =

48− [ (ident, ty)

49− | ((moduleName', ident), (ty, nameKind)) <- M.toList . names $ env

50− , moduleName == moduleName'

51− , nameKind `elem` [Value, Extern ForeignImport]

52− , isExported ident exps

53− ]

54 where

41 where

55− isExported :: Ident -> Maybe [DeclarationRef] -> Bool

56− isExported _ Nothing = True

57− isExported ident (Just exps') = ValueRef ident `elem` exps'

58

42

59−getTypesExportedFrom :: ModuleName -> Maybe [DeclarationRef] -> Environment -> [(ProperName, Kind)]

43+ exportToPs :: DeclarationRef -> Writer [String] ()

60−getTypesExportedFrom moduleName exps env =

44+ exportToPs (TypeRef pn dctors) = do

61− [ (pn, kind)

62− | ((Qualified (Just moduleName') pn), kind) <- M.toList . types $ env

45+ case Qualified (Just moduleName) pn `M.lookup` types env of

63− , moduleName == moduleName'

46+ Nothing -> error $ show pn ++ " has no kind in exportToPs"

64− , isExported pn exps

47+ Just (kind, ExternData) ->

65− ]

48+ tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]

66− where

49+ Just (_, DataType args tys) -> do

67− isExported :: ProperName -> Maybe [DeclarationRef] -> Bool

50+ let dctors' = fromMaybe (map fst tys) dctors

68− isExported _ Nothing = True

51+ printDctor dctor = case dctor `lookup` tys of

69− isExported pn (Just exps') = flip any exps' $ \e -> case e of

52+ Nothing -> Nothing

70− TypeRef pn' _ | pn == pn' -> True

53+ Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)

71− _ -> False

54+ tell ["data " ++ show pn ++ " " ++ unwords args ++ " = " ++ intercalate " | " (mapMaybe printDctor dctors')]

55+ Just (_, TypeSynonym) ->

56+ case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of

57+ Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"

58+ Just (args, synTy) ->

59+ tell ["type " ++ show pn ++ " " ++ unwords args ++ " = " ++ prettyPrintType synTy]

60+ _ -> error "Invalid input in exportToPs"

61+

62+ exportToPs (ValueRef ident) =

63+ case (moduleName, ident) `M.lookup` names env of

64+ Nothing -> error $ show ident ++ " has no type in exportToPs"

65+ Just (ty, nameKind) | nameKind == Value || nameKind == Extern ForeignImport ->

66+ tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]

67+ _ -> return ()

68+ exportToPs (TypeClassRef className) =

69+ case Qualified (Just moduleName) className `M.lookup` typeClasses env of

70+ Nothing -> error $ show className ++ " has no type class definition in exportToPs"

71+ Just (args, ds) -> do

72+ tell ["class " ++ show className ++ " " ++ unwords args ++ " where"]

73+ forM_ (filter (isValueExported . fst) ds) $ \(member ,ty) ->

74+ tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]

75+ exportToPs (TypeInstanceRef ident) = do

76+ let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =

77+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env

78+ let constraintsText = case fromMaybe [] deps of

79+ [] -> ""

80+ cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

81+ tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]

82+

83+ isValueExported :: Ident -> Bool

84+ isValueExported ident = ValueRef ident `elem` exts

85+

src/Language/PureScript/CodeGen/JS.hs+2−3

@@ -30,7 +30,6 @@ import Control.Monad (replicateM, forM)

30

31import qualified Data.Map as M

32

33−import Language.PureScript.TypeChecker (Environment(..))

34import Language.PureScript.Values

33import Language.PureScript.Values

35import Language.PureScript.Names

34import Language.PureScript.Names

36import Language.PureScript.Scope

35import Language.PureScript.Scope

@@ -41,7 +40,7 @@ import Language.PureScript.CodeGen.JS.AST as AST

41import Language.PureScript.Types

40import Language.PureScript.Types

42import Language.PureScript.Optimizer

41import Language.PureScript.Optimizer

43import Language.PureScript.CodeGen.Common

42import Language.PureScript.CodeGen.Common

44−import Language.PureScript.Prim

43+import Language.PureScript.Environment

45import qualified Language.PureScript.Constants as C

44import qualified Language.PureScript.Constants as C

46

45

47-- |

46-- |

@@ -90,7 +89,7 @@ declToJs _ _ _ _ = Nothing

90exportToJs :: DeclarationRef -> [JS]

89exportToJs :: DeclarationRef -> [JS]

91exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Escaped . runProperName)

90exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Escaped . runProperName)

92exportToJs (ValueRef name) = [export name]

91exportToJs (ValueRef name) = [export name]

93−exportToJs (TypeInstanceRef name _ _) = [export name]

92+exportToJs (TypeInstanceRef name) = [export name]

94exportToJs _ = []

93exportToJs _ = []

95

94

96-- |

95-- |

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

@@ -44,7 +44,7 @@ eliminateDeadCode entryPoints ms = map go ms

44 filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef

45 filterExport decls r@(TypeRef name _) | (any $ typeExists name) decls = Just r

46 filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r

47− filterExport decls r@(TypeInstanceRef name _ _) | (any $ valueExists name) decls = Just r

47+ filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r

48 filterExport _ _ = Nothing

49

50 valueExists :: Ident -> Declaration -> Bool

@@ -56,7 +56,7 @@ eliminateDeadCode entryPoints ms = map go ms

56 typeExists :: ProperName -> Declaration -> Bool

57 typeExists name (DataDeclaration name' _ _) = name == name'

58 typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls

59− typeExists _ _ = False

59+ typeExists _ _ = False

60

61type Key = (ModuleName, Either Ident ProperName)

62

src/Language/PureScript/Declarations.hs+2−1

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

21import Language.PureScript.Names

22import Language.PureScript.Kinds

23import Language.PureScript.CodeGen.JS.AST

24+import Language.PureScript.Environment

24

25

25import qualified Data.Data as D

26import qualified Data.Data as D

26

27

@@ -64,7 +65,7 @@ data DeclarationRef

64 -- |

65 -- |

65 -- A type class instance, created during typeclass desugaring (name, class name, instance types)

66 -- A type class instance, created during typeclass desugaring (name, class name, instance types)

66 --

67 --

67− | TypeInstanceRef Ident (Qualified ProperName) [Type]

68+ | TypeInstanceRef Ident

68 deriving (Show, Eq, D.Data, D.Typeable)

69 deriving (Show, Eq, D.Data, D.Typeable)

69

70

70-- |

71-- |

src/Language/PureScript/Environment.hsnew file+188

@@ -0,0 +1,188 @@

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+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module Language.PureScript.Environment where

18+

19+import Data.Data

20+

21+import Language.PureScript.Names

22+import Language.PureScript.Types

23+import Language.PureScript.Kinds

24+import Language.PureScript.Values

25+import qualified Language.PureScript.Constants as C

26+

27+import qualified Data.Map as M

28+

29+-- |

30+-- The @Environment@ defines all values and types which are currently in scope:

31+--

32+data Environment = Environment {

33+ -- |

34+ -- Value names currently in scope

35+ --

36+ names :: M.Map (ModuleName, Ident) (Type, NameKind)

37+ -- |

38+ -- Type names currently in scope

39+ --

40+ , types :: M.Map (Qualified ProperName) (Kind, TypeKind)

41+ -- |

42+ -- Data constructors currently in scope, along with their associated data type constructors

43+ --

44+ , dataConstructors :: M.Map (Qualified ProperName) (ProperName, Type)

45+ -- |

46+ -- Type synonyms currently in scope

47+ --

48+ , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)

49+ -- |

50+ -- Available type class dictionaries

51+ --

52+ , typeClassDictionaries :: [TypeClassDictionaryInScope]

53+ -- |

54+ -- Type classes

55+ --

56+ , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)])

57+ } deriving (Show)

58+

59+-- |

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

61+--

62+initEnvironment :: Environment

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

64+

65+-- |

66+-- The type of a foreign import

67+--

68+data ForeignImportType

69+ -- |

70+ -- A regular foreign import

71+ --

72+ = ForeignImport

73+ -- |

74+ -- A foreign import which contains inline Javascript as a string literal

75+ --

76+ | InlineJavascript

77+ -- |

78+ -- A type class dictionary member accessor import, generated during desugaring of type class declarations

79+ --

80+ | TypeClassAccessorImport deriving (Show, Eq, Data, Typeable)

81+

82+-- |

83+-- The kind of a name

84+--

85+data NameKind

86+ -- |

87+ -- A value introduced as a binding in a module

88+ --

89+ = Value

90+ -- |

91+ -- A foreign import

92+ --

93+ | Extern ForeignImportType

94+ -- |

95+ -- A local name introduced using a lambda abstraction, variable introduction or binder

96+ --

97+ | LocalVariable

98+ -- |

99+ -- A data constructor

100+ --

101+ | DataConstructor

102+ -- |

103+ -- A type class dictionary, generated during desugaring of type class declarations

104+ --

105+ | TypeInstanceDictionaryValue

106+ -- |

107+ -- A type instance member, generated during desugaring of type class declarations

108+ --

109+ | TypeInstanceMember deriving (Show, Eq, Data, Typeable)

110+

111+-- |

112+-- The kinds of a type

113+--

114+data TypeKind

115+ -- |

116+ -- Data type

117+ --

118+ = DataType [String] [(ProperName, [Type])]

119+ -- |

120+ -- Type synonym

121+ --

122+ | TypeSynonym

123+ -- |

124+ -- Foreign data

125+ --

126+ | ExternData

127+ -- |

128+ -- A local type variable

129+ --

130+ | LocalTypeVariable deriving (Show, Eq, Data, Typeable)

131+

132+-- |

133+-- Construct a ProperName in the Prim module

134+--

135+primName :: String -> Qualified ProperName

136+primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

137+

138+-- |

139+-- Construct a type in the Prim module

140+--

141+primTy :: String -> Type

142+primTy = TypeConstructor . primName

143+

144+-- |

145+-- Type constructor for functions

146+--

147+tyFunction :: Type

148+tyFunction = primTy "Function"

149+

150+-- |

151+-- Type constructor for strings

152+--

153+tyString :: Type

154+tyString = primTy "String"

155+

156+-- |

157+-- Type constructor for numbers

158+--

159+tyNumber :: Type

160+tyNumber = primTy "Number"

161+

162+-- |

163+-- Type constructor for booleans

164+--

165+tyBoolean :: Type

166+tyBoolean = primTy "Boolean"

167+

168+-- |

169+-- Type constructor for arrays

170+--

171+tyArray :: Type

172+tyArray = primTy "Array"

173+

174+-- |

175+-- Smart constructor for function types

176+--

177+function :: Type -> Type -> Type

178+function t1 = TypeApp (TypeApp tyFunction t1)

179+

180+-- |

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

182+--

183+primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)

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

185+ , (primName "Array" , (FunKind Star Star, ExternData))

186+ , (primName "String" , (Star, ExternData))

187+ , (primName "Number" , (Star, ExternData))

188+ , (primName "Boolean" , (Star, ExternData)) ]

src/Language/PureScript/Names.hs−46

@@ -21,52 +21,6 @@ import Data.List

21import Data.Data

22import Data.Function (on)

23

24−-- |

25−-- The type of a foreign import

26−--

27−data ForeignImportType

28− -- |

29− -- A regular foreign import

30− --

31− = ForeignImport

32− -- |

33− -- A foreign import which contains inline Javascript as a string literal

34− --

35− | InlineJavascript

36− -- |

37− -- A type class dictionary member accessor import, generated during desugaring of type class declarations

38− --

39− | TypeClassAccessorImport deriving (Show, Eq, Data, Typeable)

40−

41−-- |

42−-- The type of a name

43−--

44−data NameKind

45− -- |

46− -- A value introduced as a binding in a module

47− --

48− = Value

49− -- |

50− -- A foreign import

51− --

52− | Extern ForeignImportType

53− -- |

54− -- A local name introduced using a lambda abstraction, variable introduction or binder

55− --

56− | LocalVariable

57− -- |

58− -- A data constructor

59− --

60− | DataConstructor

61− -- |

62− -- A type class dictionary, generated during desugaring of type class declarations

63− --

64− | TypeInstanceDictionaryValue

65− -- |

66− -- A type instance member, generated during desugaring of type class declarations

67− --

68− | TypeInstanceMember deriving (Show, Eq, Data, Typeable)

69−

70-- |

24-- |

71-- Names for value identifiers

25-- Names for value identifiers

72--

26--

src/Language/PureScript/Parser/Declarations.hs+1−1

@@ -29,8 +29,8 @@ import Language.PureScript.Declarations

29import Language.PureScript.Parser.Values

30import Language.PureScript.Parser.Types

31import Language.PureScript.Parser.Kinds

32−import Language.PureScript.Names

33import Language.PureScript.CodeGen.JS.AST

32import Language.PureScript.CodeGen.JS.AST

33+import Language.PureScript.Environment

34

35parseDataDeclaration :: P.Parsec String ParseState Declaration

36parseDataDeclaration = do

src/Language/PureScript/Parser/Types.hs+1−1

@@ -25,7 +25,7 @@ import Control.Monad (when, unless)

25import Language.PureScript.Types

26import Language.PureScript.Parser.State

27import Language.PureScript.Parser.Common

28−import Language.PureScript.Prim

28+import Language.PureScript.Environment

29

30import qualified Text.Parsec as P

31import qualified Text.Parsec.Expr as P

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

@@ -29,7 +29,7 @@ import Control.Monad.Unify

29

30import Language.PureScript.Types

31import Language.PureScript.Pretty.Common

32−import Language.PureScript.Prim

32+import Language.PureScript.Environment

33

34typeLiterals :: Pattern () Type String

35typeLiterals = mkPattern match

src/Language/PureScript/Prim.hsdeleted−81

@@ -1,81 +0,0 @@

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 Language.PureScript.Constants as C

22−

23−import qualified Data.Map as M

24−

25−-- |

26−-- Construct a ProperName in the Prim module

27−--

28−primName :: String -> Qualified ProperName

29−primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

30−

31−-- |

32−-- Construct a type in the Prim module

33−--

34−primTy :: String -> Type

35−primTy = TypeConstructor . primName

36−

37−-- |

38−-- Type constructor for functions

39−--

40−tyFunction :: Type

41−tyFunction = primTy "Function"

42−

43−-- |

44−-- Type constructor for strings

45−--

46−tyString :: Type

47−tyString = primTy "String"

48−

49−-- |

50−-- Type constructor for numbers

51−--

52−tyNumber :: Type

53−tyNumber = primTy "Number"

54−

55−-- |

56−-- Type constructor for booleans

57−--

58−tyBoolean :: Type

59−tyBoolean = primTy "Boolean"

60−

61−-- |

62−-- Type constructor for arrays

63−--

64−tyArray :: Type

65−tyArray = primTy "Array"

66−

67−-- |

68−-- Smart constructor for function types

69−--

70−function :: Type -> Type -> Type

71−function t1 = TypeApp (TypeApp tyFunction t1)

72−

73−-- |

74−-- The primitive types in the external javascript environment with their associated kinds.

75−--

76−primTypes :: M.Map (Qualified ProperName) Kind

77−primTypes = M.fromList [ (primName "Function" , FunKind Star (FunKind Star Star))

78− , (primName "Array" , FunKind Star Star)

79− , (primName "String" , Star)

80− , (primName "Number" , Star)

81− , (primName "Boolean" , Star) ]

src/Language/PureScript/Sugar/BindingGroups.hs+10−9

@@ -31,6 +31,7 @@ import Language.PureScript.Declarations

31import Language.PureScript.Names

32import Language.PureScript.Values

33import Language.PureScript.Types

34+import Language.PureScript.Environment

34

35

35-- |

36-- |

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

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

@@ -77,19 +78,19 @@ collapseBindingGroups = concatMap go

77 go other = [other]

78 go other = [other]

78

79

79usedIdents :: (Data d) => ModuleName -> d -> [Ident]

80usedIdents :: (Data d) => ModuleName -> d -> [Ident]

80−usedIdents moduleName = nub . everything (++) (mkQ [] names)

81+usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)

81 where

82 where

82− names :: Value -> [Ident]

83+ usedNames :: Value -> [Ident]

83− names (Var (Qualified Nothing name)) = [name]

84+ usedNames (Var (Qualified Nothing name)) = [name]

84− names (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

85+ usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

85− names _ = []

86+ usedNames _ = []

86

87

87usedProperNames :: (Data d) => ModuleName -> d -> [ProperName]

88usedProperNames :: (Data d) => ModuleName -> d -> [ProperName]

88−usedProperNames moduleName = nub . everything (++) (mkQ [] names)

89+usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)

89 where

90 where

90− names :: Type -> [ProperName]

91+ usedNames :: Type -> [ProperName]

91− names (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

92+ usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

92− names _ = []

93+ usedNames _ = []

93

94

94getIdent :: Declaration -> Ident

95getIdent :: Declaration -> Ident

95getIdent (ValueDeclaration ident _ _ _ _) = ident

96getIdent (ValueDeclaration ident _ _ _ _) = ident

src/Language/PureScript/Sugar/CaseDeclarations.hs+1

@@ -30,6 +30,7 @@ import Language.PureScript.Names

30import Language.PureScript.Values

31import Language.PureScript.Declarations

32import Language.PureScript.Scope

33+import Language.PureScript.Environment

33

34

34-- |

35-- |

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

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

src/Language/PureScript/Sugar/Names.hs+7−7

@@ -29,7 +29,7 @@ import Language.PureScript.Declarations

29import Language.PureScript.Names

30import Language.PureScript.Types

31import Language.PureScript.Values

32−import Language.PureScript.Prim

32+import Language.PureScript.Environment

33

34-- |

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

@@ -97,8 +97,8 @@ addEmptyModule env name = M.insert name (Exports [] [] []) env

97--

98addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment

99addType env mn name dctors = updateExportedModule env mn $ \m -> do

100− types <- addExport (exportedTypes m) (name, dctors)

100+ types' <- addExport (exportedTypes m) (name, dctors)

101− return $ m { exportedTypes = types }

101+ return $ m { exportedTypes = types' }

102

103-- |

104-- Adds a class to the export environment.

@@ -283,10 +283,10 @@ filterExports mn exps env = do

283 -- Filter the exports for the specific module

284 filterModule :: Exports -> Either String Exports

285 filterModule exported = do

286− types <- foldM (filterTypes $ exportedTypes exported) [] exps

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

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

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

289− return exported { exportedTypes = types, exportedTypeClasses = classes, exportedValues = values }

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

290

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

292 -- exports

@@ -370,7 +370,7 @@ resolveImport currentModule importModule exps imps = maybe importAll (foldM impo

370 values' <- updateImports (importedValues imp) name

371 return $ imp { importedValues = values' }

372 importExplicit imp (TypeRef name dctors) = do

373− _ <- checkImportExists "type" types name

373+ _ <- checkImportExists "type" availableTypes name

374 types' <- updateImports (importedTypes imp) name

375 let allDctors = allExportedDataConstructors name

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

@@ -398,7 +398,7 @@ resolveImport currentModule importModule exps imps = maybe importAll (foldM impo

398

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

400 values = exportedValues exps

401− types = fst `map` exportedTypes exps

401+ availableTypes = fst `map` exportedTypes exps

402 classes = exportedTypeClasses exps

403

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

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

@@ -25,7 +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

28+import Language.PureScript.Environment

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

30

31import Control.Applicative

@@ -99,7 +99,7 @@ desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do

99 desugared <- lift $ desugarCases members

100 entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared

101 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

102− return $ (Just $ TypeInstanceRef name className ty, d : entries ++ [dictDecl])

102+ return $ (Just $ TypeInstanceRef name, d : entries ++ [dictDecl])

103desugarDecl _ other = return (Nothing, [other])

104

105memberToNameAndType :: Declaration -> (String, Type)

src/Language/PureScript/TypeChecker.hs+11−5

@@ -35,12 +35,12 @@ import Language.PureScript.Names

35import Language.PureScript.Values

36import Language.PureScript.Kinds

37import Language.PureScript.Declarations

38−import Language.PureScript.Prim

38+import Language.PureScript.Environment

39

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

41addDataType moduleName name args dctors ctorKind = do

42 env <- getEnv

43− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) ctorKind (types env) }

43+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }

44 forM_ dctors $ \(dctor, tys) ->

45 rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $

46 addDataConstructor moduleName name args dctor tys

@@ -56,7 +56,7 @@ addDataConstructor moduleName name args dctor tys = do

56addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()

57addTypeSynonym moduleName name args ty kind = do

58 env <- getEnv

59− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env)

59+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)

60 , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }

61

62valueIsNotDefined :: ModuleName -> Ident -> Check ()

@@ -71,6 +71,11 @@ addValue moduleName name ty nameKind = do

71 env <- getEnv

72 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })

73

74+addTypeClass :: ModuleName -> ProperName -> [String] -> [Declaration] -> Check ()

75+addTypeClass moduleName pn args ds =

76+ let members = map (\(TypeDeclaration ident ty) -> (ident, ty)) ds in

77+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members) (typeClasses . checkEnv $ st) } }

78+

74addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

79addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

75addTypeClassDictionaries entries =

80addTypeClassDictionaries entries =

76 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }

81 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }

@@ -150,7 +155,7 @@ typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = d

150 return $ d : ds

155 return $ d : ds

151typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do

156typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do

152 env <- getEnv

157 env <- getEnv

153− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env) }

158+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }

154 ds <- typeCheckAll mainModuleName moduleName rest

159 ds <- typeCheckAll mainModuleName moduleName rest

155 return $ d : ds

160 return $ d : ds

156typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

161typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

@@ -179,7 +184,8 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _) :

179 addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]

184 addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]

180 ds <- typeCheckAll mainModuleName currentModule rest

185 ds <- typeCheckAll mainModuleName currentModule rest

181 return $ d : ds

186 return $ d : ds

182−typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do

187+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args tys) : rest) = do

188+ addTypeClass moduleName pn args tys

183 ds <- typeCheckAll mainModuleName moduleName rest

189 ds <- typeCheckAll mainModuleName moduleName rest

184 return $ d : ds

190 return $ d : ds

185typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do

191typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do

src/Language/PureScript/TypeChecker/Kinds.hs+3−2

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

27import Language.PureScript.Names

28import Language.PureScript.TypeChecker.Monad

29import Language.PureScript.Pretty

30+import Language.PureScript.Environment

30

31

31import Control.Monad.State

32import Control.Monad.State

32import Control.Monad.Error

33import Control.Monad.Error

@@ -70,7 +71,7 @@ kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind

70kindsOf moduleName name args ts = fmap tidyUp . liftUnify $ do

71kindsOf moduleName name args ts = fmap tidyUp . liftUnify $ do

71 tyCon <- fresh

72 tyCon <- fresh

72 kargs <- replicateM (length args) fresh

73 kargs <- replicateM (length args) fresh

73− let dict = (name, tyCon) : zip (map ProperName args) kargs

74+ let dict = (name, tyCon) : zipWith (\arg kind -> (arg, kind)) (map ProperName args) kargs

74 bindLocalTypeVariables moduleName dict $

75 bindLocalTypeVariables moduleName dict $

75 solveTypes ts kargs tyCon

76 solveTypes ts kargs tyCon

76 where

77 where

@@ -134,7 +135,7 @@ infer (TypeConstructor v) = do

134 env <- liftCheck getEnv

135 env <- liftCheck getEnv

135 case M.lookup v (types env) of

136 case M.lookup v (types env) of

136 Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'" ++ show (M.keys (types env))

137 Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'" ++ show (M.keys (types env))

137− Just kind -> return kind

138+ Just (kind, _) -> return kind

138infer (TypeApp t1 t2) = do

139infer (TypeApp t1 t2) = do

139 k0 <- fresh

140 k0 <- fresh

140 k1 <- infer t1

141 k1 <- infer t1

src/Language/PureScript/TypeChecker/Monad.hs+4−37

@@ -22,7 +22,7 @@ import Language.PureScript.Types

22import Language.PureScript.Kinds

23import Language.PureScript.Values

24import Language.PureScript.Names

25−import Language.PureScript.Prim

25+import Language.PureScript.Environment

26

27import Data.Maybe

28

@@ -30,42 +30,9 @@ import Control.Applicative

30import Control.Monad.State

31import Control.Monad.Error

32import Control.Monad.Unify

33−import Control.Arrow (first)

34

33

35import qualified Data.Map as M

34import qualified Data.Map as M

36

35

37−-- |

38−-- The @Environment@ defines all values and types which are currently in scope:

39−--

40−data Environment = Environment {

41− -- |

42− -- Value names currently in scope

43− --

44− names :: M.Map (ModuleName, Ident) (Type, NameKind)

45− -- |

46− -- Type names currently in scope

47− --

48− , types :: M.Map (Qualified ProperName) Kind

49− -- |

50− -- Data constructors currently in scope, along with their associated data type constructors

51− --

52− , dataConstructors :: M.Map (Qualified ProperName) (ProperName, Type)

53− -- |

54− -- Type synonyms currently in scope

55− --

56− , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)

57− -- |

58− -- Available type class dictionaries

59− --

60− , typeClassDictionaries :: [TypeClassDictionaryInScope]

61− } deriving (Show)

62−

63−-- |

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

65−--

66−initEnvironment :: Environment

67−initEnvironment = Environment M.empty primTypes M.empty M.empty []

68−

69-- |

36-- |

70-- Temporarily bind a collection of names to values

37-- Temporarily bind a collection of names to values

71--

38--

@@ -80,7 +47,7 @@ bindNames newNames action = do

80-- |

47-- |

81-- Temporarily bind a collection of names to types

48-- Temporarily bind a collection of names to types

82--

49--

83−bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) Kind -> m a -> m a

50+bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a

84bindTypes newNames action = do

51bindTypes newNames action = do

85 orig <- get

52 orig <- get

86 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

53 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

@@ -117,7 +84,7 @@ bindLocalVariables moduleName bindings =

117--

84--

118bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

85bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

119bindLocalTypeVariables moduleName bindings =

86bindLocalTypeVariables moduleName bindings =

120− bindTypes (M.fromList $ flip map bindings $ first $ Qualified (Just moduleName))

87+ bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))

121

88

122-- |

89-- |

123-- Lookup the type of a value by name in the @Environment@

90-- Lookup the type of a value by name in the @Environment@

@@ -137,7 +104,7 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do

137 env <- getEnv

104 env <- getEnv

138 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

105 case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

139 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

106 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

140− Just k -> return k

107+ Just (k, _) -> return k

141

108

142-- |

109-- |

143-- State required for type checking:

110-- State required for type checking:

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

@@ -56,7 +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

59+import Language.PureScript.Environment

60import qualified Language.PureScript.Constants as C

61

62import Control.Monad.State