@@ -29,10 +29,10 @@ module Language.PureScript.CodeGen.Cpp
29import Prelude.Compat
29import Prelude.Compat
31import Data.Char (isLetter)
31import Data.Char (isLetter)
33import Data.Function (on)
32import Data.Function (on)
34−import Data.Maybe (catMaybes, fromJust)
33+import Data.List
35import qualified Data.Map as M
34import qualified Data.Map as M
35+import Data.Maybe (catMaybes, fromJust)
37import Control.Monad (forM, replicateM)
37import Control.Monad (forM, replicateM)
38import Control.Monad.Reader (MonadReader, ask)
38import Control.Monad.Reader (MonadReader, ask)
@@ -61,59 +61,57 @@ import qualified Language.PureScript.Types as T
63---------------------------------------------------------------------------------------------------
63---------------------------------------------------------------------------------------------------
64−moduleToCpp :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m)
66+ (Applicative m, Monad m, MonadReader Options m, MonadSupply m)
65− => E.Environment -> Module Ann -> m [Cpp]
67+ => E.Environment -> Module Ann -> m [Cpp]
66---------------------------------------------------------------------------------------------------
68---------------------------------------------------------------------------------------------------
67moduleToCpp env (Module _ mn imps _ foreigns decls) = do
69moduleToCpp env (Module _ mn imps _ foreigns decls) = do
68− cppImports <-
70+ cppImports <-
69− traverse (pure . runModuleName) .
70− delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $
71+ traverse (pure . runModuleName) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $
71− (snd <$> imps)
72+ (snd <$> imps)
72− let cppImports' = "PureScript" : cppImports
73+ let cppImports' = "PureScript" : cppImports
73− cppDecls <- concat <$> mapM (bindToCpp [TopLevel]) decls
74+ cppDecls <- concat <$> mapM (bindToCpp [TopLevel]) decls
74− let cpps = filterInlineFuncs <$> cppDecls
75+ let cpps = filterInlineFuncs <$> cppDecls
75− namesmap = M.toList .
76+ namesmap =
76− M.mapKeysMonotonic (qualifiedToCpp id) . M.map (\(t, _, _) -> arity t) $
77+ M.toList . M.mapKeysMonotonic (qualifiedToCpp id) . M.map (\(t, _, _) -> arity t) $
77− E.names env
78+ E.names env
78− datamap = M.toList .
79+ datamap =
79− M.mapKeysMonotonic (qualifiedToCpp (Ident . runProperName)) .
81+ M.mapKeysMonotonic (qualifiedToCpp (Ident . runProperName)) .
80− M.map (\(_, _, _, fields) -> length fields) $
82+ M.map (\(_, _, _, fields) -> length fields) $
81− E.dataConstructors env
83+ E.dataConstructors env
82− cpps' <- traverse (optimize $ namesmap ++ datamap) cpps
84+ cpps' <- traverse (optimize $ namesmap ++ datamap) cpps
83− foreignWrappers <- curriedForeigns
85+ foreignWrappers <- curriedForeigns
84− let optimized = cpps' ++ foreignWrappers
86+ let optimized = cpps' ++ foreignWrappers
85− let moduleHeader =
87+ let moduleHeader =
86− fileBegin mn "HH" ++
88+ fileBegin mn "HH" ++
87− P.linebreak ++
89+ P.linebreak ++
88− ((\i -> CppInclude i i) <$> cppImports') ++
90+ ((\i -> CppInclude i i) <$> cppImports') ++
89− (if not (null foreigns)
91+ (if not (null foreigns)
90− then [CppInclude [] (runModuleName mn ++ "_ffi")]
92+ then [CppInclude [] (runModuleName mn ++ "_ffi")]
91− else []) ++
93+ else []) ++
92− P.linebreak ++
94+ P.linebreak ++
93− [ CppNamespace (runModuleName mn) $
95+ [ CppNamespace (runModuleName mn) $
94− (CppUseNamespace <$> cppImports') ++
96+ (CppUseNamespace <$> cppImports') ++
97− toHeader optimized ++
98− toHeaderFns optimized
97+ P.linebreak ++ dataCtors ++ toHeader optimized ++ toHeaderFns optimized
101− fileEnd mn "HH"
99+ P.linebreak ++ fileEnd mn "HH"
102− let bodyCpps = toBodyDecl optimized ++ toBody optimized
100+ let bodyCpps = toBodyDecl optimized ++ toBody optimized
103− symbols = allSymbols bodyCpps
101+ symbols = allSymbols bodyCpps
104− moduleBody =
102+ moduleBody =
105− CppInclude (runModuleName mn) (runModuleName mn) :
103+ CppInclude (runModuleName mn) (runModuleName mn) :
106− symbolDefs symbols :
104+ symbolDefs symbols :
107− (if null bodyCpps
105+ (if null bodyCpps
109− else [ CppNamespace (runModuleName mn) $
107+ else [ CppNamespace (runModuleName mn) $
110− (CppUseNamespace <$> cppImports') ++
108+ (CppUseNamespace <$> cppImports') ++ P.linebreak ++ bodyCpps
111− P.linebreak ++ bodyCpps ]) ++
109+ ]) ++
112− P.linebreak ++
110+ P.linebreak ++
113− (if isMain mn
111+ (if isMain mn
114− then [nativeMain] ++ P.linebreak
112+ then [nativeMain] ++ P.linebreak
115− else [])
113+ else [])
116− return $ moduleHeader ++ CppEndOfHeader : moduleBody
114+ return $ moduleHeader ++ CppEndOfHeader : moduleBody
119 -- Generate code in the simplified C++1x intermediate representation for a declaration
117 -- Generate code in the simplified C++1x intermediate representation for a declaration
@@ -122,8 +120,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
122 bindToCpp :: [ValueQual] -> Bind Ann -> m [Cpp]
120 bindToCpp :: [ValueQual] -> Bind Ann -> m [Cpp]
123 -------------------------------------------------------------------------------------------------
121 -------------------------------------------------------------------------------------------------
124 bindToCpp qs (NonRec ann ident val) = return <$> declToCpp qs (ann, ident) val
122 bindToCpp qs (NonRec ann ident val) = return <$> declToCpp qs (ann, ident) val
125− bindToCpp qs (Rec vals) = forM vals (uncurry $ declToCpp (Recursive:qs))
123+ bindToCpp qs (Rec vals) = forM vals (uncurry $ declToCpp (Recursive : qs))
128 -- Desugar a declaration into a variable introduction or named function
125 -- Desugar a declaration into a variable introduction or named function
129 -- declaration.
126 -- declaration.
@@ -134,73 +131,89 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
134 let className = identToCpp ident
131 let className = identToCpp ident
135 (supers, members) = span (C.__superclass_ `isPrefixOf`) (identToCpp <$> (fst $ unAbs e []))
132 (supers, members) = span (C.__superclass_ `isPrefixOf`) (identToCpp <$> (fst $ unAbs e []))
136 in return $ CppStruct className [CppEnum Nothing Nothing (sort supers ++ members)]
133 in return $ CppStruct className [CppEnum Nothing Nothing (sort supers ++ members)]
138 declToCpp vqs (_, ident) (Abs (_, com, ty, _) arg body) = do
134 declToCpp vqs (_, ident) (Abs (_, com, ty, _) arg body) = do
139− fn <- if TopLevel `elem` vqs
136+ if TopLevel `elem` vqs
141− argNames <- replicateM (arity' - length args' - 1) freshName
138+ remainingArgs <- replicateM (arity' - length args' - 1) freshName
142− let args'' = zip argNames (repeat aty)
139+ let remainingArgs' = zip remainingArgs (repeat aty)
143− if isTypeClassMember
140+ if isTypeClassMember
144− then do -- typeclass member functions are stored curried
141+ then do -- typeclass member functions are stored curried
145− body' <- innerLambdas . optIndexers classes <$> valueToCpp (snd abs')
142+ body' <- innerLambdas . optIndexers classes <$> valueToCpp (snd abs')
146− return $ CppNamespace ""
144+ CppNamespace
147− [ CppFunction
145+ ""
148− (curriedName name)
146+ [ CppFunction (curriedName name) [arg'] rty [Inline] (returnBlock body')
153− , CppFunction
147+ , CppFunction
155− (arg' : args' ++ args'')
149+ (arg' : args' ++ remainingArgs')
157− (vqs ++ if isAccessor (snd abs') then [Inline] else [])
152+ if isAccessor (snd abs')
158− (returnBlock $
155+ (returnBlock $
159− foldl (\fn a -> CppApp fn [a])
157+ (\fn a -> CppApp fn [a])
161− (CppVar . fst <$> (args' ++ args'')))
159+ (CppVar . fst <$> (args' ++ remainingArgs')))
164− body' <- innerLambdas . optIndexers classes <$> valueToCpp
172− (Var nullAnn . Qualified Nothing . Ident $ head argNames)))
173− return $ CppNamespace ""
176− (arg' : args' ++ args'')
178− (vqs ++ if isAccessor (snd abs') then [Inline] else [])
184− (if arity' == 1 then [Inline] else [])
187− (fst <$> args' ++ args'')
188− (CppApp (CppVar name)
189− (CppVar . fst <$> (arg' : args' ++ args''))))
192− body' <- innerLambdas . optIndexers classes <$> valueToCpp body
163+ innerLambdas . optIndexers classes <$>
165+ (if null remainingArgs
168+ (tail remainingArgs)
172+ (Var nullAnn . Qualified Nothing . Ident $ head remainingArgs)))
178+ (arg' : args' ++ remainingArgs')
181+ if isAccessor (snd abs')
193− return $ CppFunction
185+ , CppFunction
194+ (fst <$> args' ++ remainingArgs')
194− name
196+ (CppVar name)
197+ (CppVar . fst <$> (arg' : args' ++ remainingArgs'))))
200+ body' <- innerLambdas . optIndexers classes <$> valueToCpp body
197− (vqs ++ if isIndexer body' then [Inline] else [])
207+ if isIndexer body'
198− (returnBlock body')
210+ (returnBlock body')
199 return (CppComment com $ convertIfPrimFn ty' fn)
211 return (CppComment com $ convertIfPrimFn ty' fn)
201− ty' | Just t <- ty = Just t
214+ | Just t <- ty = Just t
202− | Just (t, _, _) <- M.lookup (Qualified (Just mn) ident) (E.names env) = Just t
215+ | Just (t, _, _) <- M.lookup (Qualified (Just mn) ident) (E.names env) = Just t
203− | otherwise = Nothing
216+ | otherwise = Nothing
204 isTypeClassMember = ident `elem` typeClassMembers
217 isTypeClassMember = ident `elem` typeClassMembers
205 arity' = maybe 0 arity ty'
218 arity' = maybe 0 arity ty'
206 name = identToCpp ident
219 name = identToCpp ident
@@ -210,105 +223,90 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
210 args' = (\i -> (identToCpp i, aty)) <$> fst abs'
223 args' = (\i -> (identToCpp i, aty)) <$> fst abs'
211 abs' = unAbs body []
224 abs' = unAbs body []
212 isAccessor :: Expr Ann -> Bool
225 isAccessor :: Expr Ann -> Bool
213− isAccessor Accessor{} = True
226+ isAccessor Accessor {} = True
214 isAccessor _ = False
227 isAccessor _ = False
215 isIndexer :: Cpp -> Bool
228 isIndexer :: Cpp -> Bool
216 isIndexer (CppIndexer (CppSymbol _) (CppVar _)) = True
229 isIndexer (CppIndexer (CppSymbol _) (CppVar _)) = True
217 isIndexer _ = False
230 isIndexer _ = False
218− classes = zip (CppVar . fst <$> arg' : args')
233+ (CppVar . fst <$> arg' : args')
219− (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$> maybe [] extractConstraints ty')
234+ (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$>
220−
235+ maybe [] extractConstraints ty')
222 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) []) =
236 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) []) =
224− CppFunction
238+ CppFunction
225− (identToCpp ident)
239+ (identToCpp ident)
227− (Just $ Any [])
241+ (Just $ Any [])
228− [Inline]
242+ [Inline]
230− CppDataLiteral [CppAccessor (CppVar $ identToCpp ident) (CppVar "data")])
243+ (returnBlock $ CppDataLiteral [CppAccessor (CppVar $ identToCpp ident) (CppVar "data")])
232 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) fields) =
244 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) fields) =
233 return . CppNamespace "" $
245 return . CppNamespace "" $
234 [ CppFunction
246 [ CppFunction
236− (farg <$> fields')
248+ (farg <$> fields')
237− (Just $ Any [])
249+ (Just $ Any [])
238− [Inline]
250+ [Inline]
239− (returnBlock $
251+ (returnBlock $
241− CppAccessor (CppVar name) (CppVar "data") : (CppVar <$> fields'))
252+ CppDataLiteral $ CppAccessor (CppVar name) (CppVar "data") : (CppVar <$> fields'))
243 if length fields > 0
254 if length fields > 0
245− [ CppFunction
255+ then [ CppFunction
246− (curriedName name)
256+ (curriedName name)
247− (farg <$> f)
257+ (farg <$> f)
248− (Just $ Any [])
258+ (Just $ Any [])
249− (if length fields == 1 then [Inline] else [])
259+ (if length fields == 1
250− (CppBlock (fieldLambdas fs))
262+ (CppBlock (fieldLambdas fs))
255 name = identToCpp ident
266 name = identToCpp ident
256 fields' = identToCpp <$> fields
267 fields' = identToCpp <$> fields
257− (f, fs) | (f' : fs') <- fields' = ([f'], fs')
269+ | (f':fs') <- fields' = ([f'], fs')
258− | otherwise = ([], [])
270+ | otherwise = ([], [])
259 farg = \x -> (x, Just $ Any [Const, Ref])
271 farg = \x -> (x, Just $ Any [Const, Ref])
260 fieldLambdas flds
272 fieldLambdas flds
273+ | (f':fs') <- flds =
261− | (f' : fs') <- flds = [ CppReturn . maybeRemCaps $
274+ [ CppReturn . maybeRemCaps $
266− (CppBlock $ fieldLambdas fs') ]
275+ CppLambda [CaptureAll] (farg <$> [f']) (Just $ Any []) (CppBlock $ fieldLambdas fs')
267 | otherwise = [CppReturn $ CppApp (CppVar name) (CppVar <$> fields')]
277 | otherwise = [CppReturn $ CppApp (CppVar name) (CppVar <$> fields')]
269 declToCpp qs (_, ident) e
278 declToCpp qs (_, ident) e
270− | Just ty <- exprType e,
279+ | Just ty <- exprType e
271− TopLevel `elem` qs,
280+ , TopLevel `elem` qs
272− arity' <- arity ty,
281+ , arity' <- arity ty
273− arity' > 0 = do
282+ , arity' > 0 = do
274− argNames <- replicateM arity' freshName
283+ argNames <- replicateM arity' freshName
275− body' <- valueToCpp $
285+ valueToCpp $
276− curriedApp
286+ curriedApp
277− (tail argNames)
287+ (tail argNames)
278− (App nullAnn e (Var nullAnn . Qualified Nothing . Ident $ head argNames))
288+ (App nullAnn e (Var nullAnn . Qualified Nothing . Ident $ head argNames))
279− let fn' = CppFunction
290+ CppFunction
280− (curriedName name)
291+ (curriedName name)
281− [(head argNames, Just $ Any [Const, Ref])]
292+ [(head argNames, Just $ Any [Const, Ref])]
284− (returnBlock $
295+ (returnBlock $
287− (CppApp (CppVar name)
296+ curriedLambda (tail argNames) (CppApp (CppVar name) (CppVar <$> argNames)))
288− (CppVar <$> argNames)))
297+ return $
289− return $ CppNamespace "" $
298+ CppNamespace "" $
292− (zip argNames $ repeat aty)
299+ [CppFunction name (zip argNames $ repeat aty) rty [] (returnBlock body')] ++
296− ] ++ if arity' > 0
300+ if arity' > 0
297− then [fn']
301+ then [fn']
300 name = identToCpp ident
304 name = identToCpp ident
301 aty = Just $ Any [Const, Ref]
305 aty = Just $ Any [Const, Ref]
302 rty = Just $ Any []
306 rty = Just $ Any []
304 declToCpp qs (_, ident) val = do
307 declToCpp qs (_, ident) val = do
305 val' <- valueToCpp val
308 val' <- valueToCpp val
307− CppVariableIntroduction
308− (identToCpp ident, Just $ Any [Const])
309+ return $ CppVariableIntroduction (identToCpp ident, Just $ Any [Const]) qs (Just val')
312 -------------------------------------------------------------------------------------------------
310 -------------------------------------------------------------------------------------------------
313 exprType :: Expr Ann -> Maybe T.Type
311 exprType :: Expr Ann -> Maybe T.Type
314 -------------------------------------------------------------------------------------------------
312 -------------------------------------------------------------------------------------------------
@@ -317,21 +315,20 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
317 exprType (Case (_, _, Just ty, _) _ _) = Just ty
315 exprType (Case (_, _, Just ty, _) _ _) = Just ty
318 exprType (Let (_, _, Just ty, _) _ _) = Just ty
316 exprType (Let (_, _, Just ty, _) _ _) = Just ty
319 exprType _ = Nothing
317 exprType _ = Nothing
321 -------------------------------------------------------------------------------------------------
318 -------------------------------------------------------------------------------------------------
322 fnToLambda :: Cpp -> Cpp
319 fnToLambda :: Cpp -> Cpp
323 -------------------------------------------------------------------------------------------------
320 -------------------------------------------------------------------------------------------------
324 fnToLambda (CppFunction name args _ qs body) =
321 fnToLambda (CppFunction name args _ qs body) =
325 CppVariableIntroduction
322 CppVariableIntroduction
326− (name, Just $ Any [Const])
323+ (name, Just $ Any [Const])
327− (filter (==Static) qs)
324+ (filter (== Static) qs)
328− (Just $ CppLambda cs args (Just $ Any []) body)
325+ (Just $ CppLambda cs args (Just $ Any []) body)
330− cs | (not . null) (qs `intersect` [Inline, Static]) = []
328+ | (not . null) (qs `intersect` [Inline, Static]) = []
331− | otherwise = [CaptureAll]
329+ | otherwise = [CaptureAll]
332 fnToLambda (CppComment com cpp) = CppComment com (fnToLambda cpp)
330 fnToLambda (CppComment com cpp) = CppComment com (fnToLambda cpp)
333 fnToLambda _ = error "Not a function!"
331 fnToLambda _ = error "Not a function!"
335 -------------------------------------------------------------------------------------------------
332 -------------------------------------------------------------------------------------------------
336 innerLambdas :: Cpp -> Cpp
333 innerLambdas :: Cpp -> Cpp
337 -------------------------------------------------------------------------------------------------
334 -------------------------------------------------------------------------------------------------
@@ -341,7 +338,6 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
341 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f
338 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f
342 go (CppLambda _ args rtyp body) = maybeRemCaps $ CppLambda [CaptureAll] args rtyp body
339 go (CppLambda _ args rtyp body) = maybeRemCaps $ CppLambda [CaptureAll] args rtyp body
343 go cpp = cpp
340 go cpp = cpp
345 -------------------------------------------------------------------------------------------------
341 -------------------------------------------------------------------------------------------------
346 convertRecursiveFns :: [Cpp] -> Cpp -> [Cpp]
342 convertRecursiveFns :: [Cpp] -> Cpp -> [Cpp]
347 -------------------------------------------------------------------------------------------------
343 -------------------------------------------------------------------------------------------------
@@ -350,82 +346,74 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
351 cpps' = everywhereOnCpp removeRec <$> cpps
347 cpps' = everywhereOnCpp removeRec <$> cpps
352 allCpps = CppBlock $ otherCpp : cpps'
348 allCpps = CppBlock $ otherCpp : cpps'
354 fns :: [(String, Cpp)]
349 fns :: [(String, Cpp)]
355 fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps
350 fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps
357 filteredFns :: Cpp -> [(String, Cpp)]
351 filteredFns :: Cpp -> [(String, Cpp)]
358− filteredFns cpp = filter (\(f,_) -> everythingOnCpp (||) (== CppVar f) cpp) fns
352+ filteredFns cpp = filter (\(f, _) -> everythingOnCpp (||) (== CppVar f) cpp) fns
360 recursive :: Cpp -> [Cpp]
353 recursive :: Cpp -> [Cpp]
361− recursive cpp'@(CppFunction _ _ _ qs _) | Recursive `elem` qs = [cpp']
354+ recursive cpp'@(CppFunction _ _ _ qs _)
355+ | Recursive `elem` qs = [cpp']
362− recursive cpp'@(CppVariableIntroduction _ qs _) | Recursive `elem` qs = [cpp']
356+ recursive cpp'@(CppVariableIntroduction _ qs _)
357+ | Recursive `elem` qs = [cpp']
363 recursive _ = []
358 recursive _ = []
365 removeRec :: Cpp -> Cpp
359 removeRec :: Cpp -> Cpp
366− removeRec (CppFunction _ _ _ qs _) | Recursive `elem` qs = CppNoOp
360+ removeRec (CppFunction _ _ _ qs _)
361+ | Recursive `elem` qs = CppNoOp
367− removeRec (CppVariableIntroduction _ qs _) | Recursive `elem` qs = CppNoOp
362+ removeRec (CppVariableIntroduction _ qs _)
363+ | Recursive `elem` qs = CppNoOp
368 removeRec cpp' = cpp'
364 removeRec cpp' = cpp'
370 replaceVar :: [(String, Cpp)] -> Cpp -> Cpp
365 replaceVar :: [(String, Cpp)] -> Cpp -> Cpp
371 replaceVar rs = go
366 replaceVar rs = go
373− go (CppVar var) | Just var' <- lookup var rs = var'
369+ | Just var' <- lookup var rs = var'
374 go cpp' = cpp'
370 go cpp' = cpp'
376 dict :: Cpp
371 dict :: Cpp
377− dict = CppVariableIntroduction
373+ CppVariableIntroduction
378− (topdict, Just $ Any [Const])
374+ (topdict, Just $ Any [Const])
380− (Just $ CppDataLiteral ((\(f,cpp) -> CppComment [LineComment f] cpp) <$> fns))
376+ (Just $ CppDataLiteral ((\(f, cpp) -> CppComment [LineComment f] cpp) <$> fns))
382 accessed :: String -> String -> (String, Cpp)
377 accessed :: String -> String -> (String, Cpp)
383 accessed dictname name =
378 accessed dictname name =
384− (name, CppApp
380+ , CppApp
385− (CppIndexer
381+ (CppIndexer
386− (CppNumericLiteral .
389− fromJust $ findIndex ((== name) . fst) fns)
382+ (CppNumericLiteral . Left . fromIntegral . fromJust $ findIndex ((== name) . fst) fns)
391− [dict'])
384+ [dict'])
393 dict' = CppVar dictname
386 dict' = CppVar dictname
394 dict'' = CppCast (dataType 1) dict'
387 dict'' = CppCast (dataType 1) dict'
396 accessor :: String -> (String, Cpp) -> Cpp
388 accessor :: String -> (String, Cpp) -> Cpp
397 accessor dictname (name, _) =
389 accessor dictname (name, _) =
398− CppVariableIntroduction
399− (name, Just $ Any [Const])
401− (Just . snd $ accessed dictname name)
390+ CppVariableIntroduction (name, Just $ Any [Const]) [] (Just . snd $ accessed dictname name)
403 toelem :: Cpp -> (String, Cpp)
391 toelem :: Cpp -> (String, Cpp)
404 toelem (CppFunction name args rtyp _ body'@(CppBlock body)) =
392 toelem (CppFunction name args rtyp _ body'@(CppBlock body)) =
405− (name, withdict . maybeRemCaps $ CppLambda
394+ , withdict . maybeRemCaps $
406− [CaptureAll]
396+ [CaptureAll]
409− (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))
399+ (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))
411 toelem (CppVariableIntroduction (name, _) _ (Just body')) =
400 toelem (CppVariableIntroduction (name, _) _ (Just body')) =
412 let replacements = accessed localdict . fst <$> filteredFns body'
401 let replacements = accessed localdict . fst <$> filteredFns body'
413 replaced = everywhereOnCpp (replaceVar replacements) body'
402 replaced = everywhereOnCpp (replaceVar replacements) body'
414 in (name, withdict . maybeRemCaps $ CppBlock [CppReturn replaced])
403 in (name, withdict . maybeRemCaps $ CppBlock [CppReturn replaced])
416 toelem _ = error "not a function"
404 toelem _ = error "not a function"
418 withdict :: Cpp -> Cpp
405 withdict :: Cpp -> Cpp
419− withdict cpp' = maybeRemCaps $ CppLambda
407+ maybeRemCaps $
420− [CaptureAll]
409+ [CaptureAll]
421− [(localdict, Just $ Any [Const, Ref])]
410+ [(localdict, Just $ Any [Const, Ref])]
422− (Just $ Any [])
411+ (Just $ Any [])
423− (returnBlock cpp')
412+ (returnBlock cpp')
424 topdict :: String
413 topdict :: String
425 topdict = "_$dict$_"
414 topdict = "_$dict$_"
426 localdict :: String
415 localdict :: String
427 localdict = "$dict$"
416 localdict = "$dict$"
429 convertRecursiveFns cpps _ = cpps
417 convertRecursiveFns cpps _ = cpps
@@ -434,126 +422,98 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
434 -------------------------------------------------------------------------------------------------
422 -------------------------------------------------------------------------------------------------
435 valueToCpp :: Expr Ann -> m Cpp
423 valueToCpp :: Expr Ann -> m Cpp
436 -------------------------------------------------------------------------------------------------
424 -------------------------------------------------------------------------------------------------
437− valueToCpp (Var (_, _, _, Just IsNewtype) ident) =
425+ valueToCpp (Var (_, _, _, Just IsNewtype) ident) = return $ varToCpp ident
438− return $ varToCpp ident
440− valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) =
426+ valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) = return $ CppApp (varToCpp ident) []
441− return $ CppApp (varToCpp ident) []
443 valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))
427 valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))
445− return . curriedName' $ varToCpp ident
428+ | arity ty > 0 = return . curriedName' $ varToCpp ident
447− valueToCpp (Var _ ident) =
429+ valueToCpp (Var _ ident) = return $ varToCpp ident
448− return $ varToCpp ident
450− valueToCpp (Literal _ (NumericLiteral n)) =
430+ valueToCpp (Literal _ (NumericLiteral n)) = return (CppNumericLiteral n)
451− return (CppNumericLiteral n)
453− valueToCpp (Literal _ (StringLiteral s)) =
431+ valueToCpp (Literal _ (StringLiteral s)) = return (CppStringLiteral s)
454− return (CppStringLiteral s)
456− valueToCpp (Literal _ (CharLiteral c)) =
432+ valueToCpp (Literal _ (CharLiteral c)) = return (CppCharLiteral c)
457− return (CppCharLiteral c)
459− valueToCpp (Literal _ (BooleanLiteral b)) =
433+ valueToCpp (Literal _ (BooleanLiteral b)) = return (CppBooleanLiteral b)
460− return (CppBooleanLiteral b)
462− valueToCpp (Literal _ (ArrayLiteral xs)) =
434+ valueToCpp (Literal _ (ArrayLiteral xs)) = CppArrayLiteral <$> mapM valueToCpp xs
463− CppArrayLiteral <$> mapM valueToCpp xs
465 valueToCpp (Literal _ (ObjectLiteral ps)) =
435 valueToCpp (Literal _ (ObjectLiteral ps)) =
466 CppMapLiteral Record <$>
436 CppMapLiteral Record <$>
467− mapM (sndM valueToCpp) ((\(k,v) -> (CppSymbol k, v)) <$> sortBy (compare `on` fst) ps)
437+ mapM (sndM valueToCpp) ((\(k, v) -> (CppSymbol k, v)) <$> sortBy (compare `on` fst) ps)
469− valueToCpp (Accessor _ prop val) =
470− CppIndexer <$> pure (CppSymbol prop) <*> valueToCpp val
438+ valueToCpp (Accessor _ prop val) = CppIndexer <$> pure (CppSymbol prop) <*> valueToCpp val
472 -- TODO: use a more efficient way of copying/updating the map?
439 -- TODO: use a more efficient way of copying/updating the map?
473 valueToCpp (ObjectUpdate (_, _, Just ty, _) obj ps) = do
440 valueToCpp (ObjectUpdate (_, _, Just ty, _) obj ps) = do
474 obj' <- valueToCpp obj
441 obj' <- valueToCpp obj
475 updatedFields <- mapM (sndM valueToCpp) ps
442 updatedFields <- mapM (sndM valueToCpp) ps
476 let origKeys = (allKeys ty) \\ (fst <$> updatedFields)
443 let origKeys = (allKeys ty) \\ (fst <$> updatedFields)
477 origFields = (\key -> (key, CppIndexer (CppSymbol key) obj')) <$> origKeys
444 origFields = (\key -> (key, CppIndexer (CppSymbol key) obj')) <$> origKeys
478− return $ CppMapLiteral Record $
446+ CppMapLiteral Record $
479− (\(k,v) -> (CppSymbol k, v)) <$> sortBy (compare `on` fst) (origFields ++ updatedFields)
447+ (\(k, v) -> (CppSymbol k, v)) <$> sortBy (compare `on` fst) (origFields ++ updatedFields)
481 allKeys :: T.Type -> [String]
449 allKeys :: T.Type -> [String]
482 allKeys (T.TypeApp (T.TypeConstructor _) r@(T.RCons {})) = fst <$> (fst $ T.rowToList r)
450 allKeys (T.TypeApp (T.TypeConstructor _) r@(T.RCons {})) = fst <$> (fst $ T.rowToList r)
483 allKeys (T.ForAll _ t _) = allKeys t
451 allKeys (T.ForAll _ t _) = allKeys t
484 allKeys _ = error $ show "Not a recognized row type"
452 allKeys _ = error $ show "Not a recognized row type"
486 valueToCpp (ObjectUpdate _ _ _) = error $ "Bad Type in object update!"
453 valueToCpp (ObjectUpdate _ _ _) = error $ "Bad Type in object update!"
488 valueToCpp (Abs (_, _, ty, _) arg body) = do
454 valueToCpp (Abs (_, _, ty, _) arg body) = do
489 cpp <- valueToCpp body
455 cpp <- valueToCpp body
490 let cpp' = innerLambdas cpp
456 let cpp' = innerLambdas cpp
492 CppLambda
458 CppLambda
494− [(identToCpp arg, Just $ Any [Const, Ref])]
460+ [(identToCpp arg, Just $ Any [Const, Ref])]
495− (Just $ Any [])
461+ (Just $ Any [])
496− (returnBlock $ optIndexers classes cpp')
462+ (returnBlock $ optIndexers classes cpp')
498− arg' = identToCpp arg
464+ arg' = identToCpp arg
499− args' = identToCpp <$> (fst $ unAbs body [])
465+ args' = identToCpp <$> (fst $ unAbs body [])
500− classes = zip (CppVar <$> arg' : args')
468+ (CppVar <$> arg' : args')
501− (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$> maybe [] extractConstraints ty)
469+ (qualifiedToCpp (Ident . runProperName) . T.constraintClass <$>
502−
470+ maybe [] extractConstraints ty)
503− valueToCpp e@App{} = do
471+ valueToCpp e@App {} = do
504 let (f, args) = unApp e []
472 let (f, args) = unApp e []
505 args' <- mapM valueToCpp args
473 args' <- mapM valueToCpp args
506 case f of
474 case f of
507 Var (_, _, _, Just IsNewtype) _ -> return (head args')
475 Var (_, _, _, Just IsNewtype) _ -> return (head args')
508 Var (_, _, _, Just IsTypeClassConstructor) (Qualified mn' (Ident classname)) ->
476 Var (_, _, _, Just IsTypeClassConstructor) (Qualified mn' (Ident classname)) ->
509− let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname)) in
477+ let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname))
510− return . CppMapLiteral Instance $
478+ in return . CppMapLiteral Instance $
512− (CppSymbol <$> (sort $ superClassDictionaryNames constraints) ++ (fst <$> fns))
479+ zip (CppSymbol <$> (sort $ superClassDictionaryNames constraints) ++ (fst <$> fns)) args'
514 Var _ (Qualified (Just _) _) -> applied f args' curriedName'
480 Var _ (Qualified (Just _) _) -> applied f args' curriedName'
515 _ -> applied f args' id
481 _ -> applied f args' id
517 applied f args g = flip (foldl (\fn a -> CppApp (g fn) [a])) args <$> valueToCpp f
483 applied f args g = flip (foldl (\fn a -> CppApp (g fn) [a])) args <$> valueToCpp f
519 valueToCpp (Case (maybeSpan, _, ty, _) values binders) = do
484 valueToCpp (Case (maybeSpan, _, ty, _) values binders) = do
520 vals <- mapM valueToCpp values
485 vals <- mapM valueToCpp values
521 bindersToCpp maybeSpan ty binders vals
486 bindersToCpp maybeSpan ty binders vals
523 valueToCpp (Let _ ds val) = do
487 valueToCpp (Let _ ds val) = do
524 ds' <- concat <$> mapM (bindToCpp []) ds
488 ds' <- concat <$> mapM (bindToCpp []) ds
525 ret <- valueToCpp val
489 ret <- valueToCpp val
526 opts <- ask
490 opts <- ask
527 let ds'' = tco opts <$> ds'
491 let ds'' = tco opts <$> ds'
528− let rs = if hasRecursion ds''
493+ if hasRecursion ds''
529− then convertRecursiveFns ds'' ret
494+ then convertRecursiveFns ds'' ret
530− else ds''
495+ else ds''
531 let cpps = innerLambdas <$> rs
496 let cpps = innerLambdas <$> rs
533− (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret])))
497+ return $ CppApp (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret]))) []
536 hasRecursion :: [Cpp] -> Bool
499 hasRecursion :: [Cpp] -> Bool
537 hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'
500 hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'
539 valnames :: [String]
502 valnames :: [String]
540− valnames = concatMap (everythingOnCpp (++) valname) cpps'
503+ valnames = concatMap (everythingOnCpp (++) valname) cpps'
542 valname :: Cpp -> [String]
504 valname :: Cpp -> [String]
543 valname (CppFunction name _ _ _ _) = [name]
505 valname (CppFunction name _ _ _ _) = [name]
544 valname (CppVariableIntroduction (name, _) _ _) = [name]
506 valname (CppVariableIntroduction (name, _) _ _) = [name]
545 valname _ = []
507 valname _ = []
547 hasRecursiveRef :: Cpp -> Bool
508 hasRecursiveRef :: Cpp -> Bool
548 hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body
509 hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body
549 hasRecursiveRef (CppVariableIntroduction _ _ (Just value)) = everythingOnCpp (||) ref value
510 hasRecursiveRef (CppVariableIntroduction _ _ (Just value)) = everythingOnCpp (||) ref value
550 hasRecursiveRef _ = False
511 hasRecursiveRef _ = False
552 ref :: Cpp -> Bool
512 ref :: Cpp -> Bool
553− ref (CppVar name) | name `elem` valnames = True
514+ | name `elem` valnames = True
554 ref _ = False
515 ref _ = False
556− valueToCpp Constructor{} = return CppNoOp
516+ valueToCpp Constructor {} = return CppNoOp
559 -- Generate code in the simplified C++1x intermediate representation for a reference to a
519 -- 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
575 bindersToCpp maybeSpan _ binders vals = do
535 bindersToCpp maybeSpan _ binders vals = do
576 valNames <- replicateM (length vals) freshName
536 valNames <- replicateM (length vals) freshName
577 let assignments = zipWith mkVarDecl valNames (map Just vals)
537 let assignments = zipWith mkVarDecl valNames (map Just vals)
578− cpps <- forM binders $ \(CaseAlternative bs result) -> do
539+ forM binders $ \(CaseAlternative bs result) -> do
579− ret <- guardsToCpp result
540+ ret <- guardsToCpp result
580− go valNames ret bs
541+ go valNames ret bs
583 (CppLambda
544 (CppLambda
586− (Just $ Any [])
547+ (Just $ Any [])
587− (CppBlock (assignments ++ concat cpps ++ [failedPatternError valNames])))
548+ (CppBlock (assignments ++ concat cpps ++ [failedPatternError valNames])))
590− mkVarDecl :: String -> Maybe Cpp -> Cpp
551+ mkVarDecl :: String -> Maybe Cpp -> Cpp
591− mkVarDecl name = CppVariableIntroduction (name, Nothing) []
552+ mkVarDecl name = CppVariableIntroduction (name, Nothing) []
592− go :: [String] -> [Cpp] -> [Binder Ann] -> m [Cpp]
553+ go :: [String] -> [Cpp] -> [Binder Ann] -> m [Cpp]
593− go _ done [] = return done
554+ go _ done [] = return done
594− go (v:vs) done' (b:bs) = do
555+ go (v:vs) done' (b:bs) = do
595− done'' <- go vs done' bs
556+ done'' <- go vs done' bs
596− binderToCpp v done'' b
557+ binderToCpp v done'' b
597− go _ _ _ = error "Invalid arguments to bindersToCpp"
558+ go _ _ _ = error "Invalid arguments to bindersToCpp"
599− failedPatternError :: [String] -> Cpp
559+ failedPatternError :: [String] -> Cpp
600− failedPatternError _ =
560+ failedPatternError _ =
601− CppThrow $ CppApp (CppVar "runtime_error") [CppStringLiteral errorMessage]
561+ CppThrow $ CppApp (CppVar "runtime_error") [CppStringLiteral errorMessage]
603− errorMessage :: String
562+ errorMessage :: String
604− errorMessage = "Failed pattern match" ++
564+ "Failed pattern match" ++
605− maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++
565+ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
608− guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [Cpp]
566+ guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [Cpp]
609− guardsToCpp (Left gs) = forM gs $ \(cond, val) -> do
567+ guardsToCpp (Left gs) =
568+ forM gs $ \(cond, val) -> do
610 cond' <- valueToCpp cond
569 cond' <- valueToCpp cond
611− done <- valueToCpp val
570+ done <- valueToCpp val
612 return $ CppIfElse cond' (returnBlock done) Nothing
571 return $ CppIfElse cond' (returnBlock done) Nothing
613− guardsToCpp (Right v) = return . CppReturn <$> valueToCpp v
572+ guardsToCpp (Right v) = return . CppReturn <$> valueToCpp v
616 -- Generate code in the simplified C++1x intermediate representation for a pattern match
575 -- 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
619 -------------------------------------------------------------------------------------------------
578 -------------------------------------------------------------------------------------------------
620 binderToCpp :: String -> [Cpp] -> Binder Ann -> m [Cpp]
579 binderToCpp :: String -> [Cpp] -> Binder Ann -> m [Cpp]
621 -------------------------------------------------------------------------------------------------
580 -------------------------------------------------------------------------------------------------
622− binderToCpp _ done (NullBinder{}) = return done
581+ binderToCpp _ done (NullBinder {}) = return done
624− binderToCpp varName done (LiteralBinder _ l) =
582+ binderToCpp varName done (LiteralBinder _ l) = literalToBinderCpp varName done l
625− literalToBinderCpp varName done l
627 binderToCpp varName done (VarBinder _ ident) =
583 binderToCpp varName done (VarBinder _ ident) =
629− CppVariableIntroduction
630− (identToCpp ident, Just $ Any [Const])
585+ CppVariableIntroduction (identToCpp ident, Just $ Any [Const]) [] (Just $ CppVar varName) : done
632− (Just $ CppVar varName)
635 binderToCpp varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
586 binderToCpp varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
636 binderToCpp varName done b
587 binderToCpp varName done b
638− binderToCpp varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields))
588+ binderToCpp varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified mn' (ProperName ctor)) bs) = do
640− (Qualified mn' (ProperName ctor))
642 cpps <- go (zip fields bs) done
589 cpps <- go (zip fields bs) done
644 case ctorType of
591 case ctorType of
645 ProductType -> cpps
592 ProductType -> cpps
646 SumType ->
593 SumType ->
647− [ CppIfElse
594+ [ CppIfElse
648− (CppBinary
595+ (CppBinary
652− (CppCast (dataType 1) $ CppVar varName))
597+ (CppIndexer (CppVar ctorKey) (CppCast (dataType 1) $ CppVar varName))
653− ctorCpp)
598+ ctorCpp)
654− (CppBlock cpps)
599+ (CppBlock cpps)
655− Nothing]
600+ Nothing
657 go :: [(Ident, Binder Ann)] -> [Cpp] -> m [Cpp]
603 go :: [(Ident, Binder Ann)] -> [Cpp] -> m [Cpp]
658 go [] done' = return done'
604 go [] done' = return done'
659− go ((field, binder) : remain) done' = do
605+ go ((field, binder):remain) done' = do
660 argVar <- freshName
606 argVar <- freshName
661 done'' <- go remain done'
607 done'' <- go remain done'
662 cpps <- binderToCpp argVar done'' binder
608 cpps <- binderToCpp argVar done'' binder
664 CppVariableIntroduction
610 CppVariableIntroduction
665− (argVar, Nothing)
611+ (argVar, Nothing)
667− (Just $ CppIndexer
614+ CppIndexer
668− (fieldToIndex' field)
615+ (fieldToIndex' field)
669− (CppCast (dataType $ fieldToIndex field + 1) $ CppVar varName))
616+ (CppCast (dataType $ fieldToIndex field + 1) $ CppVar varName)) :
671 fieldToIndex :: Ident -> Int
618 fieldToIndex :: Ident -> Int
672− fieldToIndex = (+1) . read . dropWhile isLetter . runIdent
619+ fieldToIndex = (+ 1) . read . dropWhile isLetter . runIdent
673 fieldToIndex' :: Ident -> Cpp
620 fieldToIndex' :: Ident -> Cpp
674 fieldToIndex' = CppNumericLiteral . Left . toInteger . fieldToIndex
621 fieldToIndex' = CppNumericLiteral . Left . toInteger . fieldToIndex
675 ctor' :: Cpp
622 ctor' :: Cpp
676 ctor' = CppAccessor (CppVar . identToCpp $ Ident ctor) (CppVar "data")
623 ctor' = CppAccessor (CppVar . identToCpp $ Ident ctor) (CppVar "data")
677 ctorCpp :: Cpp
624 ctorCpp :: Cpp
678− ctorCpp | Just mn'' <- mn', mn'' /= mn = CppAccessor ctor' (CppVar $ moduleNameToCpp mn'')
627+ , mn'' /= mn = CppAccessor ctor' (CppVar $ moduleNameToCpp mn'')
679− | otherwise = ctor'
628+ | otherwise = ctor'
681− binderToCpp _ _ b@(ConstructorBinder{}) =
629+ binderToCpp _ _ b@(ConstructorBinder {}) =
682 error $ "Invalid ConstructorBinder in binderToCpp: " ++ show b
630 error $ "Invalid ConstructorBinder in binderToCpp: " ++ show b
684 binderToCpp varName done (NamedBinder _ ident binder) = do
631 binderToCpp varName done (NamedBinder _ ident binder) = do
685 cpp <- binderToCpp varName done binder
632 cpp <- binderToCpp varName done binder
687− CppVariableIntroduction
688− (identToCpp ident, Just $ Any [Const])
634+ CppVariableIntroduction (identToCpp ident, Just $ Any [Const]) [] (Just $ CppVar varName) :
690− (Just $ CppVar varName)
693 -------------------------------------------------------------------------------------------------
636 -------------------------------------------------------------------------------------------------
694 literalToBinderCpp :: String -> [Cpp] -> Literal (Binder Ann) -> m [Cpp]
637 literalToBinderCpp :: String -> [Cpp] -> Literal (Binder Ann) -> m [Cpp]
695 -------------------------------------------------------------------------------------------------
638 -------------------------------------------------------------------------------------------------
696 literalToBinderCpp varName done (NumericLiteral num) =
639 literalToBinderCpp varName done (NumericLiteral num) =
697− return [ CppIfElse
641+ [ CppIfElse
698− (CppBinary EqualTo (CppVar varName) (CppNumericLiteral num))
642+ (CppBinary EqualTo (CppVar varName) (CppNumericLiteral num))
699− (CppBlock done)
643+ (CppBlock done)
700− Nothing ]
644+ Nothing
702 literalToBinderCpp varName done (CharLiteral c) =
646 literalToBinderCpp varName done (CharLiteral c) =
703− return [ CppIfElse
647+ return
704− (CppBinary EqualTo (CppVar varName) (CppCharLiteral c))
648+ [CppIfElse (CppBinary EqualTo (CppVar varName) (CppCharLiteral c)) (CppBlock done) Nothing]
708 literalToBinderCpp varName done (StringLiteral str) =
649 literalToBinderCpp varName done (StringLiteral str) =
709− return [ CppIfElse
651+ [ CppIfElse
710− (CppBinary EqualTo (CppVar varName) (CppStringLiteral str))
652+ (CppBinary EqualTo (CppVar varName) (CppStringLiteral str))
711− (CppBlock done)
653+ (CppBlock done)
712− Nothing ]
654+ Nothing
714 literalToBinderCpp varName done (BooleanLiteral True) =
656 literalToBinderCpp varName done (BooleanLiteral True) =
715− return [ CppIfElse
657+ return [CppIfElse (CppVar varName) (CppBlock done) Nothing]
720 literalToBinderCpp varName done (BooleanLiteral False) =
658 literalToBinderCpp varName done (BooleanLiteral False) =
721− return [ CppIfElse
659+ return [CppIfElse (CppUnary Not (CppVar varName)) (CppBlock done) Nothing]
728 literalToBinderCpp varName done (ObjectLiteral bs) = go done bs
660 literalToBinderCpp varName done (ObjectLiteral bs) = go done bs
730 go :: [Cpp] -> [(String, Binder Ann)] -> m [Cpp]
662 go :: [Cpp] -> [(String, Binder Ann)] -> m [Cpp]
@@ -735,27 +667,22 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
735 cpp <- binderToCpp propVar done'' binder
667 cpp <- binderToCpp propVar done'' binder
737 CppVariableIntroduction
669 CppVariableIntroduction
738− (propVar, Nothing)
670+ (propVar, Nothing)
740− (Just $ CppIndexer
672+ (Just $ CppIndexer (CppSymbol prop) (CppVar varName)) :
745 literalToBinderCpp varName done (ArrayLiteral bs) = do
674 literalToBinderCpp varName done (ArrayLiteral bs) = do
746 cpp <- go done 0 bs
675 cpp <- go done 0 bs
747 let cond =
676 let cond =
748 case length bs of
677 case length bs of
751− (CppCast arrayType $ CppVar varName)
678+ 0 -> CppBinary Dot (CppCast arrayType $ CppVar varName) (CppApp (CppVar "empty") [])
752− (CppApp (CppVar "empty") [])
679+ n ->
753− n -> let var = CppCast arrayType $ CppVar varName
680+ let var = CppCast arrayType $ CppVar varName
754− in CppBinary
681+ in CppBinary
756− (CppBinary Dot var (CppApp (CppVar "size") []))
683+ (CppBinary Dot var (CppApp (CppVar "size") []))
757− (CppNumericLiteral (Left (fromIntegral n)))
684+ (CppNumericLiteral (Left (fromIntegral n)))
758− return [ CppIfElse cond (CppBlock cpp) Nothing ]
685+ return [CppIfElse cond (CppBlock cpp) Nothing]
760 go :: [Cpp] -> Integer -> [Binder Ann] -> m [Cpp]
687 go :: [Cpp] -> Integer -> [Binder Ann] -> m [Cpp]
761 go done' _ [] = return done'
688 go done' _ [] = return done'
@@ -765,25 +692,20 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
765 cpp <- binderToCpp elVar done'' binder
692 cpp <- binderToCpp elVar done'' binder
767 CppVariableIntroduction
694 CppVariableIntroduction
768− (elVar, Nothing)
695+ (elVar, Nothing)
771− (CppNumericLiteral (Left index))
697+ (Just $ CppIndexer (CppNumericLiteral (Left index)) (CppVar varName)) :
775 -------------------------------------------------------------------------------------------------
699 -------------------------------------------------------------------------------------------------
776 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
700 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
777 -------------------------------------------------------------------------------------------------
701 -------------------------------------------------------------------------------------------------
778 unApp (App _ val arg) args = unApp val (arg : args)
702 unApp (App _ val arg) args = unApp val (arg : args)
779 unApp other args = (other, args)
703 unApp other args = (other, args)
781 -------------------------------------------------------------------------------------------------
704 -------------------------------------------------------------------------------------------------
782 unAbs :: Expr Ann -> [Ident] -> ([Ident], Expr Ann)
705 unAbs :: Expr Ann -> [Ident] -> ([Ident], Expr Ann)
783 -------------------------------------------------------------------------------------------------
706 -------------------------------------------------------------------------------------------------
784 unAbs (Abs _ arg val) args = unAbs val (args ++ [arg])
707 unAbs (Abs _ arg val) args = unAbs val (args ++ [arg])
785 unAbs other args = (args, other)
708 unAbs other args = (args, other)
787 -------------------------------------------------------------------------------------------------
709 -------------------------------------------------------------------------------------------------
788 qualifiedToCpp :: (a -> Ident) -> Qualified a -> Cpp
710 qualifiedToCpp :: (a -> Ident) -> Qualified a -> Cpp
789 -------------------------------------------------------------------------------------------------
711 -------------------------------------------------------------------------------------------------
@@ -797,63 +719,68 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
797 -- Find a class in scope by name, retrieving its list of constraints, function names and types.
719 -- Find a class in scope by name, retrieving its list of constraints, function names and types.
799 -------------------------------------------------------------------------------------------------
721 -------------------------------------------------------------------------------------------------
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)])
801 -------------------------------------------------------------------------------------------------
724 -------------------------------------------------------------------------------------------------
802 findClass name
725 findClass name
803− | Just tcd <- M.lookup name (E.typeClasses env),
726+ | Just tcd <- M.lookup name (E.typeClasses env)
804− fns' <- (\(i,t) -> (runIdent i, t)) <$> E.typeClassMembers tcd
727+ , fns' <- (\(i, t) -> (runIdent i, t)) <$> E.typeClassMembers tcd =
805− = Just (fst <$> E.typeClassArguments tcd,
729+ ( fst <$> E.typeClassArguments tcd
806− E.typeClassSuperclasses tcd,
730+ , E.typeClassSuperclasses tcd
807− (sortBy (compare `on` normalizedName . fst) fns'))
731+ , (sortBy (compare `on` normalizedName . fst) fns'))
808 findClass _ = Nothing
732 findClass _ = Nothing
810 -------------------------------------------------------------------------------------------------
733 -------------------------------------------------------------------------------------------------
811 typeClassMembers :: [Ident]
734 typeClassMembers :: [Ident]
812 -------------------------------------------------------------------------------------------------
735 -------------------------------------------------------------------------------------------------
813− typeClassMembers = fst <$> (concat . M.elems $ M.map E.typeClassMembers (M.filterWithKey thisModule (E.typeClasses env)))
738+ (concat . M.elems $ M.map E.typeClassMembers (M.filterWithKey thisModule (E.typeClasses env)))
815 thisModule (Qualified (Just mn') _) _ = mn' == mn
740 thisModule (Qualified (Just mn') _) _ = mn' == mn
816 thisModule _ _ = False
741 thisModule _ _ = False
818 -------------------------------------------------------------------------------------------------
742 -------------------------------------------------------------------------------------------------
819 dataCtors :: [Cpp]
743 dataCtors :: [Cpp]
820 -------------------------------------------------------------------------------------------------
744 -------------------------------------------------------------------------------------------------
821− dataCtors = [CppNamespace "data"
746+ [ CppNamespace
822− [CppEnum Nothing (Just intType) . ("_" :) .
748+ [ CppEnum Nothing (Just intType) . ("_" :) . catMaybes . map modCtor . M.keys $
823− catMaybes . map modCtor . M.keys $ E.dataConstructors env]]
749+ E.dataConstructors env
825 modCtor :: Qualified (ProperName a) -> Maybe String
753 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)
827 modCtor _ = Nothing
756 modCtor _ = Nothing
829 -------------------------------------------------------------------------------------------------
757 -------------------------------------------------------------------------------------------------
830 curriedForeigns :: m [Cpp]
758 curriedForeigns :: m [Cpp]
831 -------------------------------------------------------------------------------------------------
759 -------------------------------------------------------------------------------------------------
832 curriedForeigns = concat <$> mapM go allForeigns
760 curriedForeigns = concat <$> mapM go allForeigns
834 go (ident, ty)
762 go (ident, ty)
835− | arity' <- arity ty,
763+ | arity' <- arity ty
836− arity' > 0 = do
764+ , arity' > 0 = do
837− let name = identToCpp ident
765+ let name = identToCpp ident
838− argNames <- replicateM arity' freshName
766+ argNames <- replicateM arity' freshName
839− return $
767+ return $
840− [ CppFunction
768+ [ CppFunction
841− (curriedName name)
769+ (curriedName name)
842− [(head argNames, Just $ Any [Const, Ref])]
770+ [(head argNames, Just $ Any [Const, Ref])]
843− (Just $ Any [])
771+ (Just $ Any [])
844− (if arity' == 1 then [Inline] else [])
773+ then [Inline]
845− (returnBlock $
775+ (returnBlock $
848− (CppApp (CppVar name)
776+ curriedLambda (tail argNames) (CppApp (CppVar name) (CppVar <$> argNames)))
849− (CppVar <$> argNames)))
851 go _ = return []
778 go _ = return []
853 allForeigns :: [(Ident, T.Type)]
779 allForeigns :: [(Ident, T.Type)]
854− allForeigns = map (\((Qualified _ ident), (ty, _, _)) -> (ident, ty)) .
781+ map (\((Qualified _ ident), (ty, _, _)) -> (ident, ty)) .
855− filter (\((Qualified mn' _), (_, kind, _)) -> mn' == Just mn && kind == E.External) .
782+ filter (\((Qualified mn' _), (_, kind, _)) -> mn' == Just mn && kind == E.External) . M.toList $
856− M.toList $ E.names env
783+ E.names env
858---------------------------------------------------------------------------------------------------
785---------------------------------------------------------------------------------------------------
859returnBlock :: Cpp -> Cpp
786returnBlock :: Cpp -> Cpp
@@ -863,21 +790,18 @@ returnBlock cpp = CppBlock [CppReturn cpp]
863---------------------------------------------------------------------------------------------------
790---------------------------------------------------------------------------------------------------
864curriedLambda :: [String] -> Cpp -> Cpp
791curriedLambda :: [String] -> Cpp -> Cpp
865---------------------------------------------------------------------------------------------------
792---------------------------------------------------------------------------------------------------
866−curriedLambda args ret = foldr (\arg ret' -> CppLambda
793+curriedLambda args ret =
867− [CaptureAll]
794+ foldr
868− [(arg, Just $ Any [Const, Ref])]
796+ CppLambda [CaptureAll] [(arg, Just $ Any [Const, Ref])] (Just $ Any []) (returnBlock ret'))
869− (Just $ Any [])
797+ ret
873---------------------------------------------------------------------------------------------------
800---------------------------------------------------------------------------------------------------
874curriedApp :: [String] -> Expr Ann -> Expr Ann
801curriedApp :: [String] -> Expr Ann -> Expr Ann
875---------------------------------------------------------------------------------------------------
802---------------------------------------------------------------------------------------------------
876−curriedApp args vals = foldl (\val arg -> App
803+curriedApp args vals =
879− (Var nullAnn . Qualified Nothing $ Ident arg))
804+ foldl (\val arg -> App nullAnn val (Var nullAnn . Qualified Nothing $ Ident arg)) vals args
882---------------------------------------------------------------------------------------------------
806---------------------------------------------------------------------------------------------------
883arity :: T.Type -> Int
807arity :: T.Type -> Int
@@ -885,7 +809,8 @@ arity :: T.Type -> Int
885arity = go 0
809arity = go 0
887 go arity' (T.ForAll _ t _) = go arity' t
811 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
889 go arity' (T.ConstrainedType ts t) = go (arity' + length ts) t
814 go arity' (T.ConstrainedType ts t) = go (arity' + length ts) t
890 go arity' _ = arity'
815 go arity' _ = arity'
@@ -895,29 +820,29 @@ extractConstraints :: T.Type -> [T.Constraint]
895extractConstraints = go []
820extractConstraints = go []
897 go cs (T.ForAll _ t _) = go cs t
822 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
899 go cs (T.ConstrainedType ts t) = go (cs ++ ts) t
825 go cs (T.ConstrainedType ts t) = go (cs ++ ts) t
900 go cs _ = cs
826 go cs _ = cs
902---------------------------------------------------------------------------------------------------
828---------------------------------------------------------------------------------------------------
903−optIndexers :: [(Cpp,Cpp)] -> Cpp -> Cpp
829+optIndexers :: [(Cpp, Cpp)] -> Cpp -> Cpp
904---------------------------------------------------------------------------------------------------
830---------------------------------------------------------------------------------------------------
905optIndexers classes = everywhereOnCpp dictIndexerToEnum
831optIndexers classes = everywhereOnCpp dictIndexerToEnum
907 dictIndexerToEnum :: Cpp -> Cpp
833 dictIndexerToEnum :: Cpp -> Cpp
908 dictIndexerToEnum (CppIndexer (CppSymbol prop) dict)
834 dictIndexerToEnum (CppIndexer (CppSymbol prop) dict)
909 | Just cls <- lookup dict classes =
835 | Just cls <- lookup dict classes =
910− CppBinary Dot
836+ CppBinary
912− (CppAccessor (CppVar . identToCpp $ Ident prop) cls)
838+ (CppIndexer (CppAccessor (CppVar . identToCpp $ Ident prop) cls) (CppCast (mapType 0) dict))
913− (CppCast (mapType 0) dict))
914 (CppVar "second")
839 (CppVar "second")
915 dictIndexerToEnum cpp = cpp
840 dictIndexerToEnum cpp = cpp
917---------------------------------------------------------------------------------------------------
842---------------------------------------------------------------------------------------------------
918curriedName :: String -> String
843curriedName :: String -> String
919---------------------------------------------------------------------------------------------------
844---------------------------------------------------------------------------------------------------
920−curriedName name@('$' : _) = name
845+curriedName name@('$':_) = name
921curriedName name = '$' : name
846curriedName name = '$' : name
923---------------------------------------------------------------------------------------------------
848---------------------------------------------------------------------------------------------------
@@ -932,14 +857,20 @@ primFn :: T.Type -> ([CppType], Maybe CppType)
932---------------------------------------------------------------------------------------------------
857---------------------------------------------------------------------------------------------------
933primFn = go []
858primFn = go []
935− go ps (T.TypeApp (T.TypeApp fn a) b) | fn == E.tyFunction,
860+ go ps (T.TypeApp (T.TypeApp fn a) b)
861+ | fn == E.tyFunction
936− Just a' <- numType a = go (ps ++ [a']) b
862+ , Just a' <- numType a = go (ps ++ [a']) b
937− go ps t | Just t' <- numType t = (ps , Just t')
864+ | Just t' <- numType t = (ps, Just t')
938 go _ _ = ([], Nothing)
865 go _ _ = ([], Nothing)
939− numType t@(T.TypeConstructor {}) | t == E.tyInt = Just intType
866+ numType t@(T.TypeConstructor {})
867+ | t == E.tyInt = Just intType
940− numType t@(T.TypeConstructor {}) | t == E.tyNumber = Just doubleType
868+ numType t@(T.TypeConstructor {})
869+ | t == E.tyNumber = Just doubleType
941− numType t@(T.TypeConstructor {}) | t == E.tyBoolean = Just boolType
870+ numType t@(T.TypeConstructor {})
871+ | t == E.tyBoolean = Just boolType
942− numType t@(T.TypeConstructor {}) | t == E.tyChar = Just charType
872+ numType t@(T.TypeConstructor {})
873+ | t == E.tyChar = Just charType
943 numType _ = Nothing
874 numType _ = Nothing
945---------------------------------------------------------------------------------------------------
876---------------------------------------------------------------------------------------------------
@@ -978,11 +909,11 @@ filterInlineFuncs = everywhereOnCpp convert
978 convert :: Cpp -> Cpp
909 convert :: Cpp -> Cpp
979 convert (CppBlock []) = CppBlock []
910 convert (CppBlock []) = CppBlock []
980 convert (CppFunction n ps r qs cpp)
911 convert (CppFunction n ps r qs cpp)
981− | Inline `elem` qs,
912+ | Inline `elem` qs
982− everythingOnCpp (||) shouldRemove cpp = CppFunction n ps r (delete Inline qs) cpp
913+ , everythingOnCpp (||) shouldRemove cpp = CppFunction n ps r (delete Inline qs) cpp
984 shouldRemove :: Cpp -> Bool
915 shouldRemove :: Cpp -> Bool
985− shouldRemove CppSymbol{} = True
916+ shouldRemove CppSymbol {} = True
986− shouldRemove CppLambda{} = True
917+ shouldRemove CppLambda {} = True
987 shouldRemove _ = False
918 shouldRemove _ = False
988 convert cpp = cpp
919 convert cpp = cpp