@@ -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 mn 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,30 +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 :: ModuleName -> 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 mn env ss com (A.DataDeclaration Data tyName _ ctors) =
106− flip map ctors $ \(ctor, _) ->
107− let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
108− in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
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) =
115− [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
116−declToCoreFn mn env _ com (A.PositionedDeclaration ss com1 d) =
117− declToCoreFn mn env (Just ss) (com ++ com1) d
118−declToCoreFn _ _ _ _ _ = []
119−
120230-- |
121231-- Makes a typeclass dictionary constructor function. The returned expression
122232-- is a function that accepts the superclass instances and member
@@ -132,116 +242,8 @@ mkTypeClassConstructor ss com supers members =
132242 (Ident a)
133243 (foldr (Abs nullAnn . Ident) dict as)
134244
135−-- |
136−-- Desugars expressions from AST to CoreFn representation.
137−--
138−exprToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
139−exprToCoreFn _ _ ss com ty (A.NumericLiteral v) =
140− Literal (ss, com, ty, Nothing) (NumericLiteral v)
141−exprToCoreFn _ _ ss com ty (A.StringLiteral v) =
142− Literal (ss, com, ty, Nothing) (StringLiteral v)
143−exprToCoreFn _ _ ss com ty (A.BooleanLiteral v) =
144− Literal (ss, com, ty, Nothing) (BooleanLiteral v)
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) =
160− Var (ss, com, ty, Nothing) ident
161−exprToCoreFn mn env ss com ty (A.IfThenElse v1 v2 v3) =
162− Case (ss, com, ty, Nothing) [exprToCoreFn mn env ss [] Nothing v1]
163− [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
164− (Right $ exprToCoreFn mn env Nothing [] Nothing v2)
165− , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
166− (Right $ exprToCoreFn mn env Nothing [] Nothing v3) ]
167−exprToCoreFn _ env ss com ty (A.Constructor name) =
168− Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name
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
177− ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
178− in foldl (App (ss, com, Nothing, Nothing)) ctor args
179−exprToCoreFn _ _ ss com ty (A.TypeClassDictionaryAccessor _ ident) =
180− Abs (ss, com, ty, Nothing) (Ident "dict")
181− (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))
182−exprToCoreFn mn env _ com ty (A.PositionedValue ss com1 v) =
183− exprToCoreFn mn env (Just ss) (com ++ com1) ty v
184−exprToCoreFn _ _ _ _ _ e =
185− error $ "Unexpected value in exprToCoreFn mn: " ++ show e
186−
187−-- |
188−-- Desugars case alternatives from AST to CoreFn representation.
189−--
190−altToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
191−altToCoreFn mn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)
192− where
193− go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
194− go (Left ges) = Left $ map (exprToCoreFn mn env ss [] Nothing *** exprToCoreFn mn env ss [] Nothing) ges
195− go (Right e) = Right (exprToCoreFn mn env ss [] Nothing e)
196−
197−-- |
198−-- Desugars case binders from AST to CoreFn representation.
199−--
200−binderToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
201−binderToCoreFn _ ss com (A.NullBinder) =
202− NullBinder (ss, com, Nothing, Nothing)
203−binderToCoreFn _ ss com (A.BooleanBinder b) =
204− LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)
205−binderToCoreFn _ ss com (A.StringBinder s) =
206− LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)
207−binderToCoreFn _ ss com (A.NumberBinder n) =
208− LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)
209−binderToCoreFn _ ss com (A.VarBinder name) =
210− VarBinder (ss, com, Nothing, Nothing) name
211−binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) =
212− let (_, tctor, _, _) = lookupConstructor env dctor
213− in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss []) bs)
214−binderToCoreFn env ss com (A.ObjectBinder bs) =
215− LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs)
216−binderToCoreFn env ss com (A.ArrayBinder bs) =
217− LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss []) bs)
218−binderToCoreFn env ss com (A.ConsBinder b1 b2) =
219− let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
220− in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss []) [b1, b2]
221−binderToCoreFn env ss com (A.NamedBinder name b) =
222− NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn env ss [] b)
223−binderToCoreFn env _ com (A.PositionedBinder ss com1 b) =
224− binderToCoreFn env (Just ss) (com ++ com1) b
225−
226245-- |
227246-- Converts a ProperName to an Ident.
228247--
229248properToIdent :: ProperName -> Ident
230249properToIdent = Ident . runProperName
231−
232−-- |
233−-- Gets metadata for data constructors.
234−--
235−getConstructorMeta :: Environment -> Qualified ProperName -> Meta
236−getConstructorMeta env ctor =
237− case lookupConstructor env ctor of
238− (Newtype, _, _, _) -> IsNewtype
239− dc@(Data, _, _, fields) ->
240− let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
241− in IsConstructor constructorType fields
242− where
243− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int
244− numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
245− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)
246− typeConstructor (Qualified (Just mn) _, (_, tyCtor, _, _)) = (mn, tyCtor)
247− typeConstructor _ = error "Invalid argument to typeConstructor"