@@ -69,7 +69,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
6969 imps
7070 let cppImports' = "PureScript" : cppImports
7171 cppDecls <- concat <$> mapM (bindToCpp [CppTopLevel]) decls
72− optimized <- traverse optimize cppDecls
72+ cppDecls' <- traverse optimize cppDecls
73+ foreignWrappers <- curriedForeigns
74+ let optimized = cppDecls' ++ foreignWrappers
7375 let moduleHeader =
7476 fileBegin mn "HH" ++
7577 P.linebreak ++
@@ -115,6 +117,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
115117 declToCpp _ _ (Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
116118 return CppNoOp
117119
120+ declToCpp _ (Op _) (Var (_, _, Nothing, _) _) =
121+ return CppNoOp -- skip operator aliases
122+
118123 declToCpp _ ident (Abs _ arg@(Ident "dict")
119124 body@(Accessor _ _ (Var _ (Qualified Nothing arg'))))
120125 | arg' == arg = do
@@ -127,16 +132,51 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
127132 block
128133 return fn'
129134
130− declToCpp vqs ident (Abs (_, com, _, _) arg body) = do
131− block <- asReturnBlock <$> valueToCpp body
132− let block' = convertNestedLambdas block
133− fn' = CppFunction
134− (identToCpp ident)
135− [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]
136− (Just $ CppAny [])
137− vqs
138− block'
139− return (CppComment com fn')
135+ declToCpp vqs ident (Abs (_, com, ty, _) arg body) = do
136+ fn <- if argcnt > 0 && CppTopLevel `elem` vqs
137+ then do
138+ argNames <- replicateM (argcnt - length args' - 1) freshName
139+ let args'' = zip argNames (repeat aty)
140+ block <- asReturnBlock <$> valueToCpp
141+ (if null argNames
142+ then snd abs'
143+ else curriedApp
144+ (tail argNames)
145+ (App
146+ nullAnn
147+ (snd abs')
148+ (Var nullAnn . Qualified Nothing . Ident $ head argNames)))
149+ let block' = convertNestedLambdas block
150+ return $ CppNamespace ""
151+ [ CppFunction
152+ name
153+ (arg' : args' ++ args'')
154+ rty
155+ vqs
156+ block'
157+ , CppFunction
158+ (curriedName name)
159+ [arg']
160+ rty
161+ []
162+ (asReturnBlock $
163+ curriedLambda
164+ (fst <$> args' ++ args'')
165+ (CppApp (CppVar name)
166+ (CppVar . fst <$> (arg' : args' ++ args''))))
167+ ]
168+ else do
169+ block <- asReturnBlock <$> valueToCpp body
170+ return $ CppFunction name [arg'] rty vqs (convertNestedLambdas block)
171+ return (CppComment com fn)
172+ where
173+ argcnt = maybe 0 countArgs ty
174+ name = identToCpp ident
175+ aty = Just $ CppAny [CppConst, CppRef]
176+ rty = Just $ CppAny []
177+ arg' = (identToCpp arg, aty)
178+ args' = (\i -> (identToCpp i, aty)) <$> fst abs'
179+ abs' = unAbs body []
140180
141181 declToCpp _ ident (Constructor _ _ (ProperName _) []) =
142182 return $
@@ -145,22 +185,28 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
145185 []
146186 (Just $ CppAny [])
147187 [CppInline]
148− (CppBlock [CppReturn (CppDataLiteral [CppStringLiteral (identToCpp ident)])])
188+ (asReturnBlock (CppDataLiteral [CppStringLiteral (identToCpp ident)]))
149189
150− declToCpp _ ident (Constructor _ _ (ProperName _) fields) = return . CppNamespace [] $
190+ declToCpp _ ident (Constructor _ _ (ProperName _) fields) =
191+ return . CppNamespace "" $
151192 [ CppFunction
152− ('$' : identToCpp ident)
193+ name
153194 (farg <$> fields')
154195 (Just $ CppAny [])
155196 [CppInline]
156− (CppBlock fullyConstructed)
157− , CppFunction
158− (identToCpp ident)
159− (farg <$> f)
160− (Just $ CppAny [])
161− []
162− (CppBlock (fieldLambdas fs))
163− ]
197+ (asReturnBlock (CppDataLiteral (CppStringLiteral name : (CppVar <$> fields'))))
198+ ] ++
199+ if length fields > 1
200+ then
201+ [ CppFunction
202+ (curriedName name)
203+ (farg <$> f)
204+ (Just $ CppAny [])
205+ []
206+ (CppBlock (fieldLambdas fs))
207+ ]
208+ else
209+ []
164210 where
165211 name = identToCpp ident
166212 fields' = identToCpp <$> fields
@@ -174,35 +220,44 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
174220 (farg <$> [f'])
175221 (Just $ CppAny [])
176222 (CppBlock $ fieldLambdas fs') ]
177− | otherwise = fullyConstructed
178− fullyConstructed = [CppReturn (CppDataLiteral (CppStringLiteral name : (CppVar <$> fields')))]
179−
180− declToCpp qs ident e@(App (_, _, Just ty, _) _ _)
181− | CppTopLevel `elem` qs,
182− count <- countArgs ty,
183− count > 0 = do
184− argNames <- replicateM count freshName
185− block <- flip (foldl (\fn a -> CppApp fn [a])) (CppVar <$> argNames) <$> valueToCpp e
186− return $ CppFunction
187− (identToCpp ident)
223+ | otherwise = [CppReturn $ CppApp (CppVar name) (CppVar <$> fields')]
224+
225+ declToCpp qs ident e
226+ | Just ty <- exprType e,
227+ CppTopLevel `elem` qs,
228+ argcnt <- countArgs ty,
229+ argcnt > 0 = do
230+ argNames <- replicateM argcnt freshName
231+ block <- valueToCpp $
232+ curriedApp
233+ (tail argNames)
234+ (App
235+ (Nothing, [], Just ty, Nothing)
236+ e
237+ (Var nullAnn . Qualified Nothing . Ident $ head argNames))
238+ let fn' = CppFunction
239+ (curriedName name)
188240 [(head argNames, Just $ CppAny [CppConst, CppRef])]
189− (Just $ CppAny [])
241+ rty
190242 []
191− (asReturnBlock $ curried (tail argNames) block)
243+ (asReturnBlock $
244+ curriedLambda
245+ (tail argNames)
246+ (CppApp (CppVar name)
247+ (CppVar <$> argNames)))
248+ return $ CppNamespace ""
249+ [ CppFunction
250+ name
251+ (zip argNames $ repeat aty)
252+ rty
253+ []
254+ (asReturnBlock block)
255+ , fn'
256+ ]
192257 where
193− curried :: [String] -> Cpp -> Cpp
194− curried args vals = foldl (\val arg -> CppLambda
195− [CppCaptureAll]
196− [(arg, Just $ CppAny [CppConst, CppRef])]
197− (Just $ CppAny [])
198− (asReturnBlock val)
199− ) vals args
200− countArgs :: T.Type -> Int
201− countArgs = go 0
202− where
203− go argcnt (T.ForAll _ t _) = go argcnt t
204− go argcnt (T.TypeApp (T.TypeApp fn _) t) | fn == E.tyFunction = go (argcnt + 1) t
205− go argcnt _ = argcnt
258+ name = identToCpp ident
259+ aty = Just $ CppAny [CppConst, CppRef]
260+ rty = Just $ CppAny []
206261
207262 declToCpp _ ident val = do
208263 val' <- valueToCpp val
@@ -212,6 +267,15 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
212267 []
213268 (Just val')
214269
270+ -------------------------------------------------------------------------------------------------
271+ exprType :: Expr Ann -> Maybe T.Type
272+ -------------------------------------------------------------------------------------------------
273+ exprType (Var (_, _, Just ty, _) _) = Just ty
274+ exprType (App (_, _, Just ty, _) _ _) = Just ty
275+ exprType (Case (_, _, Just ty, _) _ _) = Just ty
276+ exprType (Let (_, _, Just ty, _) _ _) = Just ty
277+ exprType _ = Nothing
278+
215279 -------------------------------------------------------------------------------------------------
216280 fnToLambda :: Cpp -> Cpp
217281 -------------------------------------------------------------------------------------------------
@@ -226,11 +290,6 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
226290 fnToLambda (CppComment com cpp) = CppComment com (fnToLambda cpp)
227291 fnToLambda _ = error "Not a function!"
228292
229− -------------------------------------------------------------------------------------------------
230− asReturnBlock :: Cpp -> Cpp
231− -------------------------------------------------------------------------------------------------
232− asReturnBlock cpp = CppBlock [CppReturn cpp]
233−
234293 -------------------------------------------------------------------------------------------------
235294 convertNestedLambdas :: Cpp -> Cpp
236295 -------------------------------------------------------------------------------------------------
@@ -288,7 +347,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
288347 [CppCaptureAll]
289348 [(localdict, Just $ CppAny [CppConst, CppRef])]
290349 (Just $ CppAny [])
291− (CppBlock [CppReturn cpp'])
350+ (asReturnBlock cpp')
292351 topdict :: String
293352 topdict = "__dict__"
294353 localdict :: String
@@ -305,9 +364,16 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
305364 valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) =
306365 return $ CppApp (CppVar $ qualifiedToStr' id ident) []
307366
308− valueToCpp (Var (_, _, _, Just (IsConstructor _ _)) ident) =
367+ valueToCpp (Var (_, _, _, Just (IsConstructor _ [_])) ident) =
309368 return . CppVar $ qualifiedToStr' id ident
310369
370+ valueToCpp (Var (_, _, _, Just (IsConstructor _ _)) ident) =
371+ return . curriedName' $ varToCpp ident
372+
373+ valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))
374+ | countArgs ty > 1 =
375+ return . curriedName' $ varToCpp ident
376+
311377 valueToCpp (Var _ ident) =
312378 return $ varToCpp ident
313379
@@ -365,11 +431,20 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
365431 args' <- mapM valueToCpp args
366432 case f of
367433 Var (_, _, _, Just IsNewtype) _ -> return (head args')
368− Var (_, _, _, Just (IsConstructor _ fields)) (Qualified qual (Ident name)) | length args == length fields ->
369− return $ CppApp (qualifiedToCpp id . Qualified qual . Ident $ '$' : name) args'
434+ Var (_, _, _, Just (IsConstructor _ fields)) ident
435+ | length args == length fields ->
436+ return $ CppApp (uncurried' $ qualifiedToCpp id ident) args'
370437 Var (_, _, _, Just IsTypeClassConstructor) (Qualified mn' (Ident classname)) ->
371438 let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname)) in
372439 return . CppObjectLiteral $ zip ((sort $ superClassDictionaryNames constraints) ++ (fst <$> fns)) args'
440+ Var (_, _, Just ty, _) (Qualified (Just _) _)
441+ | argcnt <- countArgs ty,
442+ argcnt > 1,
443+ length args >= argcnt -> do
444+ f' <- valueToCpp f
445+ let (uncurArgs, curArgs) = splitAt argcnt args'
446+ uncurApp = CppApp (uncurried' f') uncurArgs
447+ return $ foldl (\fn a -> CppApp fn [a]) uncurApp curArgs
373448 _ ->
374449 flip (foldl (\fn a -> CppApp fn [a])) args' <$> valueToCpp f
375450
@@ -625,6 +700,12 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
625700 unApp (App _ val arg) args = unApp val (arg : args)
626701 unApp other args = (other, args)
627702
703+ -------------------------------------------------------------------------------------------------
704+ unAbs :: Expr Ann -> [Ident] -> ([Ident], Expr Ann)
705+ -------------------------------------------------------------------------------------------------
706+ unAbs (Abs _ arg val) args = unAbs val (args ++ [arg])
707+ unAbs other args = (args, other)
708+
628709 -------------------------------------------------------------------------------------------------
629710 qualifiedToCpp :: (a -> Ident) -> Qualified a -> Cpp
630711 -------------------------------------------------------------------------------------------------
@@ -650,3 +731,87 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
650731 fns' <- (\(i,t) -> (runIdent i, t)) <$> fns
651732 = Just (fst <$> params, constraints, (sortBy (compare `on` normalizedName . fst) fns'))
652733 findClass _ = Nothing
734+
735+ -------------------------------------------------------------------------------------------------
736+ curriedForeigns :: m [Cpp]
737+ -------------------------------------------------------------------------------------------------
738+ curriedForeigns = concat <$> mapM go allForeigns
739+ where
740+ go (ident, ty)
741+ | argcnt <- countArgs ty,
742+ argcnt > 1 = do
743+ let name = identToCpp ident
744+ argNames <- replicateM argcnt freshName
745+ return $
746+ [ CppFunction
747+ (curriedName name)
748+ [(head argNames, Just $ CppAny [CppConst, CppRef])]
749+ (Just $ CppAny [])
750+ []
751+ (asReturnBlock $
752+ curriedLambda
753+ (tail argNames)
754+ (CppApp (CppVar name)
755+ (CppVar <$> argNames)))
756+ ]
757+ go _ = return []
758+
759+ allForeigns :: [(Ident, T.Type)]
760+ allForeigns = map (\((_, ident), (ty, _, _)) -> (ident, ty)) .
761+ filter (\((mn', _), (_, kind, _)) -> mn' == mn && kind == E.External) .
762+ M.toList $ E.names env
763+
764+---------------------------------------------------------------------------------------------------
765+asReturnBlock :: Cpp -> Cpp
766+---------------------------------------------------------------------------------------------------
767+asReturnBlock cpp = CppBlock [CppReturn cpp]
768+
769+---------------------------------------------------------------------------------------------------
770+curriedLambda :: [String] -> Cpp -> Cpp
771+---------------------------------------------------------------------------------------------------
772+curriedLambda args ret = foldr (\arg ret' -> CppLambda
773+ [CppCaptureAll]
774+ [(arg, Just $ CppAny [CppConst, CppRef])]
775+ (Just $ CppAny [])
776+ (asReturnBlock ret')
777+ ) ret args
778+
779+---------------------------------------------------------------------------------------------------
780+curriedApp :: [String] -> Expr Ann -> Expr Ann
781+---------------------------------------------------------------------------------------------------
782+curriedApp args vals = foldl (\val arg -> App
783+ nullAnn
784+ val
785+ (Var nullAnn . Qualified Nothing $ Ident arg))
786+ vals args
787+
788+---------------------------------------------------------------------------------------------------
789+countArgs :: T.Type -> Int
790+---------------------------------------------------------------------------------------------------
791+countArgs = go 0 . T.everywhereOnTypes rmForAll
792+ where
793+ go argcnt (T.TypeApp (T.TypeApp fn _) (T.ConstrainedType _ _)) | fn == E.tyFunction = argcnt
794+ go argcnt (T.TypeApp (T.TypeApp fn _) t) | fn == E.tyFunction = go (argcnt + 1) t
795+ go argcnt _ = argcnt
796+ rmForAll :: T.Type -> T.Type
797+ rmForAll (T.ForAll _ t _) = t
798+ rmForAll t = t
799+
800+---------------------------------------------------------------------------------------------------
801+curriedName :: String -> String
802+---------------------------------------------------------------------------------------------------
803+curriedName name = '$' : name
804+
805+---------------------------------------------------------------------------------------------------
806+uncurried' :: Cpp -> Cpp
807+---------------------------------------------------------------------------------------------------
808+uncurried' (CppVar ('$':name)) = CppVar name
809+uncurried' (CppAccessor a b) = CppAccessor (uncurried' a) b
810+uncurried' cpp = cpp
811+
812+---------------------------------------------------------------------------------------------------
813+curriedName' :: Cpp -> Cpp
814+---------------------------------------------------------------------------------------------------
815+curriedName' (CppVar name) = CppVar (curriedName name)
816+curriedName' (CppAccessor a b) = CppAccessor (curriedName' a) b
817+curriedName' cpp = cpp