b11114e · rowtype-yoga/purescript-native

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

Add field names to environment entries for dctors

commitb11114e17730861df911a264da9f8671921c1ea9 authorGary Burgess <gary.burgess@gmail.com> dateSat 24 Jan 2015, 01:23 (12 years ago) parenta74bae6

6 files changed+78−84

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/JS.hs+2−2 src/Language/PureScript/CoreFn/Desugar.hs+63−67 src/Language/PureScript/CoreFn/Meta.hs+3−6 src/Language/PureScript/Environment.hs+4−4 src/Language/PureScript/TypeChecker.hs+2−1 src/Language/PureScript/TypeChecker/Types.hs+4−4

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

@@ -120,7 +120,7 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

120120valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS

121121valueToJs m (Literal _ l) =

122122 literalToValueJS m l

123−valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) =

123+valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =

124124 return $ JSAccessor "value" $ qualifiedToJS m id name

125125valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =

126126 return $ JSAccessor "create" $ qualifiedToJS m id name

@@ -148,7 +148,7 @@ valueToJs m e@App{} = do

148148 args' <- mapM (valueToJs m) args

149149 case f of

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

152152 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'

153153 Var (_, _, _, Just IsTypeClassConstructor) name ->

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

4444 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls

4545 exps' = nub $ concatMap exportToCoreFn exps

4646 externs = nub $ mapMaybe externToCoreFn decls

47− decls' = concatMap (declToCoreFn env Nothing []) decls

47+ decls' = concatMap (declToCoreFn mn env Nothing []) decls

4848 in Module mn imports exps' externs decls'

4949moduleToCoreFn _ (A.Module{}) =

5050 error "Module exports were not elaborated before moduleToCoreFn"

@@ -96,26 +96,26 @@ exportToCoreFn _ = []

9696-- |

9797-- Desugars member declarations from AST to CoreFn representation.

9898--

99−declToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]

100−declToCoreFn _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

99+declToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]

100+declToCoreFn _ _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

101101 [NonRec (properToIdent ctor) $

102102 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 _ _ _) =

104104 error $ "Found newtype with multiple constructors: " ++ show d

105−declToCoreFn _ ss com (A.DataDeclaration Data tyName _ ctors) =

106− flip map ctors $ \(ctor, tys) ->

107− let fields = (\n -> Ident $ "value_" ++ show n) `map` [0..length tys]

105+declToCoreFn mn env ss com (A.DataDeclaration Data tyName _ ctors) =

106+ flip map ctors $ \(ctor, _) ->

107+ let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)

108108 in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields

109−declToCoreFn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss []) ds

110−declToCoreFn env ss com (A.ValueDeclaration name _ _ (Right e)) =

111− [NonRec name (exprToCoreFn env ss com Nothing e)]

112−declToCoreFn env ss _ (A.BindingGroupDeclaration ds) =

113− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss [] Nothing e)) ds]

114−declToCoreFn _ ss com (A.TypeClassDeclaration name _ supers members) =

109+declToCoreFn mn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn mn env ss []) ds

110+declToCoreFn mn env ss com (A.ValueDeclaration name _ _ (Right e)) =

111+ [NonRec name (exprToCoreFn mn env ss com Nothing e)]

112+declToCoreFn mn env ss _ (A.BindingGroupDeclaration ds) =

113+ [Rec $ map (\(name, _, e) -> (name, exprToCoreFn mn env ss [] Nothing e)) ds]

114+declToCoreFn _ _ ss com (A.TypeClassDeclaration name _ supers members) =

115115 [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]

116−declToCoreFn env _ com (A.PositionedDeclaration ss com1 d) =

117− declToCoreFn env (Just ss) (com ++ com1) d

118−declToCoreFn _ _ _ _ = []

116+declToCoreFn mn env _ com (A.PositionedDeclaration ss com1 d) =

117+ declToCoreFn mn env (Just ss) (com ++ com1) d

118+declToCoreFn _ _ _ _ _ = []

119119

120120-- |

121121-- Makes a typeclass dictionary constructor function. The returned expression

@@ -135,61 +135,61 @@ mkTypeClassConstructor ss com supers members =

135135-- |

136136-- Desugars expressions from AST to CoreFn representation.

137137--

138−exprToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann

139−exprToCoreFn _ ss com ty (A.NumericLiteral v) =

138+exprToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann

139+exprToCoreFn _ _ ss com ty (A.NumericLiteral v) =

140140 Literal (ss, com, ty, Nothing) (NumericLiteral v)

141−exprToCoreFn _ ss com ty (A.StringLiteral v) =

141+exprToCoreFn _ _ ss com ty (A.StringLiteral v) =

142142 Literal (ss, com, ty, Nothing) (StringLiteral v)

143−exprToCoreFn _ ss com ty (A.BooleanLiteral v) =

