git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge remote-tracking branch 'pure11/pure11' into native
d004a93Andy Arvanitis
src/Language/PureScript/CodeGen/Cpp.hs+97−66
compare with golang
unifiedsplit
@@ -140,46 +140,68 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
140 then do
140 then do
141 argNames <- replicateM (arity' - length args' - 1) freshName
141 argNames <- replicateM (arity' - length args' - 1) freshName
142 let args'' = zip argNames (repeat aty)
142 let args'' = zip argNames (repeat aty)
143− block <- asReturnBlock <$> valueToCpp
143+ if isTypeClassMember
144+ then do -- typeclass member functions are stored curried
145+ body' <- innerLambdas . optIndexers classes <$> valueToCpp (snd abs')
146+ return $ CppNamespace ""
147+ [ CppFunction
148+ (curriedName name)
149+ [arg']
150+ rty
151+ [Inline]
152+ (returnBlock body')
153+ , CppFunction
154+ name
155+ (arg' : args' ++ args'')
156+ rty
157+ (vqs ++ if isAccessor (snd abs') then [Inline] else [])
158+ (returnBlock $
159+ foldl (\fn a -> CppApp fn [a])
160+ body'
161+ (CppVar . fst <$> (args' ++ args'')))
162+ ]
163+ else do
164+ body' <- innerLambdas . optIndexers classes <$> valueToCpp
144− (if null argNames
165+ (if null argNames
145− then snd abs'
166+ then snd abs'
146− else curriedApp
167+ else curriedApp
147− (tail argNames)
168+ (tail argNames)
148− (App
169+ (App
149− nullAnn
170+ nullAnn
150− (snd abs')
171+ (snd abs')
151− (Var nullAnn . Qualified Nothing . Ident $ head argNames)))
172+ (Var nullAnn . Qualified Nothing . Ident $ head argNames)))
152− return $ CppNamespace ""
173+ return $ CppNamespace ""
153− [ CppFunction
174+ [ CppFunction
154− name
175+ name
155− (arg' : args' ++ args'')
176+ (arg' : args' ++ args'')
156− rty
177+ rty
157− (vqs ++ if isAccessor (snd abs') then [Inline] else [])
178+ (vqs ++ if isAccessor (snd abs') then [Inline] else [])
158− (convertNestedLambdas $ convertDictIndexers block)
179+ (returnBlock body')
159− , CppFunction
180+ , CppFunction
160− (curriedName name)
181+ (curriedName name)
161− [arg']
182+ [arg']
162− rty
183+ rty
163− (if arity' == 1 then [Inline] else [])
184+ (if arity' == 1 then [Inline] else [])
164− (asReturnBlock $
185+ (returnBlock $
165− curriedLambda
186+ curriedLambda
166− (fst <$> args' ++ args'')
187+ (fst <$> args' ++ args'')
167− (CppApp (CppVar name)
188+ (CppApp (CppVar name)
168− (CppVar . fst <$> (arg' : args' ++ args''))))
189+ (CppVar . fst <$> (arg' : args' ++ args''))))
169− ]
190+ ]
170 else do
191 else do
171− block <- valueToCpp body
192+ body' <- innerLambdas . optIndexers classes <$> valueToCpp body
172 return $ CppFunction
193 return $ CppFunction
173 name
194 name
174 [arg']
195 [arg']
175 rty
196 rty
176− (vqs ++ if isIndexer block then [Inline] else [])
197+ (vqs ++ if isIndexer body' then [Inline] else [])
177− (convertNestedLambdas . asReturnBlock $ convertDictIndexers block)
198+ (returnBlock body')
178 return (CppComment com $ convertIfPrimFn ty' fn)
199 return (CppComment com $ convertIfPrimFn ty' fn)
179 where
200 where
180 ty' | Just t <- ty = Just t
201 ty' | Just t <- ty = Just t
181 | Just (t, _, _) <- M.lookup (Qualified (Just mn) ident) (E.names env) = Just t
202 | Just (t, _, _) <- M.lookup (Qualified (Just mn) ident) (E.names env) = Just t
182 | otherwise = Nothing
203 | otherwise = Nothing
204+ isTypeClassMember = ident `elem` typeClassMembers
183 arity' = maybe 0 arity ty'
205 arity' = maybe 0 arity ty'
184 name = identToCpp ident
206 name = identToCpp ident
185 aty = Just $ Any [Const, Ref]
207 aty = Just $ Any [Const, Ref]
@@ -193,10 +215,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
193 isIndexer :: Cpp -> Bool
215 isIndexer :: Cpp -> Bool
194 isIndexer (CppIndexer (CppSymbol _) (CppVar _)) = True
216 isIndexer (CppIndexer (CppSymbol _) (CppVar _)) = True
195 isIndexer _ = False
217 isIndexer _ = False
218+ classes = zip (CppVar . fst <$> arg' : args')
196− classes = qualifiedToCpp (Ident . runProperName) . T.constraintClass <$>
219+ (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$> maybe [] extractConstraints ty')
197− maybe [] extractConstraints ty'
220+
198− dictClasses = zip (CppVar . fst <$> arg' : args') classes
199− convertDictIndexers = everywhereOnCpp (dictIndexerToEnum dictClasses)
200
221
201 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) []) =
222 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) []) =
202 return $
223 return $
@@ -205,7 +226,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
205 []
226 []
206 (Just $ Any [])
227 (Just $ Any [])
207 [Inline]
228 [Inline]
208− (asReturnBlock $
229+ (returnBlock $
209 CppDataLiteral [CppAccessor (CppVar $ identToCpp ident) (CppVar "data")])
230 CppDataLiteral [CppAccessor (CppVar $ identToCpp ident) (CppVar "data")])
210
231
211 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) fields) =
232 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) fields) =
@@ -215,7 +236,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
215 (farg <$> fields')
236 (farg <$> fields')
216 (Just $ Any [])
237 (Just $ Any [])
217 [Inline]
238 [Inline]
218− (asReturnBlock $
239+ (returnBlock $
219 CppDataLiteral $
240 CppDataLiteral $
220 CppAccessor (CppVar name) (CppVar "data") : (CppVar <$> fields'))
241 CppAccessor (CppVar name) (CppVar "data") : (CppVar <$> fields'))
221 ] ++
242 ] ++
@@ -251,7 +272,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
251 arity' <- arity ty,
272 arity' <- arity ty,
252 arity' > 0 = do
273 arity' > 0 = do
253 argNames <- replicateM arity' freshName
274 argNames <- replicateM arity' freshName
254− block <- valueToCpp $
275+ body' <- valueToCpp $
255 curriedApp
276 curriedApp
256 (tail argNames)
277 (tail argNames)
257 (App nullAnn e (Var nullAnn . Qualified Nothing . Ident $ head argNames))
278 (App nullAnn e (Var nullAnn . Qualified Nothing . Ident $ head argNames))
@@ -260,7 +281,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
260 [(head argNames, Just $ Any [Const, Ref])]
281 [(head argNames, Just $ Any [Const, Ref])]
261 rty
282 rty
262 []
283 []
263− (asReturnBlock $
284+ (returnBlock $
264 curriedLambda
285 curriedLambda
265 (tail argNames)
286 (tail argNames)
266 (CppApp (CppVar name)
287 (CppApp (CppVar name)
@@ -271,7 +292,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
271 (zip argNames $ repeat aty)
292 (zip argNames $ repeat aty)
272 rty
293 rty
273 []
294 []
274− (asReturnBlock block)
295+ (returnBlock body')
275 ] ++ if arity' > 0
296 ] ++ if arity' > 0
276 then [fn']
297 then [fn']
277 else []
298 else []
@@ -312,9 +333,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
312 fnToLambda _ = error "Not a function!"
333 fnToLambda _ = error "Not a function!"
313
334
314 -------------------------------------------------------------------------------------------------
335 -------------------------------------------------------------------------------------------------
315− convertNestedLambdas :: Cpp -> Cpp
336+ innerLambdas :: Cpp -> Cpp
316 -------------------------------------------------------------------------------------------------
337 -------------------------------------------------------------------------------------------------
317− convertNestedLambdas = everywhereOnCpp go
338+ innerLambdas = everywhereOnCpp go
318 where
339 where
319 go :: Cpp -> Cpp
340 go :: Cpp -> Cpp
320 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f
341 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f
@@ -399,7 +420,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
399 [CaptureAll]
420 [CaptureAll]
400 [(localdict, Just $ Any [Const, Ref])]
421 [(localdict, Just $ Any [Const, Ref])]
401 (Just $ Any [])
422 (Just $ Any [])
402− (asReturnBlock cpp')
423+ (returnBlock cpp')
403 topdict :: String
424 topdict :: String
404 topdict = "_$dict$_"
425 topdict = "_$dict$_"
405 localdict :: String
426 localdict :: String
@@ -466,20 +487,19 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
466
487
467 valueToCpp (Abs (_, _, ty, _) arg body) = do
488 valueToCpp (Abs (_, _, ty, _) arg body) = do
468 cpp <- valueToCpp body
489 cpp <- valueToCpp body
469− let cpp' = convertNestedLambdas cpp
490+ let cpp' = innerLambdas cpp
470 return $
491 return $
471 CppLambda
492 CppLambda
472 []
493 []
473 [(identToCpp arg, Just $ Any [Const, Ref])]
494 [(identToCpp arg, Just $ Any [Const, Ref])]
474 (Just $ Any [])
495 (Just $ Any [])
475− (asReturnBlock $ convertDictIndexers cpp')
496+ (returnBlock $ optIndexers classes cpp')
476 where
497 where
477 arg' = identToCpp arg
498 arg' = identToCpp arg
478 args' = identToCpp <$> (fst $ unAbs body [])
499 args' = identToCpp <$> (fst $ unAbs body [])
500+ classes = zip (CppVar <$> arg' : args')
479− classes = qualifiedToCpp (Ident . runProperName) . T.constraintClass <$>
501+ (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$> maybe [] extractConstraints ty)
480− maybe [] extractConstraints ty
502+
481− dictClasses = zip (CppVar <$> arg' : args') classes
482− convertDictIndexers = everywhereOnCpp (dictIndexerToEnum dictClasses)
483 valueToCpp e@App{} = do
503 valueToCpp e@App{} = do
484 let (f, args) = unApp e []
504 let (f, args) = unApp e []
485 args' <- mapM valueToCpp args
505 args' <- mapM valueToCpp args
@@ -508,7 +528,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
508 let rs = if hasRecursion ds''
528 let rs = if hasRecursion ds''
509 then convertRecursiveFns ds'' ret
529 then convertRecursiveFns ds'' ret
510 else ds''
530 else ds''
511− let cpps = convertNestedLambdas <$> rs
531+ let cpps = innerLambdas <$> rs
512 return $ CppApp
532 return $ CppApp
513 (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret])))
533 (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret])))
514 []
534 []
@@ -589,7 +609,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
589 guardsToCpp (Left gs) = forM gs $ \(cond, val) -> do
609 guardsToCpp (Left gs) = forM gs $ \(cond, val) -> do
590 cond' <- valueToCpp cond
610 cond' <- valueToCpp cond
591 done <- valueToCpp val
611 done <- valueToCpp val
592− return $ CppIfElse cond' (asReturnBlock done) Nothing
612+ return $ CppIfElse cond' (returnBlock done) Nothing
593 guardsToCpp (Right v) = return . CppReturn <$> valueToCpp v
613 guardsToCpp (Right v) = return . CppReturn <$> valueToCpp v
594
614
595 -- |
615 -- |
@@ -787,6 +807,14 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
787 (sortBy (compare `on` normalizedName . fst) fns'))
807 (sortBy (compare `on` normalizedName . fst) fns'))
788 findClass _ = Nothing
808 findClass _ = Nothing
789
809
810+ -------------------------------------------------------------------------------------------------
811+ typeClassMembers :: [Ident]
812+ -------------------------------------------------------------------------------------------------
813+ typeClassMembers = fst <$> (concat . M.elems $ M.map E.typeClassMembers (M.filterWithKey thisModule (E.typeClasses env)))
814+ where
815+ thisModule (Qualified (Just mn') _) _ = mn' == mn
816+ thisModule _ _ = False
817+
790 -------------------------------------------------------------------------------------------------
818 -------------------------------------------------------------------------------------------------
791 dataCtors :: [Cpp]
819 dataCtors :: [Cpp]
792 -------------------------------------------------------------------------------------------------
820 -------------------------------------------------------------------------------------------------
@@ -814,7 +842,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
814 [(head argNames, Just $ Any [Const, Ref])]
842 [(head argNames, Just $ Any [Const, Ref])]
815 (Just $ Any [])
843 (Just $ Any [])
816 (if arity' == 1 then [Inline] else [])
844 (if arity' == 1 then [Inline] else [])
817− (asReturnBlock $
845+ (returnBlock $
818 curriedLambda
846 curriedLambda
819 (tail argNames)
847 (tail argNames)
820 (CppApp (CppVar name)
848 (CppApp (CppVar name)
@@ -828,9 +856,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
828 M.toList $ E.names env
856 M.toList $ E.names env
829
857
830---------------------------------------------------------------------------------------------------
858---------------------------------------------------------------------------------------------------
831−asReturnBlock :: Cpp -> Cpp
859+returnBlock :: Cpp -> Cpp
832---------------------------------------------------------------------------------------------------
860---------------------------------------------------------------------------------------------------
833−asReturnBlock cpp = CppBlock [CppReturn cpp]
861+returnBlock cpp = CppBlock [CppReturn cpp]
834
862
835---------------------------------------------------------------------------------------------------
863---------------------------------------------------------------------------------------------------
836curriedLambda :: [String] -> Cpp -> Cpp
864curriedLambda :: [String] -> Cpp -> Cpp
@@ -839,7 +867,7 @@ curriedLambda args ret = foldr (\arg ret' -> CppLambda
839 [CaptureAll]
867 [CaptureAll]
840 [(arg, Just $ Any [Const, Ref])]
868 [(arg, Just $ Any [Const, Ref])]
841 (Just $ Any [])
869 (Just $ Any [])
842− (asReturnBlock ret')
870+ (returnBlock ret')
843 ) ret args
871 ) ret args
844
872
845---------------------------------------------------------------------------------------------------
873---------------------------------------------------------------------------------------------------
@@ -872,16 +900,19 @@ extractConstraints = go []
872 go cs _ = cs
900 go cs _ = cs
873
901
874---------------------------------------------------------------------------------------------------
902---------------------------------------------------------------------------------------------------
875−dictIndexerToEnum :: [(Cpp,Cpp)] -> Cpp -> Cpp
903+optIndexers :: [(Cpp,Cpp)] -> Cpp -> Cpp
876---------------------------------------------------------------------------------------------------
904---------------------------------------------------------------------------------------------------
905+optIndexers classes = everywhereOnCpp dictIndexerToEnum
906+ where
907+ dictIndexerToEnum :: Cpp -> Cpp
877−dictIndexerToEnum repls (CppIndexer (CppSymbol prop) dict)
908+ dictIndexerToEnum (CppIndexer (CppSymbol prop) dict)
878− | Just cls <- lookup dict repls =
909+ | Just cls <- lookup dict classes =
879− CppBinary Dot
910+ CppBinary Dot
880− (CppIndexer
911+ (CppIndexer
881− (CppAccessor (CppVar . identToCpp $ Ident prop) cls)
912+ (CppAccessor (CppVar . identToCpp $ Ident prop) cls)
882− (CppCast (mapType 0) dict))
913+ (CppCast (mapType 0) dict))
883− (CppVar "second")
914+ (CppVar "second")
884−dictIndexerToEnum _ cpp = cpp
915+ dictIndexerToEnum cpp = cpp
885
916
886---------------------------------------------------------------------------------------------------
917---------------------------------------------------------------------------------------------------
887curriedName :: String -> String
918curriedName :: String -> String
@@ -934,10 +965,10 @@ allSymbols cpps = nub $ concatMap (everythingOnCpp (++) symbols) cpps
934symbolDefs :: [String] -> Cpp
965symbolDefs :: [String] -> Cpp
935---------------------------------------------------------------------------------------------------
966---------------------------------------------------------------------------------------------------
936symbolDefs [] = CppNoOp
967symbolDefs [] = CppNoOp
937−symbolDefs syms = CppNamespace "PureScript" [CppNamespace "symbol" (asFunc <$> syms)]
968+symbolDefs syms = CppNamespace "PureScript" [CppNamespace "symbol" (asStruct <$> syms)]
938 where
969 where
939− asFunc :: String -> Cpp
970+ asStruct :: String -> Cpp
940− asFunc s = CppStruct s []
971+ asStruct s = CppStruct s []
941
972
942---------------------------------------------------------------------------------------------------
973---------------------------------------------------------------------------------------------------
943filterInlineFuncs :: Cpp -> Cpp
974filterInlineFuncs :: Cpp -> Cpp