d7f3a32 · rowtype-yoga/purescript-native

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

on golang help sign in

Retain data/newtype info in Environment

d7f3a32Gary Burgess12 years ago

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

compare with golang

unifiedsplit

@@ -401,7 +401,7 @@ binderToJs m e varName done (PositionedBinder _ binder) =

401-- This is a partial function, but if an invalid type has reached this far then

402-- something has gone wrong in typechecking.

403--

404−lookupConstructor :: Environment -> Qualified ProperName -> (ProperName, Type)

404+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)

405lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

406

407-- |

@@ -411,15 +411,17 @@ lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor

411isOnlyConstructor :: Environment -> Qualified ProperName -> Bool

412isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1

413 where

414+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int

414 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

415 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

416+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)

415− typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)

417+ typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)

416 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

418 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

417

419

418-- |

420-- |

419-- Checks the number of arguments a data constructor accepts.

421-- Checks the number of arguments a data constructor accepts.

420--

422--

421getConstructorArity :: Environment -> Qualified ProperName -> Int

423getConstructorArity :: Environment -> Qualified ProperName -> Int

422−getConstructorArity e = go . snd . lookupConstructor e

424+getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e

423 where

425 where

424 go :: Type -> Int

426 go :: Type -> Int

425 go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1

427 go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1

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

@@ -113,31 +113,14 @@ instance Eq DeclarationRef where

113 r == (PositionedDeclarationRef _ r') = r == r'

114 _ == _ = False

115

116−-- |

117−-- The type of a data type declaration

118−--

119−data DataType

120− -- |

121− -- A standard data constructor

122− --

123− = Data

124− -- |

125− -- A newtype constructor

126− --

127− | Newtype deriving (Eq, Ord, D.Data, D.Typeable)

128−

129−instance Show DataType where

130− show Data = "data"

131− show Newtype = "newtype"

132−

133-- |

116-- |

134-- The data type of declarations

117-- The data type of declarations

135--

118--

136data Declaration

119data Declaration

137 -- |

120 -- |

138− -- A data type declaration (name, arguments, data constructors)

121+ -- A data type declaration (data or newtype, name, arguments, data constructors)

139 --

122 --

140− = DataDeclaration DataType ProperName [String] [(ProperName, [Type])]

123+ = DataDeclaration DataDeclType ProperName [String] [(ProperName, [Type])]

141 -- |

124 -- |

142 -- A minimal mutually recursive set of data type declarations

125 -- A minimal mutually recursive set of data type declarations

143 --

126 --

src/Language/PureScript/Environment.hs+18−1

@@ -41,7 +41,7 @@ data Environment = Environment {

41 -- |

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

43 --

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

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

45 -- |

46 -- Type synonyms currently in scope

47 --

@@ -138,6 +138,23 @@ data TypeKind

138 --

139 | LocalTypeVariable deriving (Show, Eq, Data, Typeable)

140

141+-- |

142+-- The type ('data' or 'newtype') of a data type declaration

143+--

144+data DataDeclType

145+ -- |

146+ -- A standard data constructor

147+ --

148+ = Data

149+ -- |

150+ -- A newtype constructor

151+ --

152+ | Newtype deriving (Eq, Ord, Data, Typeable)

153+

154+instance Show DataDeclType where

155+ show Data = "data"

156+ show Newtype = "newtype"

157+

141-- |

158-- |

142-- Construct a ProperName in the Prim module

159-- Construct a ProperName in the Prim module

143--

160--

src/Language/PureScript/TypeChecker.hs+12−12

@@ -39,21 +39,21 @@ import Language.PureScript.TypeClassDictionaries

39import Language.PureScript.Environment

40import Language.PureScript.Errors

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

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

43−addDataType moduleName name args dctors ctorKind = do

43+addDataType moduleName dtype name args dctors ctorKind = do

44 env <- getEnv

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

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

47 rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $

48− addDataConstructor moduleName name args dctor tys

48+ addDataConstructor moduleName dtype name args dctor tys

50−addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

50+addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

51−addDataConstructor moduleName name args dctor tys = do

51+addDataConstructor moduleName dtype name args dctor tys = do

52 env <- getEnv

53 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

54 let dctorTy = foldr function retTy tys

55 let polyType = mkForAll args dctorTy

56− putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (name, polyType) (dataConstructors env) }

56+ putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }

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

59addTypeSynonym moduleName name args ty kind = do

@@ -111,19 +111,19 @@ checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance hea

111--

112typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]

113typeCheckAll _ _ [] = return []

114−typeCheckAll mainModuleName moduleName (d@(DataDeclaration _ name args dctors) : rest) = do

114+typeCheckAll mainModuleName moduleName (d@(DataDeclaration dtype name args dctors) : rest) = do

115 rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do

116 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

117− addDataType moduleName name args dctors ctorKind

117+ addDataType moduleName dtype name args dctors ctorKind

118 ds <- typeCheckAll mainModuleName moduleName rest

119 return $ d : ds

120typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

121 rethrow (strMsg "Error in data binding group" <>) $ do

122 let syns = mapMaybe toTypeSynonym tys

123 let dataDecls = mapMaybe toDataDecl tys

124− (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

124+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

125− forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) ->

125+ forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) ->

126− addDataType moduleName name args dctors ctorKind

126+ addDataType moduleName dtype name args dctors ctorKind

127 forM_ (zip syns syn_ks) $ \((name, args, ty), kind) ->

128 addTypeSynonym moduleName name args ty kind

129 ds <- typeCheckAll mainModuleName moduleName rest

@@ -132,7 +132,7 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

132 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)

133 toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'

134 toTypeSynonym _ = Nothing

135− toDataDecl (DataDeclaration _ nm args dctors) = Just (nm, args, dctors)

135+ toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)

136 toDataDecl (PositionedDeclaration _ d') = toDataDecl d'

137 toDataDecl _ = Nothing

138typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

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

@@ -641,8 +641,8 @@ infer' v@(Constructor c) = do

641 env <- getEnv

642 case M.lookup c (dataConstructors env) of

643 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

644− Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

644+ Just (_, _, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

645− return $ TypedValue True v ty'

645+ return $ TypedValue True v ty'

646infer' (Case vals binders) = do

647 ts <- mapM infer vals

648 ret <- fresh

@@ -726,7 +726,7 @@ inferBinder val (VarBinder name) = return $ M.singleton name val

726inferBinder val (ConstructorBinder ctor binders) = do

727 env <- getEnv

728 case M.lookup ctor (dataConstructors env) of

729− Just (_, ty) -> do

729+ Just (_, _, ty) -> do

730 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty

731 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn

732 go binders fn'

@@ -951,7 +951,7 @@ check' (Constructor c) ty = do

951 env <- getEnv

952 case M.lookup c (dataConstructors env) of

953 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

954− Just (_, ty1) -> do

954+ Just (_, _, ty1) -> do

955 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

956 _ <- subsumes Nothing repl ty

957 return $ TypedValue True (Constructor c) ty