143+exprToCoreFn _ _ ss com ty (A.BooleanLiteral v) =

144144 Literal (ss, com, ty, Nothing) (BooleanLiteral v)

145−exprToCoreFn env ss com ty (A.ArrayLiteral vs) =

146− Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss [] Nothing) vs)

147−exprToCoreFn env ss com ty (A.ObjectLiteral vs) =

148− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss [] Nothing)) vs)

149−exprToCoreFn env ss com ty (A.Accessor name v) =

150− Accessor (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)

151−exprToCoreFn 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

153−exprToCoreFn env ss com ty (A.Abs (Left name) v) =

154− Abs (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)

155−exprToCoreFn _ _ _ _ (A.Abs _ _) =

156− error "Abs with Binder argument was not desugared before exprToCoreFn"

157−exprToCoreFn env ss com ty (A.App v1 v2) =

158− App (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing v1) (exprToCoreFn env ss [] Nothing v2)

159−exprToCoreFn _ ss com ty (A.Var ident) =

145+exprToCoreFn mn env ss com ty (A.ArrayLiteral vs) =

146+ Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn mn env ss [] Nothing) vs)

147+exprToCoreFn mn env ss com ty (A.ObjectLiteral vs) =

148+ Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn mn env ss [] Nothing)) vs)

149+exprToCoreFn mn env ss com ty (A.Accessor name v) =

150+ Accessor (ss, com, ty, Nothing) name (exprToCoreFn mn env ss [] Nothing v)

151+exprToCoreFn mn env ss com ty (A.ObjectUpdate obj vs) =

152+ ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn mn env ss [] Nothing obj) $ map (second (exprToCoreFn mn env ss [] Nothing)) vs

153+exprToCoreFn mn env ss com ty (A.Abs (Left name) v) =

154+ Abs (ss, com, ty, Nothing) name (exprToCoreFn mn env ss [] Nothing v)

155+exprToCoreFn _ _ _ _ _ (A.Abs _ _) =

156+ error "Abs with Binder argument was not desugared before exprToCoreFn mn"

157+exprToCoreFn mn env ss com ty (A.App v1 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) =

160160 Var (ss, com, ty, Nothing) ident

161−exprToCoreFn env ss com ty (A.IfThenElse v1 v2 v3) =

162− Case (ss, com, ty, Nothing) [exprToCoreFn env ss [] Nothing v1]

161+exprToCoreFn mn env ss com ty (A.IfThenElse v1 v2 v3) =

162+ Case (ss, com, ty, Nothing) [exprToCoreFn mn env ss [] Nothing v1]

163163 [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]

164− (Right $ exprToCoreFn env Nothing [] Nothing v2)

164+ (Right $ exprToCoreFn mn env Nothing [] Nothing v2)

165165 , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]

166− (Right $ exprToCoreFn env Nothing [] Nothing v3) ]

167−exprToCoreFn env ss com ty (A.Constructor name) =

166+ (Right $ exprToCoreFn mn env Nothing [] Nothing v3) ]

167+exprToCoreFn _ env ss com ty (A.Constructor name) =

168168 Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name

169−exprToCoreFn 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)

171−exprToCoreFn env ss com _ (A.TypedValue _ v ty) =

172− exprToCoreFn env ss com (Just ty) v

173−exprToCoreFn env ss com ty (A.Let ds v) =

174− Let (ss, com, ty, Nothing) (concatMap (declToCoreFn env ss []) ds) (exprToCoreFn env ss [] Nothing v)

175−exprToCoreFn 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

169+exprToCoreFn mn env ss com ty (A.Case vs alts) =

170+ Case (ss, com, ty, Nothing) (map (exprToCoreFn mn env ss [] Nothing) vs) (map (altToCoreFn mn env ss) alts)

171+exprToCoreFn mn env ss com _ (A.TypedValue _ v ty) =

172+ exprToCoreFn mn env ss com (Just ty) v

173+exprToCoreFn mn env ss com ty (A.Let ds v) =

174+ Let (ss, com, ty, Nothing) (concatMap (declToCoreFn mn env ss []) ds) (exprToCoreFn mn env ss [] Nothing v)

175+exprToCoreFn mn env ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =

176+ let args = map (exprToCoreFn mn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

177177 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

178178 in foldl (App (ss, com, Nothing, Nothing)) ctor args

179−exprToCoreFn env _ com ty (A.PositionedValue ss com1 v) =

180− exprToCoreFn env (Just ss) (com ++ com1) ty v

181−exprToCoreFn _ _ _ _ e =

182− error $ "Unexpected value in exprToCoreFn: " ++ show e

179+exprToCoreFn mn env _ com ty (A.PositionedValue ss com1 v) =

180+ exprToCoreFn mn env (Just ss) (com ++ com1) ty v

181+exprToCoreFn _ _ _ _ _ e =

182+ error $ "Unexpected value in exprToCoreFn mn: " ++ show e

183183

184184-- |

185185-- Desugars case alternatives from AST to CoreFn representation.

186186--

187−altToCoreFn :: Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann

188−altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)

