47af0dc · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge remote-tracking branch 'pure11/pure11' into native

47af0dcAndy Arvanitis10 years ago

pcc/runtime/purescript.hh+1−1

compare with golang

unifiedsplit

@@ -517,7 +517,7 @@ namespace data {

517 }

518

519 template <typename T>

520− inline auto ctor(const T& a) -> const any& {

520+ inline auto ctor(const T& a) -> int {

521 return get<0>(a);

522 }

523}

src/Language/PureScript/CodeGen/Cpp.hs+3−2

@@ -28,7 +28,6 @@ module Language.PureScript.CodeGen.Cpp

28 ) where

30import Prelude.Compat

31−

32import Data.Char (isLetter)

31import Data.Char (isLetter)

33import Data.Function (on)

32import Data.Function (on)

34import Data.List

33import Data.List

@@ -110,6 +109,7 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

110 symbols = allSymbols bodyCpps

109 symbols = allSymbols bodyCpps

111 moduleBody =

110 moduleBody =

112 CppInclude (runModuleName mn) (runModuleName mn) :

111 CppInclude (runModuleName mn) (runModuleName mn) :

112+ P.linebreak ++

113 (CppDefineSymbol <$> symbols) ++

114 (if null bodyCpps

115 then []

@@ -138,7 +138,8 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

138 -------------------------------------------------------------------------------------------------

139 declToCpp _ (_, ident) e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

140 let className = identToCpp ident

141+ (supers, members) =

141− (supers, members) = span (C.__superclass_ `Text.isPrefixOf`) (identToCpp <$> (fst $ unAbs e []))

142+ span (safeName C.__superclass_ `Text.isPrefixOf`) (identToCpp <$> (fst $ unAbs e []))

142 in return $ CppStruct className [CppEnum Nothing Nothing (sort supers <> members)]

143 in return $ CppStruct className [CppEnum Nothing Nothing (sort supers <> members)]

143 declToCpp vqs (_, ident) (Abs (_, com, ty, _) arg body) = do

144 declToCpp vqs (_, ident) (Abs (_, com, ty, _) arg body) = do

144 fn <-

145 fn <-

src/Language/PureScript/CodeGen/Cpp/AST.hs+5−4

@@ -270,7 +270,7 @@ data Cpp

270 -- |

271 -- Switch statement

272 --

273− | CppSwitch Cpp [(Cpp, Cpp)]

273+ | CppSwitch Cpp [(Cpp, Cpp)] (Maybe Cpp)

274 -- |

275 -- Return statement

276 --

@@ -329,7 +329,7 @@ everywhereOnCpp f = go

329 go (CppAssignment j1 j2) = f (CppAssignment (go j1) (go j2))

330 go (CppWhile j1 j2) = f (CppWhile (go j1) (go j2))

331 go (CppIfElse j1 j2 j3) = f (CppIfElse (go j1) (go j2) (fmap go j3))

332− go (CppSwitch cpp cpps) = f (CppSwitch (go cpp) (map (fmap go) cpps))

332+ go (CppSwitch cpp cpps d) = f (CppSwitch (go cpp) (map (fmap go) cpps) (fmap go d))

333 go (CppReturn cpp) = f (CppReturn (go cpp))

334 go (CppThrow cpp) = f (CppThrow (go cpp))

335 go (CppComment com j) = f (CppComment com (go j))

@@ -362,7 +362,7 @@ everywhereOnCppTopDownM f = f >=> go

362 go (CppAssignment j1 j2) = CppAssignment <$> f' j1 <*> f' j2

363 go (CppWhile j1 j2) = CppWhile <$> f' j1 <*> f' j2

364 go (CppIfElse j1 j2 j3) = CppIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3

365− go (CppSwitch cpp cpps) = CppSwitch <$> f' cpp <*> traverse (pairM f' f') cpps

365+ go (CppSwitch cpp cpps d) = CppSwitch <$> f' cpp <*> traverse (pairM f' f') cpps <*> traverse f' d

366 go (CppReturn j) = CppReturn <$> f' j

367 go (CppThrow j) = CppThrow <$> f' j

368 go (CppComment com j) = CppComment com <$> f' j

@@ -392,7 +392,8 @@ everythingOnCpp (<>) f = go

392 go j@(CppWhile j1 j2) = f j <> go j1 <> go j2

393 go j@(CppIfElse j1 j2 Nothing) = f j <> go j1 <> go j2

394 go j@(CppIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3

395− go j@(CppSwitch cpp cpps) = foldl (<>) (f j <> go cpp) ((map (go . fst) cpps) ++ (map (go . snd) cpps))

395+ go j@(CppSwitch cpp cpps Nothing) = foldl (<>) (f j <> go cpp) ((map (go . fst) cpps) ++ (map (go . snd) cpps))

396+ go j@(CppSwitch cpp cpps (Just d)) = foldl (<>) (f j <> go cpp) ((map (go . fst) cpps) ++ (map (go . snd) cpps)) <> go d

396 go j@(CppReturn j1) = f j <> go j1

397 go j@(CppReturn j1) = f j <> go j1

397 go j@(CppThrow j1) = f j <> go j1

398 go j@(CppThrow j1) = f j <> go j1

398 go j@(CppComment _ j1) = f j <> go j1

399 go j@(CppComment _ j1) = f j <> go j1

src/Language/PureScript/CodeGen/Cpp/Common.hs+16−4

@@ -18,11 +18,12 @@

19module Language.PureScript.CodeGen.Cpp.Common where

21−import Prelude.Compat hiding (all, concatMap, last, init, null)

21+import Prelude.Compat hiding (all, any, concatMap, last, init, map, null)

23import Data.Char

24−import Data.Text hiding (map)

24+import Data.Text hiding (foldl1)

25import Data.Monoid ((<>))

26+import qualified Language.PureScript.Constants as C

26import Language.PureScript.Crash

27import Language.PureScript.Crash

27import Language.PureScript.Names

28import Language.PureScript.Names

@@ -45,6 +46,10 @@ safeName name

45safeName name

46safeName name

46 | Just ('$', s) <- uncons name

47 | Just ('$', s) <- uncons name

47 , all isDigit s = name

48 , all isDigit s = name

49+safeName name

50+ | C.__superclass_ `isPrefixOf` name

51+ , any (=='.') name

52+ = "$" <> (escaped $ dotsTo '_' name)

48safeName name

53safeName name

49 | "_" `isPrefixOf` name = "$" <> escaped name

54 | "_" `isPrefixOf` name = "$" <> escaped name

50safeName name = escaped name

55safeName name = escaped name

@@ -52,6 +57,9 @@ safeName name = escaped name

52escaped :: Text -> Text

57escaped :: Text -> Text

53escaped = escapeDoubleUnderscores . concatMap identCharToText

58escaped = escapeDoubleUnderscores . concatMap identCharToText

60+dotsTo :: Char -> Text -> Text

61+dotsTo chr' = map (\c -> if c == '.' then chr' else c)

62+

55-- |

63-- |

56-- C++ actually reserves all identifiers containing double

64-- C++ actually reserves all identifiers containing double

57-- underscores.

65-- underscores.

@@ -235,8 +243,12 @@ normalizedName = unescapeDoubleUnderscores . normalizedName'

235

243

236moduleNameToCpp :: ModuleName -> Text

244moduleNameToCpp :: ModuleName -> Text

237moduleNameToCpp (ModuleName pns) =

245moduleNameToCpp (ModuleName pns) =

238− let name = intercalate "_" (runProperName `map` pns)

239− in if properNameIsCppReserved name then name <> "$" else name

246+ if properNameIsCppReserved name then name <> "$" else name

247+ where

248+ pnames = runProperName <$> pns

249+ name

250+ | foldl1 (||) (any (=='_') <$> pnames) = error "Module names can now contain underscores"

251+ | otherwise = intercalate "_" pnames

240

252

241-- |

253-- |

242-- Checks whether a proper name is reserved in C++11.

254-- Checks whether a proper name is reserved in C++11.

src/Language/PureScript/CodeGen/Cpp/File.hs+2−3

@@ -24,11 +24,10 @@ import Data.Monoid ((<>))

24import Data.Text (Text)

26import Language.PureScript.CodeGen.Cpp.AST

27+import Language.PureScript.CodeGen.Cpp.Common

27import Language.PureScript.CodeGen.Cpp.Types

28import Language.PureScript.CodeGen.Cpp.Types

28import Language.PureScript.Names

29import Language.PureScript.Names

30−import qualified Language.PureScript.Pretty.Cpp as P

31−

32---------------------------------------------------------------------------------------------------

31---------------------------------------------------------------------------------------------------

33toHeader :: [Cpp] -> [Cpp]

32toHeader :: [Cpp] -> [Cpp]

34---------------------------------------------------------------------------------------------------

33---------------------------------------------------------------------------------------------------

@@ -171,7 +170,7 @@ fileEnd :: ModuleName -> Text -> [Cpp]

171fileEnd mn suffix = [CppRaw ("#endif // " <> fileModName mn suffix)]

170fileEnd mn suffix = [CppRaw ("#endif // " <> fileModName mn suffix)]

172

171

173fileModName :: ModuleName -> Text -> Text

172fileModName :: ModuleName -> Text -> Text

174−fileModName mn suffix = P.dotsTo '_' (runModuleName mn <> "_" <> suffix)

173+fileModName mn suffix = dotsTo '_' (runModuleName mn <> "_" <> suffix)

175

174

176isMain :: ModuleName -> Bool

175isMain :: ModuleName -> Bool

177isMain (ModuleName [ProperName "Main"]) = True

176isMain (ModuleName [ProperName "Main"]) = True

src/Language/PureScript/CodeGen/Cpp/Optimizer.hs+1

@@ -69,6 +69,7 @@ optimize' nm cpp = do

69 opts <- ask

70 untilFixedPoint (liftM toAutoVars . inlineFnComposition . applyAll

71 [ collapseNestedBlocks

72+ , collapseCtorChecksToSwitch

72 , collapseNestedIfs

73 , collapseNestedIfs

73 , collapseIfElses

74 , collapseIfElses

74 , removeCurrying nm

75 , removeCurrying nm

src/Language/PureScript/CodeGen/Cpp/Optimizer/Blocks.hs+25−1

@@ -17,11 +17,14 @@ module Language.PureScript.CodeGen.Cpp.Optimizer.Blocks

17 ( collapseNestedBlocks

18 , collapseNestedIfs

19 , collapseIfElses

20+ , collapseCtorChecksToSwitch

20 ) where

21 ) where

22import Prelude.Compat

23import Prelude.Compat

24+import Data.Either

24import Language.PureScript.CodeGen.Cpp.AST

26import Language.PureScript.CodeGen.Cpp.AST

27+import Language.PureScript.CodeGen.Cpp.Types

25import qualified Language.PureScript.Constants as C

28import qualified Language.PureScript.Constants as C

27-- |

30-- |

@@ -53,7 +56,7 @@ collapseIfElses = everywhereOnCpp collapse

53 where

56 where

54 go (st'@(CppIfElse (CppBinary EqualTo lhs _) _ Nothing) : sts') =

57 go (st'@(CppIfElse (CppBinary EqualTo lhs _) _ Nothing) : sts') =

55 if length (fst cpps') > 1

58 if length (fst cpps') > 1

56− then CppSwitch lhs (mkCases <$> fst cpps') : snd cpps'

59+ then CppSwitch lhs (mkCases <$> fst cpps') Nothing : snd cpps'

57 else st' : sts'

60 else st' : sts'

58 where

61 where

59 cpps' = span (isIntEq lhs) (st' : sts')

62 cpps' = span (isIntEq lhs) (st' : sts')

@@ -83,3 +86,24 @@ collapseIfElses = everywhereOnCpp collapse

83 go cpp' = cpp'

86 go cpp' = cpp'

84 collapse (CppIfElse (CppAccessor (CppVar "otherwise") (CppVar mn')) body _) | mn' == C.prelude = body

87 collapse (CppIfElse (CppAccessor (CppVar "otherwise") (CppVar mn')) body _) | mn' == C.prelude = body

85 collapse cpp = cpp

88 collapse cpp = cpp

89+

90+collapseCtorChecksToSwitch :: Cpp -> Cpp

91+collapseCtorChecksToSwitch = everywhereOnCpp collapse

92+ where

93+ collapse :: Cpp -> Cpp

94+ collapse (CppBlock cpps@(_:_:_)) = CppBlock (go cpps)

95+ where

96+ go cpps'@(cpp:_)

97+ | Right (lhs, _, _) <- fromif Nothing cpp

98+ , (otherCpps, ifs@(_:_:_)) <- partitionEithers $ fromif (Just lhs) <$> cpps'

99+ = CppSwitch lhs ((\(_,b,c) -> (b,c)) <$> ifs) Nothing : otherCpps

100+ go (cpp':cpps') = cpp' : go cpps'

101+ go cpp' = cpp'

102+ fromif :: Maybe Cpp -> Cpp -> Either Cpp (Cpp, Cpp, Cpp)

103+ fromif cond (CppIfElse (CppBinary EqualTo lhs rhs) stmt Nothing)

104+ | CppApp (CppVar f) _ <- lhs

105+ , f == getCtor

106+ , maybe True (lhs==) cond

107+ = Right (lhs, rhs, stmt)

108+ fromif _ cpp = Left cpp

109+ collapse cpp = cpp

src/Language/PureScript/Pretty/Cpp.hs+35−19

@@ -85,24 +85,18 @@ literals = mkPattern' match

85 match (CppCharLiteral c) = return $ "'" <> T.singleton c <> "'"

86 match (CppBooleanLiteral True) = return "true"

87 match (CppBooleanLiteral False) = return "false"

88− match (CppArrayLiteral [x@CppArrayLiteral {}]) = -- Works around what appears to be a recent clang bug

89− mconcat <$> sequence

90− [ return $ runType arrayType

88+ match (CppArrayLiteral []) = return $ runType arrayType <> "{}"

91− , return "{ { "

92− , prettyPrintCpp' x

93− , return " } }"

94− ]

95 match (CppArrayLiteral xs) = mconcat <$> sequence

89 match (CppArrayLiteral xs) = mconcat <$> sequence

96 [ return $ runType arrayType

90 [ return $ runType arrayType

97− , return "{ "

91+ , return "{{ "

98 , fmap (T.intercalate ", ") $ forM xs prettyPrintCpp'

92 , fmap (T.intercalate ", ") $ forM xs prettyPrintCpp'

99− , return " }"

93+ , return " }}"

100 ]

94 ]

101 match (CppDataLiteral xs) = mconcat <$> sequence

95 match (CppDataLiteral xs) = mconcat <$> sequence

102 [ return $ runType (dataType $ length xs)

96 [ return $ runType (dataType $ length xs)

103− , return "{ "

97+ , return "{{ "

104 , fmap (T.intercalate ", ") $ forM xs prettyPrintCpp'

98 , fmap (T.intercalate ", ") $ forM xs prettyPrintCpp'

105− , return " }"

99+ , return " }}"

106 ]

100 ]

107 match (CppEnum name ty es) = mconcat <$> sequence

101 match (CppEnum name ty es) = mconcat <$> sequence

108 [ return "enum"

102 [ return "enum"

@@ -276,15 +270,17 @@ literals = mkPattern' match

276 , prettyPrintCpp' thens

270 , prettyPrintCpp' thens

277 , maybe (return "") (fmap (" else " <>) . prettyPrintCpp') elses

271 , maybe (return "") (fmap (" else " <>) . prettyPrintCpp') elses

278 ]

272 ]

279− match (CppSwitch cond cases@((case1,_):_:_)) = mconcat <$> sequence

273+ match (CppSwitch cond cases@((case1,_):_:_) default') = mconcat <$> sequence

280 [ return "switch "

274 [ return "switch "

281 , return . parensT $ prettyPrintCpp1 (cast case1 cond)

275 , return . parensT $ prettyPrintCpp1 (cast case1 cond)

282 , return " {\n"

276 , return " {\n"

283 , withIndent $ do

277 , withIndent $ do

284− cpps <- forM cases $ \(c, s) -> do

278+ cpps <- forM (normalizeBlocks $

279+ cases ++ maybe [] (\c -> [(CppNoOp,c)]) default')

280+ $ \(c, s) -> do

285− c' <- prettyPrintCpp' c

281+ c' <- prettyPrintCpp' c

286− s' <- prettyPrintCpp' s

282+ s' <- prettyPrintCpp' s

287− return $ "case " <> c' <> ": " <> s' <> ";"

283+ return $ label c <> c' <> ": " <> s' <> caseEnd s

288 indentString <- currentIndent

284 indentString <- currentIndent

289 return $ T.intercalate "\n" $ map (indentString <>) cpps

285 return $ T.intercalate "\n" $ map (indentString <>) cpps

290 , return "\n"

286 , return "\n"

@@ -297,6 +293,25 @@ literals = mkPattern' match

297 cast CppBooleanLiteral {} cpp' = CppCast boolType cpp'

293 cast CppBooleanLiteral {} cpp' = CppCast boolType cpp'

298 cast CppCharLiteral {} cpp' = CppCast charType cpp'

294 cast CppCharLiteral {} cpp' = CppCast charType cpp'

299 cast _ cpp' = cpp'

295 cast _ cpp' = cpp'

296+ normalizeBlocks :: [(Cpp,Cpp)] -> [(Cpp,Cpp)]

297+ normalizeBlocks cpps

298+ | any (isBlock . snd) cpps = addBlock <$> cpps

299+ | otherwise = cpps

300+ where

301+ addBlock (cpp1, cpp2@(CppBlock _)) = (cpp1, cpp2)

302+ addBlock (cpp1, cpp2) = (cpp1, CppBlock [cpp2])

303+ label :: Cpp -> Text

304+ label CppNoOp = "default"

305+ label _ = "case "

306+ caseEnd :: Cpp -> Text

307+ caseEnd (CppReturn {}) = ";"

308+ caseEnd (CppThrow {}) = ";"

309+ caseEnd (CppContinue) = ";"

310+ caseEnd (CppBlock stmts@(_:_))

311+ | (CppReturn {}) <- last stmts = ""

312+ | (CppThrow {}) <- last stmts = ""

313+ | CppContinue <- last stmts = ""

314+ caseEnd _ = " break;"

300 match (CppReturn (CppBlock (cpp:cpps))) = mconcat <$> sequence

315 match (CppReturn (CppBlock (cpp:cpps))) = mconcat <$> sequence

301 [ do s <- prettyPrintCpp' cpp

316 [ do s <- prettyPrintCpp' cpp

302 return $ T.dropWhile isSpace s

317 return $ T.dropWhile isSpace s

@@ -500,9 +515,6 @@ prettyPrintCpp' = A.runKleisli $ runPattern matchValue

500 , [ binary Or " || " ]

515 , [ binary Or " || " ]

501 ]

516 ]

502

517

503−dotsTo :: Char -> Text -> Text

504−dotsTo chr' = T.map (\c -> if c == '.' then chr' else c)

505−

506argstr :: (Text, Maybe CppType) -> Text

518argstr :: (Text, Maybe CppType) -> Text

507argstr (name, Nothing) = argStr name (Auto [])

519argstr (name, Nothing) = argStr name (Auto [])

508argstr (name, Just typ)

520argstr (name, Just typ)

@@ -538,6 +550,10 @@ isNoOp CppNoOp = True

538isNoOp (CppComment [] CppNoOp) = True

550isNoOp (CppComment [] CppNoOp) = True

539isNoOp _ = False

551isNoOp _ = False

540

552

553+isBlock :: Cpp -> Bool

554+isBlock (CppBlock {}) = True

555+isBlock _ = False

556+

541renderName :: Text -> Text

557renderName :: Text -> Text

542renderName name

558renderName name

543 | Just ('*', name') <- T.uncons name = '$' `T.cons` name'

559 | Just ('*', name') <- T.uncons name = '$' `T.cons` name'