d7f3a32 · rowtype-yoga/purescript-native

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

Retain data/newtype info in Environment

commitd7f3a32a68fcd98bb298355203f2275f71915612 authorGary Burgess <gary.burgess@gmail.com> dateSat 26 Jul 2014, 12:37 (12 years ago) parente7a32d5

5 files changed+41−39

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/JS.hs+5−3 src/Language/PureScript/Declarations.hs+2−19 src/Language/PureScript/Environment.hs+18−1 src/Language/PureScript/TypeChecker.hs+12−12 src/Language/PureScript/TypeChecker/Types.hs+4−4

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

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

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

402402-- something has gone wrong in typechecking.

403403--

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

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

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

406406

407407-- |

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

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

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

413413 where

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

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

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

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

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

416418 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

417419

418420-- |

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

420422--

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

422−getConstructorArity e = go . snd . lookupConstructor e

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

423425 where

424426 go :: Type -> Int

425427 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

113113 r == (PositionedDeclarationRef _ r') = r == r'

114114 _ == _ = False

115115

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−

133116-- |

134117-- The data type of declarations

135118--

136119data Declaration

137120 -- |

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

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

139122 --

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

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

141124 -- |

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

143126 --

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

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

4141 -- |

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

4343 --

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

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

4545 -- |

4646 -- Type synonyms currently in scope

4747 --

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

138138 --

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

140140

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+

141158-- |

142159-- Construct a ProperName in the Prim module

143160--

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

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

3939import Language.PureScript.Environment

4040import Language.PureScript.Errors

4141

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

43−addDataType moduleName name args dctors ctorKind = do

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

43+addDataType moduleName dtype name args dctors ctorKind = do

4444 env <- getEnv

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

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

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

48− addDataConstructor moduleName name args dctor tys

48+ addDataConstructor moduleName dtype name args dctor tys

4949

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

51−addDataConstructor moduleName name args dctor tys = do

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

51+addDataConstructor moduleName dtype name args dctor tys = do

5252 env <- getEnv

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

5454 let dctorTy = foldr function retTy tys

5555 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) }

5757

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

5959addTypeSynonym moduleName name args ty kind = do

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

111111--

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

113113typeCheckAll _ _ [] = return []

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

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

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

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

117− addDataType moduleName name args dctors ctorKind

117+ addDataType moduleName dtype name args dctors ctorKind

118118 ds <- typeCheckAll mainModuleName moduleName rest

119119 return $ d : ds

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

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

122122 let syns = mapMaybe toTypeSynonym tys

123123 let dataDecls = mapMaybe toDataDecl tys

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) ->

126− addDataType moduleName name args dctors ctorKind

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

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

126+ addDataType moduleName dtype name args dctors ctorKind

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

128128 addTypeSynonym moduleName name args ty kind

129129 ds <- typeCheckAll mainModuleName moduleName rest

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

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

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

134134 toTypeSynonym _ = Nothing

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

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

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

137137 toDataDecl _ = Nothing

138138typeCheckAll 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

641641 env <- getEnv

642642 case M.lookup c (dataConstructors env) of

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

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

645− return $ TypedValue True v ty'

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

645+ return $ TypedValue True v ty'

646646infer' (Case vals binders) = do

647647 ts <- mapM infer vals

648648 ret <- fresh

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

726726inferBinder val (ConstructorBinder ctor binders) = do

727727 env <- getEnv

728728 case M.lookup ctor (dataConstructors env) of

729− Just (_, ty) -> do

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

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

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

732732 go binders fn'

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

951951 env <- getEnv

952952 case M.lookup c (dataConstructors env) of

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

954− Just (_, ty1) -> do

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

955955 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

956956 _ <- subsumes Nothing repl ty

957957 return $ TypedValue True (Constructor c) ty