187+altToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann

188+altToCoreFn mn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)

189189 where

190190 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

192− go (Right e) = Right (exprToCoreFn env ss [] Nothing e)

191+ go (Left ges) = Left $ map (exprToCoreFn mn env ss [] Nothing *** exprToCoreFn mn env ss [] Nothing) ges

192+ go (Right e) = Right (exprToCoreFn mn env ss [] Nothing e)

193193

194194-- |

195195-- Desugars case binders from AST to CoreFn representation.

@@ -206,7 +206,7 @@ binderToCoreFn _ ss com (A.NumberBinder n) =

206206binderToCoreFn _ ss com (A.VarBinder name) =

207207 VarBinder (ss, com, Nothing, Nothing) name

208208binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) =

209− let (_, tctor, _) = lookupConstructor env dctor

209+ let (_, tctor, _, _) = lookupConstructor env dctor

210210 in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss []) bs)

211211binderToCoreFn env ss com (A.ObjectBinder bs) =

212212 LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs)

@@ -232,17 +232,13 @@ properToIdent = Ident . runProperName

232232getConstructorMeta :: Environment -> Qualified ProperName -> Meta

233233getConstructorMeta env ctor =

234234 case lookupConstructor env ctor of

235− (Newtype, _, _) -> IsNewtype

236− dc@(Data, _, ty) ->

235+ (Newtype, _, _, _) -> IsNewtype

236+ dc@(Data, _, _, fields) ->

237237 let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType

238− in IsConstructor constructorType (getArity ty)

238+ in IsConstructor constructorType fields

239239 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

245241 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

246− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)

247− typeConstructor (Qualified (Just mn) _, (_, tyCtor, _)) = (mn, tyCtor)

242+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

243+ typeConstructor (Qualified (Just mn) _, (_, tyCtor, _, _)) = (mn, tyCtor)

248244 typeConstructor _ = error "Invalid argument to typeConstructor"

src/Language/PureScript/CoreFn/Meta.hs+3−6

@@ -18,6 +18,8 @@ module Language.PureScript.CoreFn.Meta where

1818

1919import qualified Data.Data as D

2020

21+import Language.PureScript.Names

22+

2123-- |

2224-- Metadata annotations

2325--

@@ -25,7 +27,7 @@ data Meta

2527 -- |

2628 -- The contained value is a data constructor

2729 --

28− = IsConstructor ConstructorType Arity

30+ = IsConstructor ConstructorType [Ident]

2931 -- |

3032 -- The contained value is a newtype

3133 --

@@ -35,11 +37,6 @@ data Meta

3537 --

3638 | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)

3739

38−-- |

39−-- Type alias for constructor arity

40−--

41−type Arity = Int

42−

4340-- |

4441-- Data constructor metadata

4542--

src/Language/PureScript/Environment.hs+4−4

@@ -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) (DataDeclType, ProperName, Type)

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

4545 -- |

4646 -- Type synonyms currently in scope

4747 --

@@ -223,7 +223,7 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star

223223-- |

224224-- Finds information about data constructors from the current environment.

225225--

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

226+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])

227227lookupConstructor env ctor =

228228 fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env

229229

@@ -232,5 +232,5 @@ lookupConstructor env ctor =

232232--

233233isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool

234234isNewtypeConstructor e ctor = case lookupConstructor e ctor of

235− (Newtype, _, _) -> True

236− (Data, _, _) -> False

235+ (Newtype, _, _, _) -> True

236+ (Data, _, _, _) -> False

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

@@ -57,7 +57,8 @@ addDataConstructor moduleName dtype name args dctor tys = do

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

5858 let dctorTy = foldr function retTy tys

5959 let polyType = mkForAll args dctorTy

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

60+ let fields = [Ident ("value" ++ show n) | n <- [0..length tys]]

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

6162

6263addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()

6364addTypeSynonym moduleName name args ty kind = do

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

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

271271 env <- getEnv

272272 case M.lookup c (dataConstructors env) of

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

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

275− return $ TypedValue True v ty'

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

275+ return $ TypedValue True v ty'

276276infer' (Case vals binders) = do

277277 ts <- mapM infer vals

278278 ret <- fresh

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

354354inferBinder val (ConstructorBinder ctor binders) = do

355355 env <- getEnv

356356 case M.lookup ctor (dataConstructors env) of

357− Just (_, _, ty) -> do

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

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

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

360360 go binders fn'

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

550550 env <- getEnv

551551 case M.lookup c (dataConstructors env) of

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

553− Just (_, _, ty1) -> do

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

554554 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

555555 _ <- subsumes Nothing repl ty

556556 return $ TypedValue True (Constructor c) ty