@@ -1,4 +1,4 @@
1−-----------------------------------------------------------------------------
1+---------------------------------------------------------------------------------------------------
22--
33-- Module : Language.PureScript.CodeGen.Cpp
44-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
@@ -9,10 +9,10 @@
99-- Portability :
1010--
1111-- |
12−-- This module generates code in the simplified C++1x intermediate representation from Purescript code
12+-- This module generates code in the simplified C++1x intermediate representation from
13+-- Purescript code.
1314--
14−-----------------------------------------------------------------------------
15−
15+---------------------------------------------------------------------------------------------------
1616{-# LANGUAGE GADTs #-}
1717{-# LANGUAGE ViewPatterns #-}
1818{-# LANGUAGE FlexibleContexts #-}
@@ -63,35 +63,39 @@ moduleToCpp :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSu
6363 => E.Environment -> Module Ann -> m [Cpp]
6464---------------------------------------------------------------------------------------------------
6565moduleToCpp env (Module _ mn imps _ foreigns decls) = do
66− cppImports <- traverse (pure . runModuleName) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
67− let cppImports' = "PureScript" : cppImports
68− cppDecls <- concat <$> mapM bindToCpp decls
69− optimized <- traverse optimize cppDecls
70− let moduleHeader = fileBegin mn "HH"
71− ++ P.linebreak
72− ++ ((\i -> CppInclude i i) <$> cppImports')
73− ++ (if not (null foreigns)
74− then [CppInclude [] (runModuleName mn ++ "_ffi")]
75− else []
76− )
77− ++ P.linebreak
78− ++ [CppNamespace (runModuleName mn) $
79− (CppUseNamespace <$> cppImports') ++ P.linebreak
80− ++ toHeader optimized
81− ++ toHeaderFns optimized
82− ]
83− ++ P.linebreak
84− ++ fileEnd mn "HH"
85− let bodyCpps = toBodyDecl optimized ++ toBody optimized
86− moduleBody = CppInclude (runModuleName mn) (runModuleName mn) : P.linebreak
87− ++ (if null bodyCpps
88− then []
89− else [CppNamespace (runModuleName mn) $
90− (CppUseNamespace <$> cppImports') ++ P.linebreak ++ bodyCpps])
91− ++ P.linebreak
92− ++ (if isMain mn then [nativeMain] ++ P.linebreak else [])
93− return $ moduleHeader ++ CppEndOfHeader : moduleBody
94−
66+ cppImports <-
67+ traverse (pure . runModuleName) .
68+ delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $
69+ imps
70+ let cppImports' = "PureScript" : cppImports
71+ cppDecls <- concat <$> mapM bindToCpp decls
72+ optimized <- traverse optimize cppDecls
73+ let moduleHeader =
74+ fileBegin mn "HH" ++
75+ P.linebreak ++
76+ ((\i -> CppInclude i i) <$> cppImports') ++
77+ (if not (null foreigns)
78+ then [CppInclude [] (runModuleName mn ++ "_ffi")]
79+ else []) ++
80+ P.linebreak ++
81+ [ CppNamespace (runModuleName mn) $
82+ (CppUseNamespace <$> cppImports') ++
83+ P.linebreak ++ toHeader optimized ++ toHeaderFns optimized ] ++
84+ P.linebreak ++ fileEnd mn "HH"
85+ let bodyCpps = toBodyDecl optimized ++ toBody optimized
86+ moduleBody =
87+ CppInclude (runModuleName mn) (runModuleName mn) :
88+ P.linebreak ++
89+ (if null bodyCpps
90+ then []
91+ else [ CppNamespace (runModuleName mn) $
92+ (CppUseNamespace <$> cppImports') ++
93+ P.linebreak ++ bodyCpps ]) ++
94+ P.linebreak ++
95+ (if isMain mn
96+ then [nativeMain] ++ P.linebreak
97+ else [])
98+ return $ moduleHeader ++ CppEndOfHeader : moduleBody
9599 where
96100 -- |
97101 -- Generate code in the simplified C++1x intermediate representation for a declaration
@@ -115,37 +119,47 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
115119 body@(Accessor _ _ (Var _ (Qualified Nothing arg'))))
116120 | arg' == arg = do
117121 block <- asReturnBlock <$> valueToCpp body
118− let fn' = CppFunction (identToCpp ident)
119− [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]
120− (Just $ CppAny [])
121− []
122− block
122+ let fn' = CppFunction
123+ (identToCpp ident)
124+ [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]
125+ (Just $ CppAny [])
126+ []
127+ block
123128 return fn'
124129
125130 declToCpp vqs ident (Abs (_, com, _, _) arg body) = do
126131 block <- asReturnBlock <$> valueToCpp body
127132 let block' = convertNestedLambdas block
128− fn' = CppFunction (identToCpp ident) [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]
129− (Just $ CppAny [])
130− vqs
131− block'
133+ fn' = CppFunction
134+ (identToCpp ident)
135+ [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]
136+ (Just $ CppAny [])
137+ vqs
138+ block'
132139 return (CppComment com fn')
133140
134− declToCpp _ ident (Constructor _ _ (ProperName _) []) = return $
135− CppFunction (identToCpp ident)
136− [] (Just $ CppAny [])
137− [CppInline]
138− (CppBlock [CppReturn (CppDataLiteral [CppStringLiteral (identToCpp ident)])])
141+ declToCpp _ ident (Constructor _ _ (ProperName _) []) =
142+ return $
143+ CppFunction
144+ (identToCpp ident)
145+ []
146+ (Just $ CppAny [])
147+ [CppInline]
148+ (CppBlock [CppReturn (CppDataLiteral [CppStringLiteral (identToCpp ident)])])
139149
140150 declToCpp _ ident (Constructor _ _ (ProperName _) fields) = return . CppNamespace [] $
141− [ CppFunction ('$' : identToCpp ident) (farg <$> fields')
142− (Just $ CppAny [])
143− [CppInline]
144− (CppBlock fullyConstructed)
145− , CppFunction (identToCpp ident) (farg <$> f)
146− (Just $ CppAny [])
147− []
148− (CppBlock (fieldLambdas fs))
151+ [ CppFunction
152+ ('$' : identToCpp ident)
153+ (farg <$> fields')
154+ (Just $ CppAny [])
155+ [CppInline]
156+ (CppBlock fullyConstructed)
157+ , CppFunction
158+ (identToCpp ident)
159+ (farg <$> f)
160+ (Just $ CppAny [])
161+ []
162+ (CppBlock (fieldLambdas fs))
149163 ]
150164 where
151165 name = identToCpp ident
@@ -154,24 +168,31 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
154168 | otherwise = ([], [])
155169 farg = \x -> (x, Just $ CppAny [CppConst, CppRef])
156170 fieldLambdas flds
157− | (f' : fs') <- flds = [CppReturn . maybeRemCaps $
158− CppLambda [CppCaptureAll] (farg <$> [f'])
159− (Just $ CppAny [])
160− (CppBlock $ fieldLambdas fs')]
171+ | (f' : fs') <- flds = [ CppReturn . maybeRemCaps $
172+ CppLambda
173+ [CppCaptureAll]
174+ (farg <$> [f'])
175+ (Just $ CppAny [])
176+ (CppBlock $ fieldLambdas fs') ]
161177 | otherwise = fullyConstructed
162178 fullyConstructed = [CppReturn (CppDataLiteral (CppStringLiteral name : (CppVar <$> fields')))]
163179
164180 declToCpp _ ident val = do
165181 val' <- valueToCpp val
166− return $ CppVariableIntroduction (identToCpp ident, Just $ CppAny [CppConst]) [] (Just val')
182+ return $
183+ CppVariableIntroduction
184+ (identToCpp ident, Just $ CppAny [CppConst])
185+ []
186+ (Just val')
167187
168188 -------------------------------------------------------------------------------------------------
169189 fnToLambda :: Cpp -> Cpp
170190 -------------------------------------------------------------------------------------------------
171191 fnToLambda (CppFunction name args _ qs body) =
172− CppVariableIntroduction (name, Just $ CppAny [CppConst])
173− (filter (==CppStatic) qs)
174− (Just (CppLambda cs args (Just $ CppAny []) body))
192+ CppVariableIntroduction
193+ (name, Just $ CppAny [CppConst])
194+ (filter (==CppStatic) qs)
195+ (Just $ CppLambda cs args (Just $ CppAny []) body)
175196 where
176197 cs | (not . null) (qs `intersect` [CppInline, CppStatic]) = []
177198 | otherwise = [CppCaptureAll]
@@ -211,26 +232,36 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
211232 removeRec cpp' = cpp'
212233
213234 dict :: Cpp
214− dict = CppVariableIntroduction (topdict, Just $ CppAny [CppConst]) []
215− (Just $ CppObjectLiteral fns)
235+ dict = CppVariableIntroduction
236+ (topdict, Just $ CppAny [CppConst])
237+ []
238+ (Just $ CppObjectLiteral fns)
216239
217240 accessor :: String -> (String, Cpp) -> Cpp
218− accessor dictname (name, _) = CppVariableIntroduction (name, Just $ CppAny [CppConst]) [] (Just accessed)
241+ accessor dictname (name, _) =
242+ CppVariableIntroduction
243+ (name, Just $ CppAny [CppConst])
244+ []
245+ (Just accessed)
219246 where
220247 dict' = CppVar dictname
221248 accessed = CppApp (CppIndexer (CppStringLiteral name) dict') [dict']
222249
223250 toelem :: Cpp -> (String, Cpp)
224251 toelem (CppFunction name args rtyp _ (CppBlock body)) =
225− (name, withdict . maybeRemCaps $ CppLambda [CppCaptureAll]
226− args rtyp (CppBlock $ (accessor localdict <$> fns) ++ body))
252+ (name, withdict . maybeRemCaps $ CppLambda
253+ [CppCaptureAll]
254+ args
255+ rtyp
256+ (CppBlock $ (accessor localdict <$> fns) ++ body))
227257 toelem _ = error "not a function"
228258
229259 withdict :: Cpp -> Cpp
230− withdict cpp' = maybeRemCaps $
231− CppLambda [CppCaptureAll] [(localdict, Just $ CppAny [CppConst, CppRef])]
232− (Just $ CppAny [])
233− (CppBlock [CppReturn cpp'])
260+ withdict cpp' = maybeRemCaps $ CppLambda
261+ [CppCaptureAll]
262+ [(localdict, Just $ CppAny [CppConst, CppRef])]
263+ (Just $ CppAny [])
264+ (CppBlock [CppReturn cpp'])
234265 topdict :: String
235266 topdict = "__dict__"
236267 localdict :: String
@@ -292,7 +323,12 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
292323 valueToCpp (Abs _ arg body) = do
293324 cpp <- valueToCpp body
294325 let cpp' = convertNestedLambdas cpp
295− return $ CppLambda [] [(identToCpp arg, Just $ CppAny [CppConst, CppRef])] (Just $ CppAny []) (asReturnBlock cpp')
326+ return $
327+ CppLambda
328+ []
329+ [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]
330+ (Just $ CppAny [])
331+ (asReturnBlock cpp')
296332
297333 -- valueToCpp (App _ e (Var _ (Qualified (Just (ModuleName [ProperName "Prim"])) (Ident "undefined")))) =
298334 -- valueToCpp e
@@ -307,7 +343,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
307343 Var (_, _, _, Just IsTypeClassConstructor) (Qualified mn' (Ident classname)) ->
308344 let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname)) in
309345 return . CppObjectLiteral $ zip ((sort $ superClassDictionaryNames constraints) ++ (fst <$> fns)) args'
310− _ -> -- TODO: verify this
346+ _ ->
311347 flip (foldl (\fn a -> CppApp fn [a])) args' <$> valueToCpp f
312348
313349 valueToCpp (Case (maybeSpan, _, ty, _) values binders) = do
@@ -322,7 +358,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
322358 then convertRecursiveFns ds''
323359 else ds''
324360 let cpps = convertNestedLambdas <$> rs
325− return $ CppApp (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret]))) []
361+ return $ CppApp
362+ (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret])))
363+ []
326364 where
327365 hasRecursion :: [Cpp] -> Bool
328366 hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'
@@ -367,10 +405,14 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
367405 cpps <- forM binders $ \(CaseAlternative bs result) -> do
368406 ret <- guardsToCpp result
369407 go valNames ret bs
370− return $ CppApp (CppLambda []
371− []
372− (Just $ CppAny [])
373− (CppBlock (assignments ++ concat cpps ++ [failedPatternError valNames]))) []
408+ return $
409+ CppApp
410+ (CppLambda
411+ []
412+ []
413+ (Just $ CppAny [])
414+ (CppBlock (assignments ++ concat cpps ++ [failedPatternError valNames])))
415+ []
374416 where
375417 mkVarDecl :: String -> Maybe Cpp -> Cpp
376418 mkVarDecl name = CppVariableIntroduction (name, Nothing) []
@@ -386,7 +428,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
386428 CppThrow $ CppApp (CppVar "runtime_error") [CppStringLiteral errorMessage]
387429
388430 errorMessage :: String
389− errorMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
431+ errorMessage = "Failed pattern match" ++
432+ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++
433+ ": "
390434
391435 guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [Cpp]
392436 guardsToCpp (Left gs) = forM gs $ \(cond, val) -> do
@@ -408,7 +452,12 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
408452 literalToBinderCpp varName done l
409453
410454 binderToCpp varName done (VarBinder _ ident) =
411− return (CppVariableIntroduction (identToCpp ident, Just $ CppAny [CppConst]) [] (Just (CppVar varName)) : done)
455+ return $
456+ CppVariableIntroduction
457+ (identToCpp ident, Just $ CppAny [CppConst])
458+ []
459+ (Just $ CppVar varName)
460+ : done
412461
413462 binderToCpp varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
414463 binderToCpp varName done b
@@ -418,13 +467,19 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
418467 (Qualified _ (ProperName ctor))
419468 bs) = do
420469 cpps <- go (zip fields bs) done
421− return $ case ctorType of
422− ProductType -> cpps
423− SumType ->
424− [ CppIfElse (CppBinary Equal (CppIndexer (CppVar ctorKey) (CppCast dataType $ CppVar varName))
425− (CppStringLiteral ctor))
426− (CppBlock cpps)
427− Nothing ]
470+ return $
471+ case ctorType of
472+ ProductType -> cpps
473+ SumType ->
474+ [ CppIfElse
475+ (CppBinary
476+ Equal
477+ (CppIndexer
478+ (CppVar ctorKey)
479+ (CppCast dataType $ CppVar varName))
480+ (CppStringLiteral ctor))
481+ (CppBlock cpps)
482+ Nothing]
428483 where
429484 go :: [(Ident, Binder Ann)] -> [Cpp] -> m [Cpp]
430485 go [] done' = return done'
@@ -432,10 +487,14 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
432487 argVar <- freshName
433488 done'' <- go remain done'
434489 cpps <- binderToCpp argVar done'' binder
435− return (CppVariableIntroduction (argVar, Nothing)
436− []
437− (Just (CppIndexer (fieldToIndex field) (CppCast dataType $ CppVar varName)))
438− : cpps)
490+ return $
491+ CppVariableIntroduction
492+ (argVar, Nothing)
493+ []
494+ (Just $ CppIndexer
495+ (fieldToIndex field)
496+ (CppCast dataType $ CppVar varName))
497+ : cpps
439498 fieldToIndex :: Ident -> Cpp
440499 fieldToIndex = CppNumericLiteral . Left . (+1) . read . dropWhile isLetter . runIdent
441500
@@ -444,31 +503,47 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
444503
445504 binderToCpp varName done (NamedBinder _ ident binder) = do
446505 cpp <- binderToCpp varName done binder
447− return (CppVariableIntroduction (identToCpp ident, Just $ CppAny [CppConst]) [] (Just (CppVar varName)) : cpp)
506+ return $
507+ CppVariableIntroduction
508+ (identToCpp ident, Just $ CppAny [CppConst])
509+ []
510+ (Just $ CppVar varName)
511+ : cpp
448512
449513 -------------------------------------------------------------------------------------------------
450514 literalToBinderCpp :: String -> [Cpp] -> Literal (Binder Ann) -> m [Cpp]
451515 -------------------------------------------------------------------------------------------------
452516 literalToBinderCpp varName done (NumericLiteral num) =
453− return [CppIfElse (CppBinary Equal (CppVar varName) (CppNumericLiteral num)) (CppBlock done) Nothing]
517+ return [ CppIfElse
518+ (CppBinary Equal (CppVar varName) (CppNumericLiteral num))
519+ (CppBlock done)
520+ Nothing ]
454521
455522 literalToBinderCpp varName done (CharLiteral c) =
456− return [CppIfElse (CppBinary Equal (CppVar varName)
457− (CppCharLiteral c))
458− (CppBlock done)
459− Nothing]
523+ return [ CppIfElse
524+ (CppBinary Equal (CppVar varName) (CppCharLiteral c))
525+ (CppBlock done)
526+ Nothing ]
460527
461528 literalToBinderCpp varName done (StringLiteral str) =
462− return [CppIfElse (CppBinary Equal (CppVar varName)
463− (CppStringLiteral str))
464− (CppBlock done)
465− Nothing]
529+ return [ CppIfElse
530+ (CppBinary Equal (CppVar varName) (CppStringLiteral str))
531+ (CppBlock done)
532+ Nothing ]
466533
467534 literalToBinderCpp varName done (BooleanLiteral True) =
468− return [CppIfElse (CppVar varName) (CppBlock done) Nothing]
535+ return [ CppIfElse
536+ (CppVar varName)
537+ (CppBlock done)
538+ Nothing ]
469539
470540 literalToBinderCpp varName done (BooleanLiteral False) =
471− return [CppIfElse (CppUnary CppNot (CppVar varName)) (CppBlock done) Nothing]
541+ return [ CppIfElse
542+ (CppUnary
543+ CppNot
544+ (CppVar varName))
545+ (CppBlock done)
546+ Nothing ]
472547
473548 literalToBinderCpp varName done (ObjectLiteral bs) = go done bs
474549 where
@@ -478,19 +553,28 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
478553 propVar <- freshName
479554 done'' <- go done' bs'
480555 cpp <- binderToCpp propVar done'' binder
481− return (CppVariableIntroduction (propVar, Nothing)
482− []
483− (Just (CppIndexer (CppStringLiteral prop) (CppVar varName)))
484− : cpp)
556+ return $
557+ CppVariableIntroduction
558+ (propVar, Nothing)
559+ []
560+ (Just $ CppIndexer
561+ (CppStringLiteral prop)
562+ (CppVar varName))
563+ : cpp
485564
486565 literalToBinderCpp varName done (ArrayLiteral bs) = do
487566 cpp <- go done 0 bs
488− let cond = case length bs of
489− 0 -> CppBinary Dot (CppCast arrayType $ CppVar varName)
490− (CppApp (CppVar "empty") [])
491− n -> let var = CppCast arrayType $ CppVar varName in
492− CppBinary Equal (CppBinary Dot var (CppApp (CppVar "size") []))
493− (CppNumericLiteral (Left (fromIntegral n)))
567+ let cond =
568+ case length bs of
569+ 0 -> CppBinary
570+ Dot
571+ (CppCast arrayType $ CppVar varName)
572+ (CppApp (CppVar "empty") [])
573+ n -> let var = CppCast arrayType $ CppVar varName
574+ in CppBinary
575+ Equal
576+ (CppBinary Dot var (CppApp (CppVar "size") []))
577+ (CppNumericLiteral (Left (fromIntegral n)))
494578 return [ CppIfElse cond (CppBlock cpp) Nothing ]
495579 where
496580 go :: [Cpp] -> Integer -> [Binder Ann] -> m [Cpp]
@@ -499,28 +583,41 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do
499583 elVar <- freshName
500584 done'' <- go done' (index + 1) bs'
501585 cpp <- binderToCpp elVar done'' binder
502− return (CppVariableIntroduction (elVar, Nothing) []
503− (Just (CppIndexer (CppNumericLiteral (Left index)) (CppVar varName))) : cpp)
586+ return $
587+ CppVariableIntroduction
588+ (elVar, Nothing)
589+ []
590+ (Just $ CppIndexer
591+ (CppNumericLiteral (Left index))
592+ (CppVar varName))
593+ : cpp
504594
505595 -------------------------------------------------------------------------------------------------
506−
507596 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
597+ -------------------------------------------------------------------------------------------------
508598 unApp (App _ val arg) args = unApp val (arg : args)
509599 unApp other args = (other, args)
510600
601+ -------------------------------------------------------------------------------------------------
511602 qualifiedToCpp :: (a -> Ident) -> Qualified a -> Cpp
512− qualifiedToCpp f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = CppVar . runIdent $ f a
603+ -------------------------------------------------------------------------------------------------
604+ qualifiedToCpp f (Qualified (Just (ModuleName [ProperName mn'])) a)
605+ | mn' == C.prim = CppVar . runIdent $ f a
513606 qualifiedToCpp f (Qualified (Just mn') a)
514607 | mn /= mn' = CppAccessor (CppVar . identToCpp $ f a) (CppVar (moduleNameToCpp mn'))
515608 qualifiedToCpp f (Qualified _ a) = CppVar $ identToCpp (f a)
516609
610+ -------------------------------------------------------------------------------------------------
517611 qualifiedToStr' :: (a -> Ident) -> Qualified a -> String
612+ -------------------------------------------------------------------------------------------------
518613 qualifiedToStr' = qualifiedToStr mn
519614
520615 -- |
521616 -- Find a class in scope by name, retrieving its list of constraints, function names and types.
522617 --
618+ -------------------------------------------------------------------------------------------------
523619 findClass :: Qualified (ProperName ClassName) -> Maybe ([String], [T.Constraint], [(String, T.Type)])
620+ -------------------------------------------------------------------------------------------------
524621 findClass name
525622 | Just (params, fns, constraints) <- M.lookup name (E.typeClasses env),
526623 fns' <- (\(i,t) -> (runIdent i, t)) <$> fns