@@ -29,10 +29,10 @@ module Language.PureScript.CodeGen.Cpp
2929import Prelude.Compat
3030
3131import Data.Char (isLetter)
32−import Data.List
3332import Data.Function (on)
34−import Data.Maybe (catMaybes, fromJust)
33+import Data.List
3534import qualified Data.Map as M
35+import Data.Maybe (catMaybes, fromJust)
3636
3737import Control.Monad (forM, replicateM)
3838import Control.Monad.Reader (MonadReader, ask)
@@ -61,59 +61,57 @@ import qualified Language.PureScript.Types as T
6161-- module.
6262--
6363---------------------------------------------------------------------------------------------------
64−moduleToCpp :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m)
65− => E.Environment -> Module Ann -> m [Cpp]
64+moduleToCpp
65+ :: forall m.
66+ (Applicative m, Monad m, MonadReader Options m, MonadSupply m)
67+ => E.Environment -> Module Ann -> m [Cpp]
6668---------------------------------------------------------------------------------------------------
6769moduleToCpp env (Module _ mn imps _ foreigns decls) = do
68− cppImports <-
69− traverse (pure . runModuleName) .
70− delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $
71− (snd <$> imps)
72− let cppImports' = "PureScript" : cppImports
73− cppDecls <- concat <$> mapM (bindToCpp [TopLevel]) decls
74− let cpps = filterInlineFuncs <$> cppDecls
75− namesmap = M.toList .
76− M.mapKeysMonotonic (qualifiedToCpp id) . M.map (\(t, _, _) -> arity t) $
77− E.names env
78− datamap = M.toList .
79− M.mapKeysMonotonic (qualifiedToCpp (Ident . runProperName)) .
80− M.map (\(_, _, _, fields) -> length fields) $
81− E.dataConstructors env
82− cpps' <- traverse (optimize $ namesmap ++ datamap) cpps
83− foreignWrappers <- curriedForeigns
84− let optimized = cpps' ++ foreignWrappers
85− let moduleHeader =
86− fileBegin mn "HH" ++
87− P.linebreak ++
88− ((\i -> CppInclude i i) <$> cppImports') ++
89− (if not (null foreigns)
90− then [CppInclude [] (runModuleName mn ++ "_ffi")]
91− else []) ++
92− P.linebreak ++
93− [ CppNamespace (runModuleName mn) $
94− (CppUseNamespace <$> cppImports') ++
95− P.linebreak ++
96− dataCtors ++
97− toHeader optimized ++
98− toHeaderFns optimized
99− ] ++
100− P.linebreak ++
101− fileEnd mn "HH"
102− let bodyCpps = toBodyDecl optimized ++ toBody optimized
103− symbols = allSymbols bodyCpps
104− moduleBody =
105− CppInclude (runModuleName mn) (runModuleName mn) :
106− symbolDefs symbols :
107− (if null bodyCpps
108− then []
109− else [ CppNamespace (runModuleName mn) $
110− (CppUseNamespace <$> cppImports') ++
111− P.linebreak ++ bodyCpps ]) ++
112− P.linebreak ++
113− (if isMain mn
114− then [nativeMain] ++ P.linebreak
115− else [])
116− return $ moduleHeader ++ CppEndOfHeader : moduleBody
70+ cppImports <-
71+ traverse (pure . runModuleName) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $
72+ (snd <$> imps)
73+ let cppImports' = "PureScript" : cppImports
74+ cppDecls <- concat <$> mapM (bindToCpp [TopLevel]) decls
75+ let cpps = filterInlineFuncs <$> cppDecls
76+ namesmap =
77+ M.toList . M.mapKeysMonotonic (qualifiedToCpp id) . M.map (\(t, _, _) -> arity t) $
78+ E.names env
79+ datamap =
80+ M.toList .
81+ M.mapKeysMonotonic (qualifiedToCpp (Ident . runProperName)) .
82+ M.map (\(_, _, _, fields) -> length fields) $
83+ E.dataConstructors env
84+ cpps' <- traverse (optimize $ namesmap ++ datamap) cpps
85+ foreignWrappers <- curriedForeigns
86+ let optimized = cpps' ++ foreignWrappers
87+ let moduleHeader =
88+ fileBegin mn "HH" ++
89+ P.linebreak ++
90+ ((\i -> CppInclude i i) <$> cppImports') ++
91+ (if not (null foreigns)
92+ then [CppInclude [] (runModuleName mn ++ "_ffi")]
93+ else []) ++
94+ P.linebreak ++
95+ [ CppNamespace (runModuleName mn) $
96+ (CppUseNamespace <$> cppImports') ++
97+ P.linebreak ++ dataCtors ++ toHeader optimized ++ toHeaderFns optimized
98+ ] ++
99+ P.linebreak ++ fileEnd mn "HH"
100+ let bodyCpps = toBodyDecl optimized ++ toBody optimized
101+ symbols = allSymbols bodyCpps
102+ moduleBody =
103+ CppInclude (runModuleName mn) (runModuleName mn) :
104+ symbolDefs symbols :
105+ (if null bodyCpps
106+ then []
107+ else [ CppNamespace (runModuleName mn) $
108+ (CppUseNamespace <$> cppImports') ++ P.linebreak ++ bodyCpps
109+ ]) ++
110+ P.linebreak ++
111+ (if isMain mn
112+ then [nativeMain] ++ P.linebreak
113+ else [])
114+ return $ moduleHeader ++ CppEndOfHeader : moduleBody
117115 where
118116 -- |
119117 -- Generate code in the simplified C++1x intermediate representation for a declaration
@@ -122,8 +120,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
122120 bindToCpp :: [ValueQual] -> Bind Ann -> m [Cpp]
123121 -------------------------------------------------------------------------------------------------
124122 bindToCpp qs (NonRec ann ident val) = return <$> declToCpp qs (ann, ident) val
125− bindToCpp qs (Rec vals) = forM vals (uncurry $ declToCpp (Recursive:qs))
126−
123+ bindToCpp qs (Rec vals) = forM vals (uncurry $ declToCpp (Recursive : qs))
127124 -- |
128125 -- Desugar a declaration into a variable introduction or named function
129126 -- declaration.
@@ -134,73 +131,89 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
134131 let className = identToCpp ident
135132 (supers, members) = span (C.__superclass_ `isPrefixOf`) (identToCpp <$> (fst $ unAbs e []))
136133 in return $ CppStruct className [CppEnum Nothing Nothing (sort supers ++ members)]
137−
138134 declToCpp vqs (_, ident) (Abs (_, com, ty, _) arg body) = do
139− fn <- if TopLevel `elem` vqs
140− then do
141− argNames <- replicateM (arity' - length args' - 1) freshName
142− let args'' = zip argNames (repeat aty)
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
165− (if null argNames
166− then snd abs'
167− else curriedApp
168− (tail argNames)
169− (App
170− nullAnn
171− (snd abs')
172− (Var nullAnn . Qualified Nothing . Ident $ head argNames)))
173− return $ CppNamespace ""
174− [ CppFunction
175− name
176− (arg' : args' ++ args'')
177− rty
178− (vqs ++ if isAccessor (snd abs') then [Inline] else [])
179− (returnBlock body')
180− , CppFunction
181− (curriedName name)
182− [arg']
183− rty
184− (if arity' == 1 then [Inline] else [])
185− (returnBlock $
186− curriedLambda
187− (fst <$> args' ++ args'')
188− (CppApp (CppVar name)
189− (CppVar . fst <$> (arg' : args' ++ args''))))
190− ]
135+ fn <-
136+ if TopLevel `elem` vqs
137+ then do
138+ remainingArgs <- replicateM (arity' - length args' - 1) freshName
139+ let remainingArgs' = zip remainingArgs (repeat aty)
140+ if isTypeClassMember
141+ then do -- typeclass member functions are stored curried
142+ body' <- innerLambdas . optIndexers classes <$> valueToCpp (snd abs')
143+ return $
144+ CppNamespace
145+ ""
146+ [ CppFunction (curriedName name) [arg'] rty [Inline] (returnBlock body')
147+ , CppFunction
148+ name
149+ (arg' : args' ++ remainingArgs')
150+ rty
151+ (vqs ++
152+ if isAccessor (snd abs')
153+ then [Inline]
154+ else [])
155+ (returnBlock $
156+ foldl
157+ (\fn a -> CppApp fn [a])
158+ body'
159+ (CppVar . fst <$> (args' ++ remainingArgs')))
160+ ]
191161 else do
192− body' <- innerLambdas . optIndexers classes <$> valueToCpp body
193− return $ CppFunction
194− name
195− [arg']
196− rty
197− (vqs ++ if isIndexer body' then [Inline] else [])
198− (returnBlock body')
162+ body' <-
163+ innerLambdas . optIndexers classes <$>
164+ valueToCpp
165+ (if null remainingArgs
166+ then snd abs'
167+ else curriedApp
168+ (tail remainingArgs)
169+ (App
170+ nullAnn
171+ (snd abs')
172+ (Var nullAnn . Qualified Nothing . Ident $ head remainingArgs)))
173+ return $
174+ CppNamespace
175+ ""
176+ [ CppFunction
177+ name
178+ (arg' : args' ++ remainingArgs')
179+ rty
180+ (vqs ++
181+ if isAccessor (snd abs')
182+ then [Inline]
183+ else [])
184+ (returnBlock body')
185+ , CppFunction
186+ (curriedName name)
187+ [arg']
188+ rty
189+ (if arity' == 1
190+ then [Inline]
191+ else [])
192+ (returnBlock $
193+ curriedLambda
194+ (fst <$> args' ++ remainingArgs')
195+ (CppApp
196+ (CppVar name)
197+ (CppVar . fst <$> (arg' : args' ++ remainingArgs'))))
198+ ]
199+ else do
200+ body' <- innerLambdas . optIndexers classes <$> valueToCpp body
201+ return $
202+ CppFunction
203+ name
204+ [arg']
205+ rty
206+ (vqs ++
207+ if isIndexer body'
208+ then [Inline]
209+ else [])
210+ (returnBlock body')
199211 return (CppComment com $ convertIfPrimFn ty' fn)
200212 where
201− ty' | Just t <- ty = Just t
202− | Just (t, _, _) <- M.lookup (Qualified (Just mn) ident) (E.names env) = Just t
203− | otherwise = Nothing
213+ ty'
214+ | Just t <- ty = Just t
215+ | Just (t, _, _) <- M.lookup (Qualified (Just mn) ident) (E.names env) = Just t
216+ | otherwise = Nothing
204217 isTypeClassMember = ident `elem` typeClassMembers
205218 arity' = maybe 0 arity ty'
206219 name = identToCpp ident
@@ -210,105 +223,90 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
210223 args' = (\i -> (identToCpp i, aty)) <$> fst abs'
211224 abs' = unAbs body []
212225 isAccessor :: Expr Ann -> Bool
213− isAccessor Accessor{} = True
226+ isAccessor Accessor {} = True
214227 isAccessor _ = False
215228 isIndexer :: Cpp -> Bool
216229 isIndexer (CppIndexer (CppSymbol _) (CppVar _)) = True
217230 isIndexer _ = False
218− classes = zip (CppVar . fst <$> arg' : args')
219− (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$> maybe [] extractConstraints ty')
220−
221−
231+ classes =
232+ zip
233+ (CppVar . fst <$> arg' : args')
234+ (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$>
235+ maybe [] extractConstraints ty')
222236 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) []) =
223237 return $
224− CppFunction
225− (identToCpp ident)
226− []
227− (Just $ Any [])
228− [Inline]
229− (returnBlock $
230− CppDataLiteral [CppAccessor (CppVar $ identToCpp ident) (CppVar "data")])
231−
238+ CppFunction
239+ (identToCpp ident)
240+ []
241+ (Just $ Any [])
242+ [Inline]
243+ (returnBlock $ CppDataLiteral [CppAccessor (CppVar $ identToCpp ident) (CppVar "data")])
232244 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) fields) =
233245 return . CppNamespace "" $
234246 [ CppFunction
235− name
236− (farg <$> fields')
237− (Just $ Any [])
238− [Inline]
239− (returnBlock $
240− CppDataLiteral $
241− CppAccessor (CppVar name) (CppVar "data") : (CppVar <$> fields'))
247+ name
248+ (farg <$> fields')
249+ (Just $ Any [])
250+ [Inline]
251+ (returnBlock $
252+ CppDataLiteral $ CppAccessor (CppVar name) (CppVar "data") : (CppVar <$> fields'))
242253 ] ++
243254 if length fields > 0
244− then
245− [ CppFunction
246− (curriedName name)
247− (farg <$> f)
248− (Just $ Any [])
249− (if length fields == 1 then [Inline] else [])
250− (CppBlock (fieldLambdas fs))
251− ]
252− else
253− []
255+ then [ CppFunction
256+ (curriedName name)
257+ (farg <$> f)
258+ (Just $ Any [])
259+ (if length fields == 1
260+ then [Inline]
261+ else [])
262+ (CppBlock (fieldLambdas fs))
263+ ]
264+ else []
254265 where
255266 name = identToCpp ident
256267 fields' = identToCpp <$> fields
257− (f, fs) | (f' : fs') <- fields' = ([f'], fs')
258− | otherwise = ([], [])
268+ (f, fs)
269+ | (f':fs') <- fields' = ([f'], fs')
270+ | otherwise = ([], [])
259271 farg = \x -> (x, Just $ Any [Const, Ref])
260272 fieldLambdas flds
261− | (f' : fs') <- flds = [ CppReturn . maybeRemCaps $
262− CppLambda
263− [CaptureAll]
264− (farg <$> [f'])
265− (Just $ Any [])
266− (CppBlock $ fieldLambdas fs') ]
273+ | (f':fs') <- flds =
274+ [ CppReturn . maybeRemCaps $
275+ CppLambda [CaptureAll] (farg <$> [f']) (Just $ Any []) (CppBlock $ fieldLambdas fs')
276+ ]
267277 | otherwise = [CppReturn $ CppApp (CppVar name) (CppVar <$> fields')]
268−
269278 declToCpp qs (_, ident) e
270− | Just ty <- exprType e,
271− TopLevel `elem` qs,
272− arity' <- arity ty,
273− arity' > 0 = do
274− argNames <- replicateM arity' freshName
275− body' <- valueToCpp $
276− curriedApp
277− (tail argNames)
278− (App nullAnn e (Var nullAnn . Qualified Nothing . Ident $ head argNames))
279− let fn' = CppFunction
280− (curriedName name)
281− [(head argNames, Just $ Any [Const, Ref])]
282− rty
283− []
284− (returnBlock $
285− curriedLambda
286− (tail argNames)
287− (CppApp (CppVar name)
288− (CppVar <$> argNames)))
289− return $ CppNamespace "" $
290− [ CppFunction
291− name
292− (zip argNames $ repeat aty)
293− rty
294− []
295− (returnBlock body')
296− ] ++ if arity' > 0
297− then [fn']
298− else []
279+ | Just ty <- exprType e
280+ , TopLevel `elem` qs
281+ , arity' <- arity ty
282+ , arity' > 0 = do
283+ argNames <- replicateM arity' freshName
284+ body' <-
285+ valueToCpp $
286+ curriedApp
287+ (tail argNames)
288+ (App nullAnn e (Var nullAnn . Qualified Nothing . Ident $ head argNames))
289+ let fn' =
290+ CppFunction
291+ (curriedName name)
292+ [(head argNames, Just $ Any [Const, Ref])]
293+ rty
294+ []
295+ (returnBlock $
296+ curriedLambda (tail argNames) (CppApp (CppVar name) (CppVar <$> argNames)))
297+ return $
298+ CppNamespace "" $
299+ [CppFunction name (zip argNames $ repeat aty) rty [] (returnBlock body')] ++
300+ if arity' > 0
301+ then [fn']
302+ else []
299303 where
300304 name = identToCpp ident
301305 aty = Just $ Any [Const, Ref]
302306 rty = Just $ Any []
303−
304307 declToCpp qs (_, ident) val = do
305308 val' <- valueToCpp val
306− return $
307− CppVariableIntroduction
308− (identToCpp ident, Just $ Any [Const])
309− qs
310− (Just val')
311−
309+ return $ CppVariableIntroduction (identToCpp ident, Just $ Any [Const]) qs (Just val')
312310 -------------------------------------------------------------------------------------------------
313311 exprType :: Expr Ann -> Maybe T.Type
314312 -------------------------------------------------------------------------------------------------
@@ -317,21 +315,20 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
317315 exprType (Case (_, _, Just ty, _) _ _) = Just ty
318316 exprType (Let (_, _, Just ty, _) _ _) = Just ty
319317 exprType _ = Nothing
320−
321318 -------------------------------------------------------------------------------------------------
322319 fnToLambda :: Cpp -> Cpp
323320 -------------------------------------------------------------------------------------------------
324321 fnToLambda (CppFunction name args _ qs body) =
325322 CppVariableIntroduction
326− (name, Just $ Any [Const])
327− (filter (==Static) qs)
328− (Just $ CppLambda cs args (Just $ Any []) body)
323+ (name, Just $ Any [Const])
324+ (filter (== Static) qs)
325+ (Just $ CppLambda cs args (Just $ Any []) body)
329326 where
330− cs | (not . null) (qs `intersect` [Inline, Static]) = []
331− | otherwise = [CaptureAll]
327+ cs
328+ | (not . null) (qs `intersect` [Inline, Static]) = []
329+ | otherwise = [CaptureAll]
332330 fnToLambda (CppComment com cpp) = CppComment com (fnToLambda cpp)
333331 fnToLambda _ = error "Not a function!"
334−
335332 -------------------------------------------------------------------------------------------------
336333 innerLambdas :: Cpp -> Cpp
337334 -------------------------------------------------------------------------------------------------
@@ -341,7 +338,6 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
341338 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f
342339 go (CppLambda _ args rtyp body) = maybeRemCaps $ CppLambda [CaptureAll] args rtyp body
343340 go cpp = cpp
344−
345341 -------------------------------------------------------------------------------------------------
346342 convertRecursiveFns :: [Cpp] -> Cpp -> [Cpp]
347343 -------------------------------------------------------------------------------------------------
@@ -350,82 +346,74 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
350346 where
351347 cpps' = everywhereOnCpp removeRec <$> cpps
352348 allCpps = CppBlock $ otherCpp : cpps'
353−
354349 fns :: [(String, Cpp)]
355350 fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps
356−
357351 filteredFns :: Cpp -> [(String, Cpp)]
358− filteredFns cpp = filter (\(f,_) -> everythingOnCpp (||) (== CppVar f) cpp) fns
359−
352+ filteredFns cpp = filter (\(f, _) -> everythingOnCpp (||) (== CppVar f) cpp) fns
360353 recursive :: Cpp -> [Cpp]
361− recursive cpp'@(CppFunction _ _ _ qs _) | Recursive `elem` qs = [cpp']
362− recursive cpp'@(CppVariableIntroduction _ qs _) | Recursive `elem` qs = [cpp']
354+ recursive cpp'@(CppFunction _ _ _ qs _)
355+ | Recursive `elem` qs = [cpp']
356+ recursive cpp'@(CppVariableIntroduction _ qs _)
357+ | Recursive `elem` qs = [cpp']
363358 recursive _ = []
364−
365359 removeRec :: Cpp -> Cpp
366− removeRec (CppFunction _ _ _ qs _) | Recursive `elem` qs = CppNoOp
367− removeRec (CppVariableIntroduction _ qs _) | Recursive `elem` qs = CppNoOp
360+ removeRec (CppFunction _ _ _ qs _)
361+ | Recursive `elem` qs = CppNoOp
362+ removeRec (CppVariableIntroduction _ qs _)
363+ | Recursive `elem` qs = CppNoOp
368364 removeRec cpp' = cpp'
369−
370365 replaceVar :: [(String, Cpp)] -> Cpp -> Cpp
371366 replaceVar rs = go
372367 where
373− go (CppVar var) | Just var' <- lookup var rs = var'
368+ go (CppVar var)
369+ | Just var' <- lookup var rs = var'
374370 go cpp' = cpp'
375−
376371 dict :: Cpp
377− dict = CppVariableIntroduction
378− (topdict, Just $ Any [Const])
379− []
380− (Just $ CppDataLiteral ((\(f,cpp) -> CppComment [LineComment f] cpp) <$> fns))
381−
372+ dict =
373+ CppVariableIntroduction
374+ (topdict, Just $ Any [Const])
375+ []
376+ (Just $ CppDataLiteral ((\(f, cpp) -> CppComment [LineComment f] cpp) <$> fns))
382377 accessed :: String -> String -> (String, Cpp)
383378 accessed dictname name =
384− (name, CppApp
385− (CppIndexer
386− (CppNumericLiteral .
387− Left .
388− fromIntegral .
389− fromJust $ findIndex ((== name) . fst) fns)
390− dict'')
391− [dict'])
379+ ( name
380+ , CppApp
381+ (CppIndexer
382+ (CppNumericLiteral . Left . fromIntegral . fromJust $ findIndex ((== name) . fst) fns)
383+ dict'')
384+ [dict'])
392385 where
393386 dict' = CppVar dictname
394387 dict'' = CppCast (dataType 1) dict'
395−
396388 accessor :: String -> (String, Cpp) -> Cpp
397389 accessor dictname (name, _) =
398− CppVariableIntroduction
399− (name, Just $ Any [Const])
400− []
401− (Just . snd $ accessed dictname name)
402−
390+ CppVariableIntroduction (name, Just $ Any [Const]) [] (Just . snd $ accessed dictname name)
403391 toelem :: Cpp -> (String, Cpp)
404392 toelem (CppFunction name args rtyp _ body'@(CppBlock body)) =
405− (name, withdict . maybeRemCaps $ CppLambda
406− [CaptureAll]
407− args
408− rtyp
409− (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))
410−
393+ ( name
394+ , withdict . maybeRemCaps $
395+ CppLambda
396+ [CaptureAll]
397+ args
398+ rtyp
399+ (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))
411400 toelem (CppVariableIntroduction (name, _) _ (Just body')) =
412401 let replacements = accessed localdict . fst <$> filteredFns body'
413402 replaced = everywhereOnCpp (replaceVar replacements) body'
414403 in (name, withdict . maybeRemCaps $ CppBlock [CppReturn replaced])
415−
416404 toelem _ = error "not a function"
417−
418405 withdict :: Cpp -> Cpp
419− withdict cpp' = maybeRemCaps $ CppLambda
420− [CaptureAll]
421− [(localdict, Just $ Any [Const, Ref])]
422− (Just $ Any [])
423− (returnBlock cpp')
406+ withdict cpp' =
407+ maybeRemCaps $
408+ CppLambda
409+ [CaptureAll]
410+ [(localdict, Just $ Any [Const, Ref])]
411+ (Just $ Any [])
412+ (returnBlock cpp')
424413 topdict :: String
425414 topdict = "_$dict$_"
426415 localdict :: String
427416 localdict = "$dict$"
428−
429417 convertRecursiveFns cpps _ = cpps
430418
431419 -- |
@@ -434,126 +422,98 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
434422 -------------------------------------------------------------------------------------------------
435423 valueToCpp :: Expr Ann -> m Cpp
436424 -------------------------------------------------------------------------------------------------
437− valueToCpp (Var (_, _, _, Just IsNewtype) ident) =
438− return $ varToCpp ident
439−
440− valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) =
441− return $ CppApp (varToCpp ident) []
442−
425+ valueToCpp (Var (_, _, _, Just IsNewtype) ident) = return $ varToCpp ident
426+ valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) = return $ CppApp (varToCpp ident) []
443427 valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))
444− | arity ty > 0 =
445− return . curriedName' $ varToCpp ident
446−
447− valueToCpp (Var _ ident) =
448− return $ varToCpp ident
449−
450− valueToCpp (Literal _ (NumericLiteral n)) =
451− return (CppNumericLiteral n)
452−
453− valueToCpp (Literal _ (StringLiteral s)) =
454− return (CppStringLiteral s)
455−
456− valueToCpp (Literal _ (CharLiteral c)) =
457− return (CppCharLiteral c)
458−
459− valueToCpp (Literal _ (BooleanLiteral b)) =
460− return (CppBooleanLiteral b)
461−
462− valueToCpp (Literal _ (ArrayLiteral xs)) =
463− CppArrayLiteral <$> mapM valueToCpp xs
464−
428+ | arity ty > 0 = return . curriedName' $ varToCpp ident
429+ valueToCpp (Var _ ident) = return $ varToCpp ident
430+ valueToCpp (Literal _ (NumericLiteral n)) = return (CppNumericLiteral n)
431+ valueToCpp (Literal _ (StringLiteral s)) = return (CppStringLiteral s)
432+ valueToCpp (Literal _ (CharLiteral c)) = return (CppCharLiteral c)
433+ valueToCpp (Literal _ (BooleanLiteral b)) = return (CppBooleanLiteral b)
434+ valueToCpp (Literal _ (ArrayLiteral xs)) = CppArrayLiteral <$> mapM valueToCpp xs
465435 valueToCpp (Literal _ (ObjectLiteral ps)) =
466436 CppMapLiteral Record <$>
467− mapM (sndM valueToCpp) ((\(k,v) -> (CppSymbol k, v)) <$> sortBy (compare `on` fst) ps)
468−
469− valueToCpp (Accessor _ prop val) =
470− CppIndexer <$> pure (CppSymbol prop) <*> valueToCpp val
471−
437+ mapM (sndM valueToCpp) ((\(k, v) -> (CppSymbol k, v)) <$> sortBy (compare `on` fst) ps)
438+ valueToCpp (Accessor _ prop val) = CppIndexer <$> pure (CppSymbol prop) <*> valueToCpp val
472439 -- TODO: use a more efficient way of copying/updating the map?
473440 valueToCpp (ObjectUpdate (_, _, Just ty, _) obj ps) = do
474441 obj' <- valueToCpp obj
475442 updatedFields <- mapM (sndM valueToCpp) ps
476443 let origKeys = (allKeys ty) \\ (fst <$> updatedFields)
477444 origFields = (\key -> (key, CppIndexer (CppSymbol key) obj')) <$> origKeys
478− return $ CppMapLiteral Record $
479− (\(k,v) -> (CppSymbol k, v)) <$> sortBy (compare `on` fst) (origFields ++ updatedFields)
445+ return $
446+ CppMapLiteral Record $
447+ (\(k, v) -> (CppSymbol k, v)) <$> sortBy (compare `on` fst) (origFields ++ updatedFields)
480448 where
481449 allKeys :: T.Type -> [String]
482450 allKeys (T.TypeApp (T.TypeConstructor _) r@(T.RCons {})) = fst <$> (fst $ T.rowToList r)
483451 allKeys (T.ForAll _ t _) = allKeys t
484452 allKeys _ = error $ show "Not a recognized row type"
485−
486453 valueToCpp (ObjectUpdate _ _ _) = error $ "Bad Type in object update!"
487−
488454 valueToCpp (Abs (_, _, ty, _) arg body) = do
489455 cpp <- valueToCpp body
490456 let cpp' = innerLambdas cpp
491457 return $
492458 CppLambda
493− []
494− [(identToCpp arg, Just $ Any [Const, Ref])]
495− (Just $ Any [])
496− (returnBlock $ optIndexers classes cpp')
459+ []
460+ [(identToCpp arg, Just $ Any [Const, Ref])]
461+ (Just $ Any [])
462+ (returnBlock $ optIndexers classes cpp')
497463 where
498− arg' = identToCpp arg
499− args' = identToCpp <$> (fst $ unAbs body [])
500− classes = zip (CppVar <$> arg' : args')
501− (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$> maybe [] extractConstraints ty)
502−
503− valueToCpp e@App{} = do
464+ arg' = identToCpp arg
465+ args' = identToCpp <$> (fst $ unAbs body [])
466+ classes =
467+ zip
468+ (CppVar <$> arg' : args')
469+ (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$>
470+ maybe [] extractConstraints ty)
471+ valueToCpp e@App {} = do
504472 let (f, args) = unApp e []
505473 args' <- mapM valueToCpp args
506474 case f of
507475 Var (_, _, _, Just IsNewtype) _ -> return (head args')
508476 Var (_, _, _, Just IsTypeClassConstructor) (Qualified mn' (Ident classname)) ->
509− let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname)) in
510− return . CppMapLiteral Instance $
511− zip
512− (CppSymbol <$> (sort $ superClassDictionaryNames constraints) ++ (fst <$> fns))
513− args'
477+ let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname))
478+ in return . CppMapLiteral Instance $
479+ zip (CppSymbol <$> (sort $ superClassDictionaryNames constraints) ++ (fst <$> fns)) args'
514480 Var _ (Qualified (Just _) _) -> applied f args' curriedName'
515481 _ -> applied f args' id
516482 where
517483 applied f args g = flip (foldl (\fn a -> CppApp (g fn) [a])) args <$> valueToCpp f
518−
519484 valueToCpp (Case (maybeSpan, _, ty, _) values binders) = do
520485 vals <- mapM valueToCpp values
521486 bindersToCpp maybeSpan ty binders vals
522−
523487 valueToCpp (Let _ ds val) = do
524488 ds' <- concat <$> mapM (bindToCpp []) ds
525489 ret <- valueToCpp val
526490 opts <- ask
527491 let ds'' = tco opts <$> ds'
528− let rs = if hasRecursion ds''
529− then convertRecursiveFns ds'' ret
530− else ds''
492+ let rs =
493+ if hasRecursion ds''
494+ then convertRecursiveFns ds'' ret
495+ else ds''
531496 let cpps = innerLambdas <$> rs
532− return $ CppApp
533− (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret])))
534− []
497+ return $ CppApp (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret]))) []
535498 where
536499 hasRecursion :: [Cpp] -> Bool
537500 hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'
538501 where
539502 valnames :: [String]
540− valnames = concatMap (everythingOnCpp (++) valname) cpps'
541−
503+ valnames = concatMap (everythingOnCpp (++) valname) cpps'
542504 valname :: Cpp -> [String]
543505 valname (CppFunction name _ _ _ _) = [name]
544506 valname (CppVariableIntroduction (name, _) _ _) = [name]
545507 valname _ = []
546−
547508 hasRecursiveRef :: Cpp -> Bool
548509 hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body
549510 hasRecursiveRef (CppVariableIntroduction _ _ (Just value)) = everythingOnCpp (||) ref value
550511 hasRecursiveRef _ = False
551−
552512 ref :: Cpp -> Bool
553− ref (CppVar name) | name `elem` valnames = True
513+ ref (CppVar name)
514+ | name `elem` valnames = True
554515 ref _ = False
555−
556− valueToCpp Constructor{} = return CppNoOp
516+ valueToCpp Constructor {} = return CppNoOp
557517
558518 -- |
559519 -- Generate code in the simplified C++1x intermediate representation for a reference to a
@@ -575,42 +535,41 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
575535 bindersToCpp maybeSpan _ binders vals = do
576536 valNames <- replicateM (length vals) freshName
577537 let assignments = zipWith mkVarDecl valNames (map Just vals)
578− cpps <- forM binders $ \(CaseAlternative bs result) -> do
579− ret <- guardsToCpp result
580− go valNames ret bs
538+ cpps <-
539+ forM binders $ \(CaseAlternative bs result) -> do
540+ ret <- guardsToCpp result
541+ go valNames ret bs
581542 return $
582543 CppApp
583544 (CppLambda
584− []
585− []
586− (Just $ Any [])
587− (CppBlock (assignments ++ concat cpps ++ [failedPatternError valNames])))
545+ []
546+ []
547+ (Just $ Any [])
548+ (CppBlock (assignments ++ concat cpps ++ [failedPatternError valNames])))
588549 []
589550 where
590− mkVarDecl :: String -> Maybe Cpp -> Cpp
591− mkVarDecl name = CppVariableIntroduction (name, Nothing) []
592− go :: [String] -> [Cpp] -> [Binder Ann] -> m [Cpp]
593− go _ done [] = return done
594− go (v:vs) done' (b:bs) = do
595− done'' <- go vs done' bs
596− binderToCpp v done'' b
597− go _ _ _ = error "Invalid arguments to bindersToCpp"
598−
599− failedPatternError :: [String] -> Cpp
600− failedPatternError _ =
601− CppThrow $ CppApp (CppVar "runtime_error") [CppStringLiteral errorMessage]
602−
603− errorMessage :: String
604− errorMessage = "Failed pattern match" ++
605− maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++
606− ": "
607−
608− guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [Cpp]
609− guardsToCpp (Left gs) = forM gs $ \(cond, val) -> do
551+ mkVarDecl :: String -> Maybe Cpp -> Cpp
552+ mkVarDecl name = CppVariableIntroduction (name, Nothing) []
553+ go :: [String] -> [Cpp] -> [Binder Ann] -> m [Cpp]
554+ go _ done [] = return done
555+ go (v:vs) done' (b:bs) = do
556+ done'' <- go vs done' bs
557+ binderToCpp v done'' b
558+ go _ _ _ = error "Invalid arguments to bindersToCpp"
559+ failedPatternError :: [String] -> Cpp
560+ failedPatternError _ =
561+ CppThrow $ CppApp (CppVar "runtime_error") [CppStringLiteral errorMessage]
562+ errorMessage :: String
563+ errorMessage =
564+ "Failed pattern match" ++
565+ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
566+ guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [Cpp]
567+ guardsToCpp (Left gs) =
568+ forM gs $ \(cond, val) -> do
610569 cond' <- valueToCpp cond
611− done <- valueToCpp val
570+ done <- valueToCpp val
612571 return $ CppIfElse cond' (returnBlock done) Nothing
613− guardsToCpp (Right v) = return . CppReturn <$> valueToCpp v
572+ guardsToCpp (Right v) = return . CppReturn <$> valueToCpp v
614573
615574 -- |
616575 -- Generate code in the simplified C++1x intermediate representation for a pattern match
@@ -619,112 +578,85 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
619578 -------------------------------------------------------------------------------------------------
620579 binderToCpp :: String -> [Cpp] -> Binder Ann -> m [Cpp]
621580 -------------------------------------------------------------------------------------------------
622− binderToCpp _ done (NullBinder{}) = return done
623−
624− binderToCpp varName done (LiteralBinder _ l) =
625− literalToBinderCpp varName done l
626−
581+ binderToCpp _ done (NullBinder {}) = return done
582+ binderToCpp varName done (LiteralBinder _ l) = literalToBinderCpp varName done l
627583 binderToCpp varName done (VarBinder _ ident) =
628584 return $
629− CppVariableIntroduction
630− (identToCpp ident, Just $ Any [Const])
631− []
632− (Just $ CppVar varName)
633− : done
634−
585+ CppVariableIntroduction (identToCpp ident, Just $ Any [Const]) [] (Just $ CppVar varName) : done
635586 binderToCpp varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
636587 binderToCpp varName done b
637−
638− binderToCpp varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields))
639− _
640− (Qualified mn' (ProperName ctor))
641− bs) = do
588+ binderToCpp varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified mn' (ProperName ctor)) bs) = do
642589 cpps <- go (zip fields bs) done
643590 return $
644591 case ctorType of
645592 ProductType -> cpps
646593 SumType ->
647− [ CppIfElse
648− (CppBinary
649− EqualTo
650− (CppIndexer
651− (CppVar ctorKey)
652− (CppCast (dataType 1) $ CppVar varName))
653− ctorCpp)
654− (CppBlock cpps)
655− Nothing]
594+ [ CppIfElse
595+ (CppBinary
596+ EqualTo
597+ (CppIndexer (CppVar ctorKey) (CppCast (dataType 1) $ CppVar varName))
598+ ctorCpp)
599+ (CppBlock cpps)
600+ Nothing
601+ ]
656602 where
657603 go :: [(Ident, Binder Ann)] -> [Cpp] -> m [Cpp]
658604 go [] done' = return done'
659− go ((field, binder) : remain) done' = do
605+ go ((field, binder):remain) done' = do
660606 argVar <- freshName
661607 done'' <- go remain done'
662608 cpps <- binderToCpp argVar done'' binder
663609 return $
664610 CppVariableIntroduction
665− (argVar, Nothing)
666− []
667− (Just $ CppIndexer
668− (fieldToIndex' field)
669− (CppCast (dataType $ fieldToIndex field + 1) $ CppVar varName))
670− : cpps
611+ (argVar, Nothing)
612+ []
613+ (Just $
614+ CppIndexer
615+ (fieldToIndex' field)
616+ (CppCast (dataType $ fieldToIndex field + 1) $ CppVar varName)) :
617+ cpps
671618 fieldToIndex :: Ident -> Int
672− fieldToIndex = (+1) . read . dropWhile isLetter . runIdent
619+ fieldToIndex = (+ 1) . read . dropWhile isLetter . runIdent
673620 fieldToIndex' :: Ident -> Cpp
674621 fieldToIndex' = CppNumericLiteral . Left . toInteger . fieldToIndex
675622 ctor' :: Cpp
676623 ctor' = CppAccessor (CppVar . identToCpp $ Ident ctor) (CppVar "data")
677624 ctorCpp :: Cpp
678− ctorCpp | Just mn'' <- mn', mn'' /= mn = CppAccessor ctor' (CppVar $ moduleNameToCpp mn'')
679− | otherwise = ctor'
680−
681− binderToCpp _ _ b@(ConstructorBinder{}) =
625+ ctorCpp
626+ | Just mn'' <- mn'
627+ , mn'' /= mn = CppAccessor ctor' (CppVar $ moduleNameToCpp mn'')
628+ | otherwise = ctor'
629+ binderToCpp _ _ b@(ConstructorBinder {}) =
682630 error $ "Invalid ConstructorBinder in binderToCpp: " ++ show b
683−
684631 binderToCpp varName done (NamedBinder _ ident binder) = do
685632 cpp <- binderToCpp varName done binder
686633 return $
687− CppVariableIntroduction
688− (identToCpp ident, Just $ Any [Const])
689− []
690− (Just $ CppVar varName)
691− : cpp
692−
634+ CppVariableIntroduction (identToCpp ident, Just $ Any [Const]) [] (Just $ CppVar varName) :
635+ cpp
693636 -------------------------------------------------------------------------------------------------
694637 literalToBinderCpp :: String -> [Cpp] -> Literal (Binder Ann) -> m [Cpp]
695638 -------------------------------------------------------------------------------------------------
696639 literalToBinderCpp varName done (NumericLiteral num) =
697− return [ CppIfElse
698− (CppBinary EqualTo (CppVar varName) (CppNumericLiteral num))
699− (CppBlock done)
700− Nothing ]
701−
640+ return
641+ [ CppIfElse
642+ (CppBinary EqualTo (CppVar varName) (CppNumericLiteral num))
643+ (CppBlock done)
644+ Nothing
645+ ]
702646 literalToBinderCpp varName done (CharLiteral c) =
703− return [ CppIfElse
704− (CppBinary EqualTo (CppVar varName) (CppCharLiteral c))
705− (CppBlock done)
706− Nothing ]
707−
647+ return
648+ [CppIfElse (CppBinary EqualTo (CppVar varName) (CppCharLiteral c)) (CppBlock done) Nothing]
708649 literalToBinderCpp varName done (StringLiteral str) =
709− return [ CppIfElse
710− (CppBinary EqualTo (CppVar varName) (CppStringLiteral str))
711− (CppBlock done)
712− Nothing ]
713−
650+ return
651+ [ CppIfElse
652+ (CppBinary EqualTo (CppVar varName) (CppStringLiteral str))
653+ (CppBlock done)
654+ Nothing
655+ ]
714656 literalToBinderCpp varName done (BooleanLiteral True) =
715− return [ CppIfElse
716− (CppVar varName)
717− (CppBlock done)
718− Nothing ]
719−
657+ return [CppIfElse (CppVar varName) (CppBlock done) Nothing]
720658 literalToBinderCpp varName done (BooleanLiteral False) =
721− return [ CppIfElse
722− (CppUnary
723− Not
724− (CppVar varName))
725− (CppBlock done)
726− Nothing ]
727−
659+ return [CppIfElse (CppUnary Not (CppVar varName)) (CppBlock done) Nothing]
728660 literalToBinderCpp varName done (ObjectLiteral bs) = go done bs
729661 where
730662 go :: [Cpp] -> [(String, Binder Ann)] -> m [Cpp]
@@ -735,27 +667,22 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
735667 cpp <- binderToCpp propVar done'' binder
736668 return $
737669 CppVariableIntroduction
738− (propVar, Nothing)
739− []
740− (Just $ CppIndexer
741− (CppSymbol prop)
742− (CppVar varName))
743− : cpp
744−
670+ (propVar, Nothing)
671+ []
672+ (Just $ CppIndexer (CppSymbol prop) (CppVar varName)) :
673+ cpp
745674 literalToBinderCpp varName done (ArrayLiteral bs) = do
746675 cpp <- go done 0 bs
747676 let cond =
748677 case length bs of
749− 0 -> CppBinary
750− Dot
751− (CppCast arrayType $ CppVar varName)
752− (CppApp (CppVar "empty") [])
753− n -> let var = CppCast arrayType $ CppVar varName
754− in CppBinary
755− EqualTo
756− (CppBinary Dot var (CppApp (CppVar "size") []))
757− (CppNumericLiteral (Left (fromIntegral n)))
758− return [ CppIfElse cond (CppBlock cpp) Nothing ]
678+ 0 -> CppBinary Dot (CppCast arrayType $ CppVar varName) (CppApp (CppVar "empty") [])
679+ n ->
680+ let var = CppCast arrayType $ CppVar varName
681+ in CppBinary
682+ EqualTo
683+ (CppBinary Dot var (CppApp (CppVar "size") []))
684+ (CppNumericLiteral (Left (fromIntegral n)))
685+ return [CppIfElse cond (CppBlock cpp) Nothing]
759686 where
760687 go :: [Cpp] -> Integer -> [Binder Ann] -> m [Cpp]
761688 go done' _ [] = return done'
@@ -765,25 +692,20 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
765692 cpp <- binderToCpp elVar done'' binder
766693 return $
767694 CppVariableIntroduction
768− (elVar, Nothing)
769− []
770− (Just $ CppIndexer
771− (CppNumericLiteral (Left index))
772− (CppVar varName))
773− : cpp
774−
695+ (elVar, Nothing)
696+ []
697+ (Just $ CppIndexer (CppNumericLiteral (Left index)) (CppVar varName)) :
698+ cpp
775699 -------------------------------------------------------------------------------------------------
776700 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
777701 -------------------------------------------------------------------------------------------------
778702 unApp (App _ val arg) args = unApp val (arg : args)
779703 unApp other args = (other, args)
780−
781704 -------------------------------------------------------------------------------------------------
782705 unAbs :: Expr Ann -> [Ident] -> ([Ident], Expr Ann)
783706 -------------------------------------------------------------------------------------------------
784707 unAbs (Abs _ arg val) args = unAbs val (args ++ [arg])
785708 unAbs other args = (args, other)
786−
787709 -------------------------------------------------------------------------------------------------
788710 qualifiedToCpp :: (a -> Ident) -> Qualified a -> Cpp
789711 -------------------------------------------------------------------------------------------------
@@ -797,63 +719,68 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
797719 -- Find a class in scope by name, retrieving its list of constraints, function names and types.
798720 --
799721 -------------------------------------------------------------------------------------------------
800− findClass :: Qualified (ProperName 'ClassName) -> Maybe ([String], [T.Constraint], [(String, T.Type)])
722+ findClass :: Qualified (ProperName 'ClassName)
723+ -> Maybe ([String], [T.Constraint], [(String, T.Type)])
801724 -------------------------------------------------------------------------------------------------
802725 findClass name
803− | Just tcd <- M.lookup name (E.typeClasses env),
804− fns' <- (\(i,t) -> (runIdent i, t)) <$> E.typeClassMembers tcd
805− = Just (fst <$> E.typeClassArguments tcd,
806− E.typeClassSuperclasses tcd,
807− (sortBy (compare `on` normalizedName . fst) fns'))
726+ | Just tcd <- M.lookup name (E.typeClasses env)
727+ , fns' <- (\(i, t) -> (runIdent i, t)) <$> E.typeClassMembers tcd =
728+ Just
729+ ( fst <$> E.typeClassArguments tcd
730+ , E.typeClassSuperclasses tcd
731+ , (sortBy (compare `on` normalizedName . fst) fns'))
808732 findClass _ = Nothing
809−
810733 -------------------------------------------------------------------------------------------------
811734 typeClassMembers :: [Ident]
812735 -------------------------------------------------------------------------------------------------
813− typeClassMembers = fst <$> (concat . M.elems $ M.map E.typeClassMembers (M.filterWithKey thisModule (E.typeClasses env)))
736+ typeClassMembers =
737+ fst <$>
738+ (concat . M.elems $ M.map E.typeClassMembers (M.filterWithKey thisModule (E.typeClasses env)))
814739 where
815740 thisModule (Qualified (Just mn') _) _ = mn' == mn
816741 thisModule _ _ = False
817−
818742 -------------------------------------------------------------------------------------------------
819743 dataCtors :: [Cpp]
820744 -------------------------------------------------------------------------------------------------
821− dataCtors = [CppNamespace "data"
822− [CppEnum Nothing (Just intType) . ("_" :) .
823− catMaybes . map modCtor . M.keys $ E.dataConstructors env]]
745+ dataCtors =
746+ [ CppNamespace
747+ "data"
748+ [ CppEnum Nothing (Just intType) . ("_" :) . catMaybes . map modCtor . M.keys $
749+ E.dataConstructors env
750+ ]
751+ ]
824752 where
825753 modCtor :: Qualified (ProperName a) -> Maybe String
826− modCtor (Qualified (Just mn') (ProperName name)) | mn' == mn = Just $ identToCpp (Ident name)
754+ modCtor (Qualified (Just mn') (ProperName name))
755+ | mn' == mn = Just $ identToCpp (Ident name)
827756 modCtor _ = Nothing
828−
829757 -------------------------------------------------------------------------------------------------
830758 curriedForeigns :: m [Cpp]
831759 -------------------------------------------------------------------------------------------------
832760 curriedForeigns = concat <$> mapM go allForeigns
833761 where
834762 go (ident, ty)
835− | arity' <- arity ty,
836− arity' > 0 = do
837− let name = identToCpp ident
838− argNames <- replicateM arity' freshName
839− return $
840− [ CppFunction
841− (curriedName name)
842− [(head argNames, Just $ Any [Const, Ref])]
843− (Just $ Any [])
844− (if arity' == 1 then [Inline] else [])
845− (returnBlock $
846− curriedLambda
847− (tail argNames)
848− (CppApp (CppVar name)
849− (CppVar <$> argNames)))
850− ]
763+ | arity' <- arity ty
764+ , arity' > 0 = do
765+ let name = identToCpp ident
766+ argNames <- replicateM arity' freshName
767+ return $
768+ [ CppFunction
769+ (curriedName name)
770+ [(head argNames, Just $ Any [Const, Ref])]
771+ (Just $ Any [])
772+ (if arity' == 1
773+ then [Inline]
774+ else [])
775+ (returnBlock $
776+ curriedLambda (tail argNames) (CppApp (CppVar name) (CppVar <$> argNames)))
777+ ]
851778 go _ = return []
852−
853779 allForeigns :: [(Ident, T.Type)]
854− allForeigns = map (\((Qualified _ ident), (ty, _, _)) -> (ident, ty)) .
855− filter (\((Qualified mn' _), (_, kind, _)) -> mn' == Just mn && kind == E.External) .
856− M.toList $ E.names env
780+ allForeigns =
781+ map (\((Qualified _ ident), (ty, _, _)) -> (ident, ty)) .
782+ filter (\((Qualified mn' _), (_, kind, _)) -> mn' == Just mn && kind == E.External) . M.toList $
783+ E.names env
857784
858785---------------------------------------------------------------------------------------------------
859786returnBlock :: Cpp -> Cpp
@@ -863,21 +790,18 @@ returnBlock cpp = CppBlock [CppReturn cpp]
863790---------------------------------------------------------------------------------------------------
864791curriedLambda :: [String] -> Cpp -> Cpp
865792---------------------------------------------------------------------------------------------------
866−curriedLambda args ret = foldr (\arg ret' -> CppLambda
867− [CaptureAll]
868− [(arg, Just $ Any [Const, Ref])]
869− (Just $ Any [])
870− (returnBlock ret')
871− ) ret args
793+curriedLambda args ret =
794+ foldr
795+ (\arg ret' ->
796+ CppLambda [CaptureAll] [(arg, Just $ Any [Const, Ref])] (Just $ Any []) (returnBlock ret'))
797+ ret
798+ args
872799
873800---------------------------------------------------------------------------------------------------
874801curriedApp :: [String] -> Expr Ann -> Expr Ann
875802---------------------------------------------------------------------------------------------------
876−curriedApp args vals = foldl (\val arg -> App
877− nullAnn
878− val
879− (Var nullAnn . Qualified Nothing $ Ident arg))
880− vals args
803+curriedApp args vals =
804+ foldl (\val arg -> App nullAnn val (Var nullAnn . Qualified Nothing $ Ident arg)) vals args
881805
882806---------------------------------------------------------------------------------------------------
883807arity :: T.Type -> Int
@@ -885,7 +809,8 @@ arity :: T.Type -> Int
885809arity = go 0
886810 where
887811 go arity' (T.ForAll _ t _) = go arity' t
888− go arity' (T.TypeApp (T.TypeApp fn _) t) | fn == E.tyFunction = go (arity' + 1) t
812+ go arity' (T.TypeApp (T.TypeApp fn _) t)
813+ | fn == E.tyFunction = go (arity' + 1) t
889814 go arity' (T.ConstrainedType ts t) = go (arity' + length ts) t
890815 go arity' _ = arity'
891816
@@ -895,29 +820,29 @@ extractConstraints :: T.Type -> [T.Constraint]
895820extractConstraints = go []
896821 where
897822 go cs (T.ForAll _ t _) = go cs t
898− go cs (T.TypeApp (T.TypeApp fn _) t) | fn == E.tyFunction = go cs t
823+ go cs (T.TypeApp (T.TypeApp fn _) t)
824+ | fn == E.tyFunction = go cs t
899825 go cs (T.ConstrainedType ts t) = go (cs ++ ts) t
900826 go cs _ = cs
901827
902828---------------------------------------------------------------------------------------------------
903−optIndexers :: [(Cpp,Cpp)] -> Cpp -> Cpp
829+optIndexers :: [(Cpp, Cpp)] -> Cpp -> Cpp
904830---------------------------------------------------------------------------------------------------
905831optIndexers classes = everywhereOnCpp dictIndexerToEnum
906832 where
907833 dictIndexerToEnum :: Cpp -> Cpp
908834 dictIndexerToEnum (CppIndexer (CppSymbol prop) dict)
909835 | Just cls <- lookup dict classes =
910− CppBinary Dot
911− (CppIndexer
912− (CppAccessor (CppVar . identToCpp $ Ident prop) cls)
913− (CppCast (mapType 0) dict))
836+ CppBinary
837+ Dot
838+ (CppIndexer (CppAccessor (CppVar . identToCpp $ Ident prop) cls) (CppCast (mapType 0) dict))
914839 (CppVar "second")
915840 dictIndexerToEnum cpp = cpp
916841
917842---------------------------------------------------------------------------------------------------
918843curriedName :: String -> String
919844---------------------------------------------------------------------------------------------------
920−curriedName name@('$' : _) = name
845+curriedName name@('$':_) = name
921846curriedName name = '$' : name
922847
923848---------------------------------------------------------------------------------------------------
@@ -932,14 +857,20 @@ primFn :: T.Type -> ([CppType], Maybe CppType)
932857---------------------------------------------------------------------------------------------------
933858primFn = go []
934859 where
935− go ps (T.TypeApp (T.TypeApp fn a) b) | fn == E.tyFunction,
936− Just a' <- numType a = go (ps ++ [a']) b
937− go ps t | Just t' <- numType t = (ps , Just t')
860+ go ps (T.TypeApp (T.TypeApp fn a) b)
861+ | fn == E.tyFunction
862+ , Just a' <- numType a = go (ps ++ [a']) b
863+ go ps t
864+ | Just t' <- numType t = (ps, Just t')
938865 go _ _ = ([], Nothing)
939− numType t@(T.TypeConstructor {}) | t == E.tyInt = Just intType
940− numType t@(T.TypeConstructor {}) | t == E.tyNumber = Just doubleType
941− numType t@(T.TypeConstructor {}) | t == E.tyBoolean = Just boolType
942− numType t@(T.TypeConstructor {}) | t == E.tyChar = Just charType
866+ numType t@(T.TypeConstructor {})
867+ | t == E.tyInt = Just intType
868+ numType t@(T.TypeConstructor {})
869+ | t == E.tyNumber = Just doubleType
870+ numType t@(T.TypeConstructor {})
871+ | t == E.tyBoolean = Just boolType
872+ numType t@(T.TypeConstructor {})
873+ | t == E.tyChar = Just charType
943874 numType _ = Nothing
944875
945876---------------------------------------------------------------------------------------------------
@@ -978,11 +909,11 @@ filterInlineFuncs = everywhereOnCpp convert
978909 convert :: Cpp -> Cpp
979910 convert (CppBlock []) = CppBlock []
980911 convert (CppFunction n ps r qs cpp)
981− | Inline `elem` qs,
982− everythingOnCpp (||) shouldRemove cpp = CppFunction n ps r (delete Inline qs) cpp
912+ | Inline `elem` qs
913+ , everythingOnCpp (||) shouldRemove cpp = CppFunction n ps r (delete Inline qs) cpp
983914 where
984915 shouldRemove :: Cpp -> Bool
985− shouldRemove CppSymbol{} = True
986− shouldRemove CppLambda{} = True
916+ shouldRemove CppSymbol {} = True
917+ shouldRemove CppLambda {} = True
987918 shouldRemove _ = False
988919 convert cpp = cpp