git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #877 from purescript/corefn-class-repr

Add named fields to data constructor representation

commitd10f1b74016fe5d69f34a5a340c11fd34724f01a authorGary Burgess <gary.burgess@gmail.com> dateTue 17 Feb 2015, 23:03 (12 years ago) parentd844d148c39725
9 files changed+191−193
compare with golang
unifiedsplit
src/Language/PureScript/AST/Declarations.hs+4 src/Language/PureScript/CodeGen/JS.hs+21−27 src/Language/PureScript/CoreFn/Desugar.hs+137−135 src/Language/PureScript/CoreFn/Expr.hs+2−3 src/Language/PureScript/CoreFn/Meta.hs+3−6 src/Language/PureScript/Environment.hs+4−4 src/Language/PureScript/Sugar/TypeClasses.hs+13−12 src/Language/PureScript/TypeChecker.hs+2−1 src/Language/PureScript/TypeChecker/Types.hs+5−5
src/Language/PureScript/AST/Declarations.hs+4
@@ -398,6 +398,10 @@ data Expr
398398 --
399399 | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
400400 -- |
401+ -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
402+ --
403+ | TypeClassDictionaryAccessor (Qualified ProperName) Ident
404+ -- |
401405 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
402406 --
403407 | SuperClassDictionary (Qualified ProperName) [Type]
src/Language/PureScript/CodeGen/JS.hs+21−27
@@ -129,7 +129,7 @@ valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
129129 => ModuleName -> Expr Ann -> SupplyT m JS
130130valueToJs m (Literal _ l) =
131131 literalToValueJS m l
132−valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) =
132+valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =
133133 return $ JSAccessor "value" $ qualifiedToJS m id name
134134valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =
135135 return $ JSAccessor "create" $ qualifiedToJS m id name
@@ -157,7 +157,7 @@ valueToJs m e@App{} = do
157157 args' <- mapM (valueToJs m) args
158158 case f of
159159 Var (_, _, _, Just IsNewtype) _ -> return (head args')
160− Var (_, _, _, Just (IsConstructor _ arity)) name | arity == length args ->
160+ Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
161161 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
162162 Var (_, _, _, Just IsTypeClassConstructor) name ->
163163 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
@@ -180,26 +180,20 @@ valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
180180 JSObjectLiteral [("create",
181181 JSFunction Nothing ["value"]
182182 (JSBlock [JSReturn $ JSVar "value"]))])
183−valueToJs _ (Constructor _ _ (ProperName ctor) 0) =
183+valueToJs _ (Constructor _ _ (ProperName ctor) []) =
184184 return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
185185 , JSAssignment (JSAccessor "value" (JSVar ctor))
186186 (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
187−valueToJs _ (Constructor _ _ (ProperName ctor) arity) =
188− return $ iife ctor [ makeConstructor ctor arity
189− , JSAssignment (JSAccessor "create" (JSVar ctor)) (go ctor 0 arity [])
190− ]
191− where
192− makeConstructor :: String -> Int -> JS
193− makeConstructor ctorName n =
194− let args = [ "value" ++ show index | index <- [0..n-1] ]
195− body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]
196− in JSFunction (Just ctorName) args (JSBlock body)
197− go :: String -> Int -> Int -> [JS] -> JS
198− go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar pn) (reverse values)
199− go pn index n values =
200− JSFunction Nothing ["value" ++ show index]
201− (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])
202−
187+valueToJs _ (Constructor _ _ (ProperName ctor) fields) =
188+ let constructor =
189+ let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
190+ in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
191+ createFn =
192+ let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
193+ in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
194+ in return $ iife ctor [ constructor
195+ , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
196+ ]
203197iife :: String -> [JS] -> JS
204198iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
205199
@@ -254,7 +248,7 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
254248bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
255249 => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS
256250bindersToJs m binders vals = do
257− valNames <- replicateM (length vals) $ freshName
251+ valNames <- replicateM (length vals) freshName
258252 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
259253 jss <- forM binders $ \(CaseAlternative bs result) -> do
260254 ret <- guardsToJs result
@@ -291,8 +285,8 @@ binderToJs _ varName done (VarBinder _ ident) =
291285 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
292286binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
293287 binderToJs m varName done b
294−binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType _)) _ ctor bs) = do
295− js <- go 0 done bs
288+binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
289+ js <- go (zip fields bs) done
296290 return $ case ctorType of
297291 ProductType -> js
298292 SumType ->
@@ -301,13 +295,13 @@ binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorT
301295 Nothing]
302296 where
303297 go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
304− => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]
305− go _ done' [] = return done'
306− go index done' (binder:bs') = do
298+ => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS]
299+ go [] done' = return done'
300+ go ((field, binder) : remain) done' = do
307301 argVar <- freshName
308− done'' <- go (index + 1) done' bs'
302+ done'' <- go remain done'
309303 js <- binderToJs m argVar done'' binder
310− return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)
304+ return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
311305binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
312306 let (headBinders, tailBinder) = uncons [] binder
313307 numberOfHeadBinders = fromIntegral $ length headBinders
src/Language/PureScript/CoreFn/Desugar.hs+137−135
@@ -40,14 +40,148 @@ import qualified Language.PureScript.AST as A
4040-- Desugars a module from AST to CoreFn representation.
4141--
4242moduleToCoreFn :: Environment -> A.Module -> Module Ann
43+moduleToCoreFn _ (A.Module _ _ Nothing) =
44+ error "Module exports were not elaborated before moduleToCoreFn"
4345moduleToCoreFn env (A.Module mn decls (Just exps)) =
4446 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
4547 exps' = nub $ concatMap exportToCoreFn exps
4648 externs = nub $ mapMaybe externToCoreFn decls
47− decls' = concatMap (declToCoreFn env Nothing []) decls
49+ decls' = concatMap (declToCoreFn Nothing []) decls
4850 in Module mn imports exps' externs decls'
49−moduleToCoreFn _ (A.Module{}) =
50− error "Module exports were not elaborated before moduleToCoreFn"
51+
52+ where
53+
54+ -- |
55+ -- Desugars member declarations from AST to CoreFn representation.
56+ --
57+ declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
58+ declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
59+ [NonRec (properToIdent ctor) $
60+ Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
61+ declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =
62+ error $ "Found newtype with multiple constructors: " ++ show d
63+ declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =
64+ flip map ctors $ \(ctor, _) ->
65+ let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
66+ in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
67+ declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
68+ declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
69+ [NonRec name (exprToCoreFn ss com Nothing e)]
70+ declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
71+ [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
72+ declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
73+ [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
74+ declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =
75+ declToCoreFn (Just ss) (com ++ com1) d
76+ declToCoreFn _ _ _ = []
77+
78+ -- |
79+ -- Desugars expressions from AST to CoreFn representation.
80+ --
81+ exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
82+ exprToCoreFn ss com ty (A.NumericLiteral v) =
83+ Literal (ss, com, ty, Nothing) (NumericLiteral v)
84+ exprToCoreFn ss com ty (A.StringLiteral v) =
85+ Literal (ss, com, ty, Nothing) (StringLiteral v)
86+ exprToCoreFn ss com ty (A.BooleanLiteral v) =
87+ Literal (ss, com, ty, Nothing) (BooleanLiteral v)
88+ exprToCoreFn ss com ty (A.ArrayLiteral vs) =
89+ Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)
90+ exprToCoreFn ss com ty (A.ObjectLiteral vs) =
91+ Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)
92+ exprToCoreFn ss com ty (A.Accessor name v) =
93+ Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
94+ exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
95+ ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs
96+ exprToCoreFn ss com ty (A.Abs (Left name) v) =
97+ Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
98+ exprToCoreFn _ _ _ (A.Abs _ _) =
99+ error "Abs with Binder argument was not desugared before exprToCoreFn mn"
100+ exprToCoreFn ss com ty (A.App v1 v2) =
101+ App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)
102+ exprToCoreFn ss com ty (A.Var ident) =
103+ Var (ss, com, ty, Nothing) ident
104+ exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =
105+ Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]
106+ [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
107+ (Right $ exprToCoreFn Nothing [] Nothing v2)
108+ , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
109+ (Right $ exprToCoreFn Nothing [] Nothing v3) ]
110+ exprToCoreFn ss com ty (A.Constructor name) =
111+ Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name
112+ exprToCoreFn ss com ty (A.Case vs alts) =
113+ Case (ss, com, ty, Nothing) (map (exprToCoreFn ss [] Nothing) vs) (map (altToCoreFn ss) alts)
114+ exprToCoreFn ss com _ (A.TypedValue _ v ty) =
115+ exprToCoreFn ss com (Just ty) v
116+ exprToCoreFn ss com ty (A.Let ds v) =
117+ Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)
118+ exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
119+ let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
120+ ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
121+ in foldl (App (ss, com, Nothing, Nothing)) ctor args
122+ exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) =
123+ Abs (ss, com, ty, Nothing) (Ident "dict")
124+ (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))
125+ exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =
126+ exprToCoreFn (Just ss) (com ++ com1) ty v
127+ exprToCoreFn _ _ _ e =
128+ error $ "Unexpected value in exprToCoreFn mn: " ++ show e
129+
130+ -- |
131+ -- Desugars case alternatives from AST to CoreFn representation.
132+ --
133+ altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
134+ altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs)
135+ where
136+ go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
137+ go (Left ges) = Left $ map (exprToCoreFn ss [] Nothing *** exprToCoreFn ss [] Nothing) ges
138+ go (Right e) = Right (exprToCoreFn ss [] Nothing e)
139+
140+ -- |
141+ -- Desugars case binders from AST to CoreFn representation.
142+ --
143+ binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
144+ binderToCoreFn ss com (A.NullBinder) =
145+ NullBinder (ss, com, Nothing, Nothing)
146+ binderToCoreFn ss com (A.BooleanBinder b) =
147+ LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)
148+ binderToCoreFn ss com (A.StringBinder s) =
149+ LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)
150+ binderToCoreFn ss com (A.NumberBinder n) =
151+ LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)
152+ binderToCoreFn ss com (A.VarBinder name) =
153+ VarBinder (ss, com, Nothing, Nothing) name
154+ binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =
155+ let (_, tctor, _, _) = lookupConstructor env dctor
156+ in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)
157+ binderToCoreFn ss com (A.ObjectBinder bs) =
158+ LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)
159+ binderToCoreFn ss com (A.ArrayBinder bs) =
160+ LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)
161+ binderToCoreFn ss com (A.ConsBinder b1 b2) =
162+ let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
163+ in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn ss []) [b1, b2]
164+ binderToCoreFn ss com (A.NamedBinder name b) =
165+ NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)
166+ binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
167+ binderToCoreFn (Just ss) (com ++ com1) b
168+
169+ -- |
170+ -- Gets metadata for data constructors.
171+ --
172+ getConstructorMeta :: Qualified ProperName -> Meta
173+ getConstructorMeta ctor =
174+ case lookupConstructor env ctor of
175+ (Newtype, _, _, _) -> IsNewtype
176+ dc@(Data, _, _, fields) ->
177+ let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
178+ in IsConstructor constructorType fields
179+ where
180+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int
181+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
182+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)
183+ typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)
184+ typeConstructor _ = error "Invalid argument to typeConstructor"
51185
52186-- |
53187-- Find module names from qualified references to values. This is used to
@@ -93,29 +227,6 @@ exportToCoreFn (A.TypeInstanceRef name) = [name]
93227exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d
94228exportToCoreFn _ = []
95229
96−-- |
97−-- Desugars member declarations from AST to CoreFn representation.
98−--
99−declToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
100−declToCoreFn _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
101− [NonRec (properToIdent ctor) $
102− Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
103−declToCoreFn _ _ _ d@(A.DataDeclaration Newtype _ _ _) =
104− error $ "Found newtype with multiple constructors: " ++ show d
105−declToCoreFn _ ss com (A.DataDeclaration Data tyName _ ctors) =
106− flip map ctors $ \(ctor, tys) ->
107− NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor (length tys)
108−declToCoreFn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss []) ds
109−declToCoreFn env ss com (A.ValueDeclaration name _ _ (Right e)) =
110− [NonRec name (exprToCoreFn env ss com Nothing e)]
111−declToCoreFn env ss _ (A.BindingGroupDeclaration ds) =
112− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss [] Nothing e)) ds]
113−declToCoreFn _ ss com (A.TypeClassDeclaration name _ supers members) =
114− [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
115−declToCoreFn env _ com (A.PositionedDeclaration ss com1 d) =
116− declToCoreFn env (Just ss) (com ++ com1) d
117−declToCoreFn _ _ _ _ = []
118−
119230-- |
120231-- Makes a typeclass dictionary constructor function. The returned expression
121232-- is a function that accepts the superclass instances and member
@@ -131,117 +242,8 @@ mkTypeClassConstructor ss com supers members =
131242 (Ident a)
132243 (foldr (Abs nullAnn . Ident) dict as)
133244
134−-- |
135−-- Desugars expressions from AST to CoreFn representation.
136−--
137−exprToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
138−exprToCoreFn _ ss com ty (A.NumericLiteral v) =
139− Literal (ss, com, ty, Nothing) (NumericLiteral v)
140−exprToCoreFn _ ss com ty (A.StringLiteral v) =
141− Literal (ss, com, ty, Nothing) (StringLiteral v)
142−exprToCoreFn _ ss com ty (A.BooleanLiteral v) =
143− Literal (ss, com, ty, Nothing) (BooleanLiteral v)
144−exprToCoreFn env ss com ty (A.ArrayLiteral vs) =
145− Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss [] Nothing) vs)
146−exprToCoreFn env ss com ty (A.ObjectLiteral vs) =
147− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss [] Nothing)) vs)
148−exprToCoreFn env ss com ty (A.Accessor name v) =
149− Accessor (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)
150−exprToCoreFn env ss com ty (A.ObjectUpdate obj vs) =
151− ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing obj) $ map (second (exprToCoreFn env ss [] Nothing)) vs
152−exprToCoreFn env ss com ty (A.Abs (Left name) v) =
153− Abs (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)
154−exprToCoreFn _ _ _ _ (A.Abs _ _) =
155− error "Abs with Binder argument was not desugared before exprToCoreFn"
156−exprToCoreFn env ss com ty (A.App v1 v2) =
157− App (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing v1) (exprToCoreFn env ss [] Nothing v2)
158−exprToCoreFn _ ss com ty (A.Var ident) =
159− Var (ss, com, ty, Nothing) ident
160−exprToCoreFn env ss com ty (A.IfThenElse v1 v2 v3) =
161− Case (ss, com, ty, Nothing) [exprToCoreFn env ss [] Nothing v1]
162− [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
163− (Right $ exprToCoreFn env Nothing [] Nothing v2)
164− , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
165− (Right $ exprToCoreFn env Nothing [] Nothing v3) ]
166−exprToCoreFn env ss com ty (A.Constructor name) =
167− Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name
168−exprToCoreFn env ss com ty (A.Case vs alts) =
169− Case (ss, com, ty, Nothing) (map (exprToCoreFn env ss [] Nothing) vs) (map (altToCoreFn env ss) alts)
170−exprToCoreFn env ss com _ (A.TypedValue _ v ty) =
171− exprToCoreFn env ss com (Just ty) v
172−exprToCoreFn env ss com ty (A.Let ds v) =
173− Let (ss, com, ty, Nothing) (concatMap (declToCoreFn env ss []) ds) (exprToCoreFn env ss [] Nothing v)
174−exprToCoreFn env ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
175− let args = map (exprToCoreFn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
176− ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
177− in foldl (App (ss, com, Nothing, Nothing)) ctor args
178−exprToCoreFn env _ com ty (A.PositionedValue ss com1 v) =
179− exprToCoreFn env (Just ss) (com ++ com1) ty v
180−exprToCoreFn _ _ _ _ e =
181− error $ "Unexpected value in exprToCoreFn: " ++ show e
182−
183−-- |
184−-- Desugars case alternatives from AST to CoreFn representation.
185−--
186−altToCoreFn :: Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
187−altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)
188− where
189− go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
190− go (Left ges) = Left $ map (exprToCoreFn env ss [] Nothing *** exprToCoreFn env ss [] Nothing) ges
191− go (Right e) = Right (exprToCoreFn env ss [] Nothing e)
192−
193−-- |
194−-- Desugars case binders from AST to CoreFn representation.
195−--
196−binderToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
197−binderToCoreFn _ ss com (A.NullBinder) =
198− NullBinder (ss, com, Nothing, Nothing)
199−binderToCoreFn _ ss com (A.BooleanBinder b) =
200− LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)
201−binderToCoreFn _ ss com (A.StringBinder s) =
202− LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)
203−binderToCoreFn _ ss com (A.NumberBinder n) =
204− LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)
205−binderToCoreFn _ ss com (A.VarBinder name) =
206− VarBinder (ss, com, Nothing, Nothing) name
207−binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) =
208− let (_, tctor, _) = lookupConstructor env dctor
209− in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss []) bs)
210−binderToCoreFn env ss com (A.ObjectBinder bs) =
211− LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs)
212−binderToCoreFn env ss com (A.ArrayBinder bs) =
213− LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss []) bs)
214−binderToCoreFn env ss com (A.ConsBinder b1 b2) =
215− let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
216− in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss []) [b1, b2]
217−binderToCoreFn env ss com (A.NamedBinder name b) =
218− NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn env ss [] b)
219−binderToCoreFn env _ com (A.PositionedBinder ss com1 b) =
220− binderToCoreFn env (Just ss) (com ++ com1) b
221−
222245-- |
223246-- Converts a ProperName to an Ident.
224247--
225248properToIdent :: ProperName -> Ident
226249properToIdent = Ident . runProperName
227−
228−-- |
229−-- Gets metadata for data constructors.
230−--
231−getConstructorMeta :: Environment -> Qualified ProperName -> Meta
232−getConstructorMeta env ctor =
233− case lookupConstructor env ctor of
234− (Newtype, _, _) -> IsNewtype
235− dc@(Data, _, ty) ->
236− let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
237− in IsConstructor constructorType (getArity ty)
238− where
239− getArity :: Type -> Int
240− getArity (TypeApp (TypeApp f _) t) | f == tyFunction = getArity t + 1
241− getArity (ForAll _ ty _) = getArity ty
242− getArity _ = 0
243− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int
244− numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
245− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)
246− typeConstructor (Qualified (Just mn) _, (_, tyCtor, _)) = (mn, tyCtor)
247− typeConstructor _ = error "Invalid argument to typeConstructor"
src/Language/PureScript/CoreFn/Expr.hs+2−3
@@ -23,7 +23,6 @@ import qualified Data.Data as D
2323
2424import Language.PureScript.CoreFn.Binders
2525import Language.PureScript.CoreFn.Literals
26−import Language.PureScript.CoreFn.Meta
2726import Language.PureScript.Names
2827
2928-- |
@@ -35,9 +34,9 @@ data Expr a
3534 --
3635 = Literal a (Literal (Expr a))
3736 -- |
38− -- A data constructor (type name, constructor name, arity)
37+ -- A data constructor (type name, constructor name, field names)
3938 --
40− | Constructor a ProperName ProperName Arity
39+ | Constructor a ProperName ProperName [Ident]
4140 -- |
4241 -- A record property accessor
4342 --
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 --
@@ -228,7 +228,7 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star
228228-- |
229229-- Finds information about data constructors from the current environment.
230230--
231−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)
231+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])
232232lookupConstructor env ctor =
233233 fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env
234234
@@ -237,5 +237,5 @@ lookupConstructor env ctor =
237237--
238238isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
239239isNewtypeConstructor e ctor = case lookupConstructor e ctor of
240− (Newtype, _, _) -> True
241− (Data, _, _) -> False
240+ (Newtype, _, _, _) -> True
241+ (Data, _, _, _) -> False
src/Language/PureScript/Sugar/TypeClasses.hs+13−12
@@ -21,24 +21,24 @@ module Language.PureScript.Sugar.TypeClasses
2121 ) where
2222
2323import Language.PureScript.AST hiding (isExported)
24−import Language.PureScript.Names
25−import Language.PureScript.Types
26−import Language.PureScript.Kinds
27−import Language.PureScript.Sugar.CaseDeclarations
2824import Language.PureScript.Environment
2925import Language.PureScript.Errors
30−import Language.PureScript.Supply
26+import Language.PureScript.Kinds
27+import Language.PureScript.Names
3128import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
29+import Language.PureScript.Sugar.CaseDeclarations
30+import Language.PureScript.Supply
31+import Language.PureScript.Types
3232
3333import qualified Language.PureScript.Constants as C
3434
3535import Control.Applicative
36+import Control.Arrow (first, second)
3637import Control.Monad.Error
3738import Control.Monad.State
38−import Control.Arrow (first, second)
3939import Data.List ((\\), find)
40−import Data.Monoid ((<>))
4140import Data.Maybe (catMaybes, mapMaybe, isJust)
41+import Data.Monoid ((<>))
4242
4343import qualified Data.Map as M
4444
@@ -158,12 +158,12 @@ desugarDecl mn exps = go
158158 where
159159 go d@(TypeClassDeclaration name args implies members) = do
160160 modify (M.insert (mn, name) d)
161− return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
161+ return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
162162 go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
163163 go d@(TypeInstanceDeclaration name deps className tys members) = do
164164 desugared <- lift $ desugarCases members
165165 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
166− return $ (expRef name className tys, [d, dictDecl])
166+ return (expRef name className tys, [d, dictDecl])
167167 go (PositionedDeclaration pos com d) = do
168168 (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
169169 return (dr, map (PositionedDeclaration pos com) ds)
@@ -212,9 +212,10 @@ typeClassDictionaryDeclaration name args implies members =
212212
213213typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
214214typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
215− ValueDeclaration ident TypeClassAccessorImport [] $ Right $
216− TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
217− moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))
215+ let className = Qualified (Just mn) name
216+ in ValueDeclaration ident TypeClassAccessorImport [] $ Right $
217+ TypedValue False (TypeClassDictionaryAccessor className ident) $
218+ moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))
218219typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
219220 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
220221typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
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 - 1)]]
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+5−5
@@ -270,8 +270,8 @@ infer' v@(Constructor c) = do
270270 env <- getEnv
271271 case M.lookup c (dataConstructors env) of
272272 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
273− Just (_, _, ty) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty
274− return $ TypedValue True v' ty'
273+ Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty
274+ return $ TypedValue True v' ty'
275275infer' (Case vals binders) = do
276276 ts <- mapM infer vals
277277 ret <- fresh
@@ -355,7 +355,7 @@ inferBinder val (VarBinder name) = return $ M.singleton name val
355355inferBinder val (ConstructorBinder ctor binders) = do
356356 env <- getEnv
357357 case M.lookup ctor (dataConstructors env) of
358− Just (_, _, ty) -> do
358+ Just (_, _, ty, _) -> do
359359 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty
360360 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn
361361 go binders fn'
@@ -552,7 +552,7 @@ check' (Constructor c) ty = do
552552 env <- getEnv
553553 case M.lookup c (dataConstructors env) of
554554 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
555− Just (_, _, ty1) -> do
555+ Just (_, _, ty1, _) -> do
556556 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
557557 _ <- subsumes Nothing repl ty
558558 return $ TypedValue True (Constructor c) ty
@@ -583,7 +583,7 @@ containsTypeSynonyms = everythingOnTypes (||) go where
583583checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]
584584checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
585585 go [] [] REmpty = return []
586− go [] [] u@(TUnknown _)
586+ go [] [] u@(TUnknown _)
587587 | lax = return []
588588 | otherwise = do u =?= REmpty
589589 return []