@@ -140,46 +140,68 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = 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+ if isTypeClassMember
144+ then do -- typeclass member functions are stored curried
145+ body' <- nestedLambdas . optimizeIndexers classes <$> valueToCpp (snd abs')
146+ return $ CppNamespace ""
152+ (asReturnBlock body')
155+ (arg' : args' ++ args'')
157+ (vqs ++ if isAccessor (snd abs') then [Inline] else [])
143− block <- asReturnBlock <$> valueToCpp
158+ (asReturnBlock $
159+ foldl (\fn a -> CppApp fn [a])
161+ (CppVar . fst <$> (args' ++ args'')))
164+ body' <- nestedLambdas . optimizeIndexers 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)
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
155− (arg' : args' ++ args'')
176+ (arg' : args' ++ args'')
157− (vqs ++ if isAccessor (snd abs') then [Inline] else [])
178+ (vqs ++ if isAccessor (snd abs') then [Inline] else [])
158− (convertNestedLambdas $ convertDictIndexers block)
179+ (asReturnBlock body')
159− , CppFunction
180+ , CppFunction
160− (curriedName name)
181+ (curriedName name)
163− (if arity' == 1 then [Inline] else [])
184+ (if arity' == 1 then [Inline] else [])
164− (asReturnBlock $
185+ (asReturnBlock $
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''))))
171− block <- valueToCpp body
192+ body' <- nestedLambdas . optimizeIndexers classes <$> valueToCpp body
172 return $ CppFunction
193 return $ CppFunction
176− (vqs ++ if isIndexer block then [Inline] else [])
197+ (vqs ++ if isIndexer body' then [Inline] else [])
177− (convertNestedLambdas . asReturnBlock $ convertDictIndexers block)
198+ (asReturnBlock body')
178 return (CppComment com $ convertIfPrimFn ty' fn)
199 return (CppComment com $ convertIfPrimFn ty' fn)
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)
201 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) []) =
222 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) []) =
@@ -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))
@@ -271,7 +292,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
271 (zip argNames $ repeat aty)
292 (zip argNames $ repeat aty)
274− (asReturnBlock block)
295+ (asReturnBlock body')
275 ] ++ if arity' > 0
296 ] ++ if arity' > 0
276 then [fn']
297 then [fn']
@@ -312,9 +333,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
312 fnToLambda _ = error "Not a function!"
333 fnToLambda _ = error "Not a function!"
314 -------------------------------------------------------------------------------------------------
335 -------------------------------------------------------------------------------------------------
315− convertNestedLambdas :: Cpp -> Cpp
336+ nestedLambdas :: Cpp -> Cpp
316 -------------------------------------------------------------------------------------------------
337 -------------------------------------------------------------------------------------------------
317− convertNestedLambdas = everywhereOnCpp go
338+ nestedLambdas = everywhereOnCpp go
319 go :: Cpp -> Cpp
340 go :: Cpp -> Cpp
320 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f
341 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f
@@ -466,20 +487,19 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
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' = nestedLambdas cpp
471 CppLambda
492 CppLambda
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+ (asReturnBlock $ optimizeIndexers classes cpp')
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 = nestedLambdas <$> rs
512 return $ CppApp
532 return $ CppApp
513 (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret])))
533 (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret])))
@@ -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
810+ -------------------------------------------------------------------------------------------------
811+ typeClassMembers :: [Ident]
812+ -------------------------------------------------------------------------------------------------
813+ typeClassMembers = fst <$> (concat . M.elems $ M.map E.typeClassMembers (M.filterWithKey thisModule (E.typeClasses env)))
815+ thisModule (Qualified (Just mn') _) _ = mn' == mn
816+ thisModule _ _ = False
790 -------------------------------------------------------------------------------------------------
818 -------------------------------------------------------------------------------------------------
791 dataCtors :: [Cpp]
819 dataCtors :: [Cpp]
792 -------------------------------------------------------------------------------------------------
820 -------------------------------------------------------------------------------------------------
@@ -872,16 +900,19 @@ extractConstraints = go []
872 go cs _ = cs
900 go cs _ = cs
874---------------------------------------------------------------------------------------------------
902---------------------------------------------------------------------------------------------------
875−dictIndexerToEnum :: [(Cpp,Cpp)] -> Cpp -> Cpp
903+optimizeIndexers :: [(Cpp,Cpp)] -> Cpp -> Cpp
876---------------------------------------------------------------------------------------------------
904---------------------------------------------------------------------------------------------------
905+optimizeIndexers classes = everywhereOnCpp dictIndexerToEnum
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
886---------------------------------------------------------------------------------------------------
917---------------------------------------------------------------------------------------------------
887curriedName :: String -> String
918curriedName :: String -> String