git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add field names to environment entries for dctors
b11114eGary Burgess
src/Language/PureScript/CodeGen/JS.hs+2−2
compare with golang
unifiedsplit
@@ -120,7 +120,7 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
120valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS
120valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS
121valueToJs m (Literal _ l) =
121valueToJs m (Literal _ l) =
122 literalToValueJS m l
122 literalToValueJS m l
123−valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) =
123+valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =
124 return $ JSAccessor "value" $ qualifiedToJS m id name
124 return $ JSAccessor "value" $ qualifiedToJS m id name
125valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =
125valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =
126 return $ JSAccessor "create" $ qualifiedToJS m id name
126 return $ JSAccessor "create" $ qualifiedToJS m id name
@@ -148,7 +148,7 @@ valueToJs m e@App{} = do
148 args' <- mapM (valueToJs m) args
148 args' <- mapM (valueToJs m) args
149 case f of
149 case f of
150 Var (_, _, _, Just IsNewtype) _ -> return (head args')
150 Var (_, _, _, Just IsNewtype) _ -> return (head args')
151− Var (_, _, _, Just (IsConstructor _ arity)) name | arity == length args ->
151+ Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
152 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
152 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
153 Var (_, _, _, Just IsTypeClassConstructor) name ->
153 Var (_, _, _, Just IsTypeClassConstructor) name ->
154 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
154 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
src/Language/PureScript/CoreFn/Desugar.hs+63−67
@@ -44,7 +44,7 @@ moduleToCoreFn env (A.Module mn decls (Just exps)) =
44 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
44 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
45 exps' = nub $ concatMap exportToCoreFn exps
45 exps' = nub $ concatMap exportToCoreFn exps
46 externs = nub $ mapMaybe externToCoreFn decls
46 externs = nub $ mapMaybe externToCoreFn decls
47− decls' = concatMap (declToCoreFn env Nothing []) decls
47+ decls' = concatMap (declToCoreFn mn env Nothing []) decls
48 in Module mn imports exps' externs decls'
48 in Module mn imports exps' externs decls'
49moduleToCoreFn _ (A.Module{}) =
49moduleToCoreFn _ (A.Module{}) =
50 error "Module exports were not elaborated before moduleToCoreFn"
50 error "Module exports were not elaborated before moduleToCoreFn"
@@ -96,26 +96,26 @@ exportToCoreFn _ = []
96-- |
96-- |
97-- Desugars member declarations from AST to CoreFn representation.
97-- Desugars member declarations from AST to CoreFn representation.
98--
98--
99−declToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
99+declToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
100−declToCoreFn _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
100+declToCoreFn _ _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
101 [NonRec (properToIdent ctor) $
101 [NonRec (properToIdent ctor) $
102 Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
102 Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
103−declToCoreFn _ _ _ d@(A.DataDeclaration Newtype _ _ _) =
103+declToCoreFn _ _ _ _ d@(A.DataDeclaration Newtype _ _ _) =
104 error $ "Found newtype with multiple constructors: " ++ show d
104 error $ "Found newtype with multiple constructors: " ++ show d
105−declToCoreFn _ ss com (A.DataDeclaration Data tyName _ ctors) =
105+declToCoreFn mn env ss com (A.DataDeclaration Data tyName _ ctors) =
106− flip map ctors $ \(ctor, tys) ->
106+ flip map ctors $ \(ctor, _) ->
107− let fields = (\n -> Ident $ "value_" ++ show n) `map` [0..length tys]
107+ let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
108 in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
108 in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
109−declToCoreFn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss []) ds
109+declToCoreFn mn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn mn env ss []) ds
110−declToCoreFn env ss com (A.ValueDeclaration name _ _ (Right e)) =
110+declToCoreFn mn env ss com (A.ValueDeclaration name _ _ (Right e)) =
111− [NonRec name (exprToCoreFn env ss com Nothing e)]
111+ [NonRec name (exprToCoreFn mn env ss com Nothing e)]
112−declToCoreFn env ss _ (A.BindingGroupDeclaration ds) =
112+declToCoreFn mn env ss _ (A.BindingGroupDeclaration ds) =
113− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss [] Nothing e)) ds]
113+ [Rec $ map (\(name, _, e) -> (name, exprToCoreFn mn env ss [] Nothing e)) ds]
114−declToCoreFn _ ss com (A.TypeClassDeclaration name _ supers members) =
114+declToCoreFn _ _ ss com (A.TypeClassDeclaration name _ supers members) =
115 [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
115 [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
116−declToCoreFn env _ com (A.PositionedDeclaration ss com1 d) =
116+declToCoreFn mn env _ com (A.PositionedDeclaration ss com1 d) =
117− declToCoreFn env (Just ss) (com ++ com1) d
117+ declToCoreFn mn env (Just ss) (com ++ com1) d
118−declToCoreFn _ _ _ _ = []
118+declToCoreFn _ _ _ _ _ = []
119
119
120-- |
120-- |
121-- Makes a typeclass dictionary constructor function. The returned expression
121-- Makes a typeclass dictionary constructor function. The returned expression
@@ -135,61 +135,61 @@ mkTypeClassConstructor ss com supers members =
135-- |
135-- |
136-- Desugars expressions from AST to CoreFn representation.
136-- Desugars expressions from AST to CoreFn representation.
137--
137--
138−exprToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
138+exprToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
139−exprToCoreFn _ ss com ty (A.NumericLiteral v) =
139+exprToCoreFn _ _ ss com ty (A.NumericLiteral v) =
140 Literal (ss, com, ty, Nothing) (NumericLiteral v)
140 Literal (ss, com, ty, Nothing) (NumericLiteral v)
141−exprToCoreFn _ ss com ty (A.StringLiteral v) =
141+exprToCoreFn _ _ ss com ty (A.StringLiteral v) =
142 Literal (ss, com, ty, Nothing) (StringLiteral v)
142 Literal (ss, com, ty, Nothing) (StringLiteral v)
143−exprToCoreFn _ ss com ty (A.BooleanLiteral v) =
143+exprToCoreFn _ _ ss com ty (A.BooleanLiteral v) =
144 Literal (ss, com, ty, Nothing) (BooleanLiteral v)
144 Literal (ss, com, ty, Nothing) (BooleanLiteral v)
145−exprToCoreFn env ss com ty (A.ArrayLiteral vs) =
145+exprToCoreFn mn env ss com ty (A.ArrayLiteral vs) =
146− Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss [] Nothing) vs)
146+ Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn mn env ss [] Nothing) vs)
147−exprToCoreFn env ss com ty (A.ObjectLiteral vs) =
147+exprToCoreFn mn env ss com ty (A.ObjectLiteral vs) =
148− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss [] Nothing)) vs)
148+ Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn mn env ss [] Nothing)) vs)
149−exprToCoreFn env ss com ty (A.Accessor name v) =
149+exprToCoreFn mn env ss com ty (A.Accessor name v) =
150− Accessor (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)
150+ Accessor (ss, com, ty, Nothing) name (exprToCoreFn mn env ss [] Nothing v)
151−exprToCoreFn env ss com ty (A.ObjectUpdate obj vs) =
151+exprToCoreFn mn env ss com ty (A.ObjectUpdate obj vs) =
152− ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing obj) $ map (second (exprToCoreFn env ss [] Nothing)) vs
152+ ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn mn env ss [] Nothing obj) $ map (second (exprToCoreFn mn env ss [] Nothing)) vs
153−exprToCoreFn env ss com ty (A.Abs (Left name) v) =
153+exprToCoreFn mn env ss com ty (A.Abs (Left name) v) =
154− Abs (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)
154+ Abs (ss, com, ty, Nothing) name (exprToCoreFn mn env ss [] Nothing v)
155−exprToCoreFn _ _ _ _ (A.Abs _ _) =
155+exprToCoreFn _ _ _ _ _ (A.Abs _ _) =
156− error "Abs with Binder argument was not desugared before exprToCoreFn"
156+ error "Abs with Binder argument was not desugared before exprToCoreFn mn"
157−exprToCoreFn env ss com ty (A.App v1 v2) =
157+exprToCoreFn mn env ss com ty (A.App v1 v2) =
158− App (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing v1) (exprToCoreFn env ss [] Nothing v2)
158+ App (ss, com, ty, Nothing) (exprToCoreFn mn env ss [] Nothing v1) (exprToCoreFn mn env ss [] Nothing v2)
159−exprToCoreFn _ ss com ty (A.Var ident) =
159+exprToCoreFn _ _ ss com ty (A.Var ident) =
160 Var (ss, com, ty, Nothing) ident
160 Var (ss, com, ty, Nothing) ident
161−exprToCoreFn env ss com ty (A.IfThenElse v1 v2 v3) =
161+exprToCoreFn mn env ss com ty (A.IfThenElse v1 v2 v3) =
162− Case (ss, com, ty, Nothing) [exprToCoreFn env ss [] Nothing v1]
162+ Case (ss, com, ty, Nothing) [exprToCoreFn mn env ss [] Nothing v1]
163 [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
163 [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
164− (Right $ exprToCoreFn env Nothing [] Nothing v2)
164+ (Right $ exprToCoreFn mn env Nothing [] Nothing v2)
165 , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
165 , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
166− (Right $ exprToCoreFn env Nothing [] Nothing v3) ]
166+ (Right $ exprToCoreFn mn env Nothing [] Nothing v3) ]
167−exprToCoreFn env ss com ty (A.Constructor name) =
167+exprToCoreFn _ env ss com ty (A.Constructor name) =
168 Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name
168 Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name
169−exprToCoreFn env ss com ty (A.Case vs alts) =
169+exprToCoreFn mn env ss com ty (A.Case vs alts) =
170− Case (ss, com, ty, Nothing) (map (exprToCoreFn env ss [] Nothing) vs) (map (altToCoreFn env ss) alts)
170+ Case (ss, com, ty, Nothing) (map (exprToCoreFn mn env ss [] Nothing) vs) (map (altToCoreFn mn env ss) alts)
171−exprToCoreFn env ss com _ (A.TypedValue _ v ty) =
171+exprToCoreFn mn env ss com _ (A.TypedValue _ v ty) =
172− exprToCoreFn env ss com (Just ty) v
172+ exprToCoreFn mn env ss com (Just ty) v
173−exprToCoreFn env ss com ty (A.Let ds v) =
173+exprToCoreFn mn env ss com ty (A.Let ds v) =
174− Let (ss, com, ty, Nothing) (concatMap (declToCoreFn env ss []) ds) (exprToCoreFn env ss [] Nothing v)
174+ Let (ss, com, ty, Nothing) (concatMap (declToCoreFn mn env ss []) ds) (exprToCoreFn mn env ss [] Nothing v)
175−exprToCoreFn env ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
175+exprToCoreFn mn env ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
176− let args = map (exprToCoreFn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
176+ let args = map (exprToCoreFn mn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
177 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
177 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
178 in foldl (App (ss, com, Nothing, Nothing)) ctor args
178 in foldl (App (ss, com, Nothing, Nothing)) ctor args
179−exprToCoreFn env _ com ty (A.PositionedValue ss com1 v) =
179+exprToCoreFn mn env _ com ty (A.PositionedValue ss com1 v) =
180− exprToCoreFn env (Just ss) (com ++ com1) ty v
180+ exprToCoreFn mn env (Just ss) (com ++ com1) ty v
181−exprToCoreFn _ _ _ _ e =
181+exprToCoreFn _ _ _ _ _ e =
182− error $ "Unexpected value in exprToCoreFn: " ++ show e
182+ error $ "Unexpected value in exprToCoreFn mn: " ++ show e
183
183
184-- |
184-- |
185-- Desugars case alternatives from AST to CoreFn representation.
185-- Desugars case alternatives from AST to CoreFn representation.
186--
186--
187−altToCoreFn :: Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
187+altToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
188−altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)
188+altToCoreFn mn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)
189 where
189 where
190 go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
190 go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
191− go (Left ges) = Left $ map (exprToCoreFn env ss [] Nothing *** exprToCoreFn env ss [] Nothing) ges
191+ go (Left ges) = Left $ map (exprToCoreFn mn env ss [] Nothing *** exprToCoreFn mn env ss [] Nothing) ges
192− go (Right e) = Right (exprToCoreFn env ss [] Nothing e)
192+ go (Right e) = Right (exprToCoreFn mn env ss [] Nothing e)
193
193
194-- |
194-- |
195-- Desugars case binders from AST to CoreFn representation.
195-- Desugars case binders from AST to CoreFn representation.
@@ -206,7 +206,7 @@ binderToCoreFn _ ss com (A.NumberBinder n) =
206binderToCoreFn _ ss com (A.VarBinder name) =
206binderToCoreFn _ ss com (A.VarBinder name) =
207 VarBinder (ss, com, Nothing, Nothing) name
207 VarBinder (ss, com, Nothing, Nothing) name
208binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) =
208binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) =
209− let (_, tctor, _) = lookupConstructor env dctor
209+ let (_, tctor, _, _) = lookupConstructor env dctor
210 in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss []) bs)
210 in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss []) bs)
211binderToCoreFn env ss com (A.ObjectBinder bs) =
211binderToCoreFn env ss com (A.ObjectBinder bs) =
212 LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs)
212 LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs)
@@ -232,17 +232,13 @@ properToIdent = Ident . runProperName
232getConstructorMeta :: Environment -> Qualified ProperName -> Meta
232getConstructorMeta :: Environment -> Qualified ProperName -> Meta
233getConstructorMeta env ctor =
233getConstructorMeta env ctor =
234 case lookupConstructor env ctor of
234 case lookupConstructor env ctor of
235− (Newtype, _, _) -> IsNewtype
235+ (Newtype, _, _, _) -> IsNewtype
236− dc@(Data, _, ty) ->
236+ dc@(Data, _, _, fields) ->
237 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
237 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
238− in IsConstructor constructorType (getArity ty)
238+ in IsConstructor constructorType fields
239 where
239 where
240− getArity :: Type -> Int
241− getArity (TypeApp (TypeApp f _) t) | f == tyFunction = getArity t + 1
242− getArity (ForAll _ ty _) = getArity ty
243− getArity _ = 0
244− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int
240+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int
245 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
241 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
246− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)
242+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)
247− typeConstructor (Qualified (Just mn) _, (_, tyCtor, _)) = (mn, tyCtor)
243+ typeConstructor (Qualified (Just mn) _, (_, tyCtor, _, _)) = (mn, tyCtor)
248 typeConstructor _ = error "Invalid argument to typeConstructor"
244 typeConstructor _ = error "Invalid argument to typeConstructor"
src/Language/PureScript/CoreFn/Meta.hs+3−6
@@ -18,6 +18,8 @@ module Language.PureScript.CoreFn.Meta where
18
18
19import qualified Data.Data as D
19import qualified Data.Data as D
20
20
21+import Language.PureScript.Names
22+
21-- |
23-- |
22-- Metadata annotations
24-- Metadata annotations
23--
25--
@@ -25,7 +27,7 @@ data Meta
25 -- |
27 -- |
26 -- The contained value is a data constructor
28 -- The contained value is a data constructor
27 --
29 --
28− = IsConstructor ConstructorType Arity
30+ = IsConstructor ConstructorType [Ident]
29 -- |
31 -- |
30 -- The contained value is a newtype
32 -- The contained value is a newtype
31 --
33 --
@@ -35,11 +37,6 @@ data Meta
35 --
37 --
36 | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)
38 | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)
37
39
38−-- |
39−-- Type alias for constructor arity
40−--
41−type Arity = Int
42−
43-- |
40-- |
44-- Data constructor metadata
41-- Data constructor metadata
45--
42--
src/Language/PureScript/Environment.hs+4−4
@@ -41,7 +41,7 @@ data Environment = Environment {
41 -- |
41 -- |
42 -- Data constructors currently in scope, along with their associated data type constructors
42 -- Data constructors currently in scope, along with their associated data type constructors
43 --
43 --
44− , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type)
44+ , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
45 -- |
45 -- |
46 -- Type synonyms currently in scope
46 -- Type synonyms currently in scope
47 --
47 --
@@ -223,7 +223,7 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star
223-- |
223-- |
224-- Finds information about data constructors from the current environment.
224-- Finds information about data constructors from the current environment.
225--
225--
226−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)
226+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])
227lookupConstructor env ctor =
227lookupConstructor env ctor =
228 fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env
228 fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env
229
229
@@ -232,5 +232,5 @@ lookupConstructor env ctor =
232--
232--
233isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
233isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
234isNewtypeConstructor e ctor = case lookupConstructor e ctor of
234isNewtypeConstructor e ctor = case lookupConstructor e ctor of
235− (Newtype, _, _) -> True
235+ (Newtype, _, _, _) -> True
236− (Data, _, _) -> False
236+ (Data, _, _, _) -> False
src/Language/PureScript/TypeChecker.hs+2−1
@@ -57,7 +57,8 @@ addDataConstructor moduleName dtype name args dctor tys = do
57 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
57 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
58 let dctorTy = foldr function retTy tys
58 let dctorTy = foldr function retTy tys
59 let polyType = mkForAll args dctorTy
59 let polyType = mkForAll args dctorTy
60+ let fields = [Ident ("value" ++ show n) | n <- [0..length tys]]
60− putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }
61+ putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
61
62
62addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
63addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
63addTypeSynonym moduleName name args ty kind = do
64addTypeSynonym moduleName name args ty kind = do
src/Language/PureScript/TypeChecker/Types.hs+4−4
@@ -271,8 +271,8 @@ infer' v@(Constructor c) = do
271 env <- getEnv
271 env <- getEnv
272 case M.lookup c (dataConstructors env) of
272 case M.lookup c (dataConstructors env) of
273 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
273 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
274− Just (_, _, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
274+ Just (_, _, ty, _) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
275− return $ TypedValue True v ty'
275+ return $ TypedValue True v ty'
276infer' (Case vals binders) = do
276infer' (Case vals binders) = do
277 ts <- mapM infer vals
277 ts <- mapM infer vals
278 ret <- fresh
278 ret <- fresh
@@ -354,7 +354,7 @@ inferBinder val (VarBinder name) = return $ M.singleton name val
354inferBinder val (ConstructorBinder ctor binders) = do
354inferBinder val (ConstructorBinder ctor binders) = do
355 env <- getEnv
355 env <- getEnv
356 case M.lookup ctor (dataConstructors env) of
356 case M.lookup ctor (dataConstructors env) of
357− Just (_, _, ty) -> do
357+ Just (_, _, ty, _) -> do
358 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty
358 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty
359 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn
359 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn
360 go binders fn'
360 go binders fn'
@@ -550,7 +550,7 @@ check' (Constructor c) ty = do
550 env <- getEnv
550 env <- getEnv
551 case M.lookup c (dataConstructors env) of
551 case M.lookup c (dataConstructors env) of
552 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
552 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
553− Just (_, _, ty1) -> do
553+ Just (_, _, ty1, _) -> do
554 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
554 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
555 _ <- subsumes Nothing repl ty
555 _ <- subsumes Nothing repl ty
556 return $ TypedValue True (Constructor c) ty
556 return $ TypedValue True (Constructor c) ty