git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
New C++11 backend baseline
commit9f2e7d2e60696b25358bdd06e8aeec466fdb7203 authorAndy Arvanitis <andyarvanitis@gmail.com> dateFri 9 Oct 2015, 16:04 (11 years ago) parentf7ff352
22 files changed+4213
compare with golang
unifiedsplit
pcc/Main.hs+173 pcc/Make.hs+192 pcc/Makefile.example+16 pcc/TestMain.hs+140 pcc/include/hash.hh+42 pcc/include/map_key.hh+57 pcc/include/purescript.cc+530 pcc/include/purescript.hh+400 purescript.cabal+35 src/Language/PureScript/CodeGen/Cpp.hs+528 src/Language/PureScript/CodeGen/Cpp/AST.hs+352 src/Language/PureScript/CodeGen/Cpp/Common.hs+205 src/Language/PureScript/CodeGen/Cpp/File.hs+158 src/Language/PureScript/CodeGen/Cpp/Optimizer.hs+92 src/Language/PureScript/CodeGen/Cpp/Optimizer/Blocks.hs+42 src/Language/PureScript/CodeGen/Cpp/Optimizer/Common.hs+75 src/Language/PureScript/CodeGen/Cpp/Optimizer/Inliner.hs+319 src/Language/PureScript/CodeGen/Cpp/Optimizer/MagicDo.hs+117 src/Language/PureScript/CodeGen/Cpp/Optimizer/TCO.hs+149 src/Language/PureScript/CodeGen/Cpp/Optimizer/Unused.hs+43 src/Language/PureScript/CodeGen/Cpp/Types.hs+122 src/Language/PureScript/Pretty/Cpp.hs+426
pcc/Main.hsnew file+173
@@ -0,0 +1,173 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE RecordWildCards #-}
18+{-# LANGUAGE TupleSections #-}
19+
20+module Main where
21+
22+import Control.Applicative
23+import Control.Monad
24+import Control.Monad.Error.Class (MonadError(..))
25+import Control.Monad.Writer.Strict
26+
27+import Data.Version (showVersion)
28+import qualified Data.Map as M
29+
30+import Options.Applicative as Opts
31+
32+import System.Exit (exitSuccess, exitFailure)
33+import System.IO (hPutStrLn, stderr)
34+
35+import qualified Language.PureScript as P
36+import qualified Paths_purescript as Paths
37+
38+import Make
39+
40+data PCCOptions = PCCOptions
41+ { pccmInput :: [FilePath]
42+ , pccmForeignInput :: [FilePath]
43+ , pccmOutputDir :: FilePath
44+ , pccmOpts :: P.Options
45+ , pccmUsePrefix :: Bool
46+ }
47+
48+data InputOptions = InputOptions
49+ { ioInputFiles :: [FilePath]
50+ }
51+
52+compile :: PCCOptions -> IO ()
53+compile (PCCOptions input _ outputDir opts usePrefix) = do
54+ moduleFiles <- readInput (InputOptions input)
55+ case runWriterT (parseInputs moduleFiles []) of
56+ Left errs -> do
57+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
58+ exitFailure
59+ Right ((ms, _), warnings) -> do
60+ when (P.nonEmpty warnings) $
61+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
62+ let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms
63+ makeActions = buildMakeActions outputDir filePathMap usePrefix
64+ e <- runMake opts $ P.make makeActions (map snd ms)
65+ case e of
66+ Left errs -> do
67+ putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
68+ exitFailure
69+ Right (_, warnings') -> do
70+ when (P.nonEmpty warnings') $
71+ putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
72+ exitSuccess
73+
74+readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
75+readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
76+
77+parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
78+ => [(Either P.RebuildPolicy FilePath, String)]
79+ -> [(FilePath, P.ForeignJS)]
80+ -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath)
81+parseInputs modules foreigns =
82+ (,) <$> P.parseModulesFromFiles (either (const "") id) modules
83+ <*> P.parseForeignModulesFromFiles foreigns
84+
85+inputFile :: Parser FilePath
86+inputFile = strArgument $
87+ metavar "FILE"
88+ <> help "The input .purs file(s)"
89+
90+inputForeignFile :: Parser FilePath
91+inputForeignFile = strOption $
92+ short 'f'
93+ <> long "ffi"
94+ <> help "The input .js file(s) providing foreign import implementations"
95+
96+outputDirectory :: Parser FilePath
97+outputDirectory = strOption $
98+ short 'o'
99+ <> long "output"
100+ <> Opts.value "output"
101+ <> showDefault
102+ <> help "The output directory"
103+
104+requirePath :: Parser (Maybe FilePath)
105+requirePath = optional $ strOption $
106+ short 'r'
107+ <> long "require-path"
108+ <> help "The path prefix to use for require() calls in the generated code"
109+
110+noTco :: Parser Bool
111+noTco = switch $
112+ long "no-tco"
113+ <> help "Disable tail call optimizations"
114+
115+noPrelude :: Parser Bool
116+noPrelude = switch $
117+ long "no-prelude"
118+ <> help "Omit the automatic Prelude import"
119+
120+noMagicDo :: Parser Bool
121+noMagicDo = switch $
122+ long "no-magic-do"
123+ <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."
124+
125+noOpts :: Parser Bool
126+noOpts = switch $
127+ long "no-opts"
128+ <> help "Skip the optimization phase."
129+
130+comments :: Parser Bool
131+comments = switch $
132+ short 'c'
133+ <> long "comments"
134+ <> help "Include comments in the generated code."
135+
136+verboseErrors :: Parser Bool
137+verboseErrors = switch $
138+ short 'v'
139+ <> long "verbose-errors"
140+ <> help "Display verbose error messages"
141+
142+noPrefix :: Parser Bool
143+noPrefix = switch $
144+ short 'p'
145+ <> long "no-prefix"
146+ <> help "Do not include comment header"
147+
148+options :: Parser P.Options
149+options = P.Options <$> noTco
150+ <*> noMagicDo
151+ <*> pure Nothing
152+ <*> noOpts
153+ <*> verboseErrors
154+ <*> (not <$> comments)
155+ <*> requirePath
156+
157+pccOptions :: Parser PCCOptions
158+pccOptions = PCCOptions <$> many inputFile
159+ <*> many inputForeignFile
160+ <*> outputDirectory
161+ <*> options
162+ <*> (not <$> noPrefix)
163+
164+main :: IO ()
165+main = execParser opts >>= compile
166+ where
167+ opts = info (version <*> helper <*> pccOptions) infoModList
168+ infoModList = fullDesc <> headerInfo <> footerInfo
169+ headerInfo = header "pcc - Compiles PureScript to C++11"
170+ footerInfo = footer $ "pcc " ++ showVersion Paths.version
171+
172+ version :: Parser (a -> a)
173+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
pcc/Make.hsnew file+192
@@ -0,0 +1,192 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Make
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18+{-# LANGUAGE TupleSections #-}
19+{-# LANGUAGE TemplateHaskell #-}
20+
21+module Make
22+ ( Make(..)
23+ , runMake
24+ , buildMakeActions
25+ ) where
26+
27+import Control.Monad
28+import Control.Monad.Error.Class (MonadError(..))
29+import Control.Monad.Trans.Except
30+import Control.Monad.Reader
31+import Control.Monad.Writer.Strict
32+
33+import Data.FileEmbed (embedFile)
34+import Data.List (intercalate)
35+import Data.Maybe (fromMaybe)
36+import Data.String (fromString)
37+import Data.Time.Clock
38+import Data.Version (showVersion)
39+import qualified Data.Map as M
40+import qualified Data.ByteString.Lazy as B
41+
42+import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime, createDirectoryIfMissing)
43+import System.FilePath ((</>), takeDirectory, addExtension, dropExtension)
44+import System.IO.Error (tryIOError)
45+
46+import qualified Language.PureScript as P
47+import qualified Language.PureScript.CodeGen.Cpp as CPP
48+import qualified Language.PureScript.CoreFn as CF
49+import qualified Paths_purescript as Paths
50+
51+newtype Make a = Make { unMake :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
52+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
53+
54+runMake :: P.Options -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))
55+runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
56+
57+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
58+makeIO f io = do
59+ e <- liftIO $ tryIOError io
60+ either (throwError . P.singleError . f) return e
61+
62+-- Traverse (Either e) instance (base 4.7)
63+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
64+traverseEither _ (Left x) = pure (Left x)
65+traverseEither f (Right y) = Right <$> f y
66+
67+buildMakeActions :: FilePath
68+ -> M.Map P.ModuleName (Either P.RebuildPolicy String)
69+ -> Bool
70+ -> P.MakeActions Make
71+buildMakeActions outputDir filePathMap usePrefix =
72+ P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
73+ where
74+
75+ getInputFile :: P.ModuleName -> FilePath
76+ getInputFile mn =
77+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap in
78+ case path of
79+ Right path' -> path'
80+ Left _ -> error "Module has no filename in 'make'"
81+
82+ getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
83+ getInputTimestamp mn = do
84+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
85+ traverseEither getTimestamp path
86+
87+ getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
88+ getOutputTimestamp mn = do
89+
90+ let filePath = dotsTo '/' $ P.runModuleName mn
91+ fileBase = outputDir </> filePath </> (last . words . dotsTo ' ' $ P.runModuleName mn)
92+ srcFile = addExtension fileBase "cc"
93+-- headerFile = addExtension fileBase "hh"
94+ externsFile = outputDir </> filePath </> "externs.purs"
95+ min <$> getTimestamp srcFile <*> getTimestamp externsFile
96+
97+ readExterns :: P.ModuleName -> Make (FilePath, B.ByteString)
98+ readExterns mn = do
99+ let path = outputDir </> (dotsTo '/' $ P.runModuleName mn) </> "externs.purs"
100+ (path, ) <$> readTextFile path
101+
102+ codegen :: CF.Module CF.Ann -> P.Environment -> P.Externs -> P.SupplyT Make ()
103+ codegen m env exts = do
104+ let mn = CF.moduleName m
105+ let filePath = dotsTo '/' $ P.runModuleName mn
106+ fileBase = outputDir </> filePath </> (last . words . dotsTo ' ' $ P.runModuleName mn)
107+ srcFile = addExtension fileBase "cc"
108+ headerFile = addExtension fileBase "hh"
109+ externsFile = outputDir </> filePath </> "externs.purs"
110+ prefix = ["Generated by pcc version " ++ showVersion Paths.version | usePrefix]
111+ cpps <- CPP.moduleToCpp env m
112+ let (hdrs,srcs) = span (/= CPP.CppEndOfHeader) cpps
113+ psrcs <- CPP.prettyPrintCpp <$> pure srcs
114+ phdrs <- CPP.prettyPrintCpp <$> pure hdrs
115+ let src = unlines $ map ("// " ++) prefix ++ [psrcs]
116+ hdr = unlines $ map ("// " ++) prefix ++ [phdrs]
117+
118+ lift $ do
119+ writeTextFile srcFile (fromString src)
120+ writeTextFile headerFile (fromString hdr)
121+ writeTextFile externsFile exts
122+
123+ let supportDir = outputDir </> "PureScript"
124+ supportFilesExist <- dirExists supportDir
125+ when (not supportFilesExist) $ do
126+ writeTextFile (outputDir </> "CMakeLists.txt") (fromString cmakeListsTxt)
127+ writeTextFile (supportDir </> "PureScript.hh") $ B.fromStrict $(embedFile "pcc/include/purescript.hh")
128+ writeTextFile (supportDir </> "PureScript.cc") $ B.fromStrict $(embedFile "pcc/include/purescript.cc")
129+ writeTextFile (supportDir </> "map_key.hh") $ B.fromStrict $(embedFile "pcc/include/map_key.hh")
130+ writeTextFile (supportDir </> "hash.hh") $ B.fromStrict $(embedFile "pcc/include/hash.hh")
131+
132+ when (requiresForeign m) $ do
133+ let inputPath = dropExtension $ getInputFile mn
134+ hfile = addExtension inputPath "hh"
135+ sfile = addExtension inputPath "cc"
136+ hfileExists <- textFileExists hfile
137+ when (not hfileExists) (throwError . P.errorMessage $ P.MissingFFIModule mn)
138+ text <- readTextFile hfile
139+ writeTextFile (addExtension (fileBase ++ "_ffi") "hh") text
140+ sfileExists <- textFileExists sfile
141+ when (sfileExists) $ do
142+ text' <- readTextFile sfile
143+ writeTextFile (addExtension (fileBase ++ "_ffi") "cc") text'
144+
145+ requiresForeign :: CF.Module a -> Bool
146+ requiresForeign = not . null . CF.moduleForeign
147+
148+ dirExists :: FilePath -> Make Bool
149+ dirExists path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do
150+ doesDirectoryExist path
151+
152+ textFileExists :: FilePath -> Make Bool
153+ textFileExists path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do
154+ doesFileExist path
155+
156+ getTimestamp :: FilePath -> Make (Maybe UTCTime)
157+ getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
158+ exists <- doesFileExist path
159+ traverse (const $ getModificationTime path) $ guard exists
160+
161+ readTextFile :: FilePath -> Make B.ByteString
162+ readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ B.readFile path
163+
164+ writeTextFile :: FilePath -> B.ByteString -> Make ()
165+ writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
166+ mkdirp path
167+ B.writeFile path text
168+ where
169+ mkdirp :: FilePath -> IO ()
170+ mkdirp = createDirectoryIfMissing True . takeDirectory
171+
172+ -- | Render a progress message
173+ renderProgressMessage :: P.ProgressMessage -> String
174+ renderProgressMessage (P.CompilingModule mn) = "Compiling " ++ P.runModuleName mn
175+
176+ progress :: P.ProgressMessage -> Make ()
177+ progress = liftIO . putStrLn . renderProgressMessage
178+
179+dotsTo :: Char -> String -> String
180+dotsTo chr = map (\c -> if c == '.' then chr else c)
181+
182+-- TODO: quick and dirty for now -- explicit file list would be better
183+cmakeListsTxt :: String
184+cmakeListsTxt = intercalate "\n" lines'
185+ where lines' = [ "cmake_minimum_required (VERSION 3.0)"
186+ , "project (Main)"
187+ , "file (GLOB_RECURSE SRCS *.cc)"
188+ , "file (GLOB_RECURSE HDRS *.hh)"
189+ , "add_executable (Main ${SRCS} ${HDRS})"
190+ , "include_directories (${CMAKE_CURRENT_SOURCE_DIR})"
191+ , "set (CMAKE_CXX_FLAGS ${CMAKE_CXX_FLAGS} \"-std=c++11 -DDEBUG\")"
192+ ]
pcc/Makefile.examplenew file+16
@@ -0,0 +1,16 @@
1+PCC := "../.cabal-sandbox/bin/pcc"
2+
3+MODULE_DIR="../../packages"
4+#MODULE_DIR="bower_components"
5+SOURCE_DIR="src"
6+
7+MODULES := $(shell find $(MODULE_DIR) -name '*.purs' | grep -v \/test\/ | grep -v \/example\/ | grep -v \/examples\/)
8+SOURCES := $(shell find $(SOURCE_DIR) -name '*.purs')
9+
10+all: main
11+
12+main:
13+ $(PCC) $(MODULES) $(SOURCES)
14+
15+clean:
16+ @rm -rf output/*
pcc/TestMain.hsnew file+140
@@ -0,0 +1,140 @@
1+-------------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) 2015 Andy Arvanitis and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+--
12+--
13+-------------------------------------------------------------------------------
14+module Main where
15+
16+import Data.List
17+import Control.Applicative
18+import Control.Monad
19+
20+import System.Process
21+import System.FilePath
22+import System.Directory
23+
24+-------------------------------------------------------------------------------
25+testsDir :: IO (FilePath, FilePath)
26+-------------------------------------------------------------------------------
27+testsDir = do
28+ baseDir <- getCurrentDirectory
29+ return (baseDir </> "pcc-tests", baseDir)
30+
31+-------------------------------------------------------------------------------
32+main :: IO ()
33+-------------------------------------------------------------------------------
34+main = do
35+
36+ (outputDir, baseDir) <- testsDir
37+
38+ outputDirExists <- doesDirectoryExist outputDir
39+ when outputDirExists $ removeDirectoryRecursive outputDir
40+ createDirectory outputDir
41+
42+ fetchPackages
43+
44+ let srcDir = outputDir </> "src"
45+ createDirectory srcDir
46+
47+ let buildDir = outputDir </> "build"
48+ createDirectory buildDir
49+
50+ let makefile = outputDir </> "Makefile"
51+ writeFile makefile makefileText
52+
53+ let passingDir = baseDir </> "examples" </> "passing"
54+ passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir
55+
56+ let tests = filter (`notElem` skipped) passingTestCases
57+
58+ -- Run the tests
59+ --
60+ forM_ tests $ \inputFile -> do
61+ --
62+ -- Compile PureScript file
63+ --
64+ putStrLn $ "Compiling test " ++ inputFile ++ " ..."
65+ setCurrentDirectory outputDir
66+ copyFile (passingDir </> inputFile) (srcDir </> inputFile)
67+ callProcess "make" ["clean", "main"]
68+ --
69+ -- Build and run C++ files
70+ --
71+ setCurrentDirectory buildDir
72+ callProcess "cmake" ["../output"]
73+ callProcess "make" ["-j2"]
74+ callProcess (buildDir </> "Main") []
75+
76+ removeFile (srcDir </> inputFile)
77+
78+ -- TODO: support failing test cases
79+ --
80+ -- let failing = baseDir </> "examples" </> "failing"
81+ -- failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
82+ --
83+
84+ setCurrentDirectory baseDir
85+ putStrLn "pcc-tests finished"
86+ putStrLn $ "Total tests available: " ++ show (length passingTestCases)
87+ putStrLn $ "Tests run: " ++ show (length tests)
88+ putStrLn $ "Tests skipped: " ++ show (length skipped)
89+
90+-------------------------------------------------------------------------------
91+repo :: String
92+-------------------------------------------------------------------------------
93+repo = "git://github.com/pure14/"
94+
95+-------------------------------------------------------------------------------
96+packages :: [(String, String)]
97+-------------------------------------------------------------------------------
98+packages =
99+ [ ("purescript-eff", "pure14-dictionary")
100+ , ("purescript-prelude", "pure14-dictionary")
101+ , ("purescript-assert", "pure14-dictionary")
102+ , ("purescript-st", "pure14-dictionary")
103+ , ("purescript-console", "pure14-dictionary")
104+ , ("purescript-functions", "pure14-dictionary")
105+ ]
106+
107+-------------------------------------------------------------------------------
108+fetchPackages :: IO ()
109+-------------------------------------------------------------------------------
110+fetchPackages = do
111+ (outputDir, baseDir) <- testsDir
112+ let packageDir = outputDir </> "packages"
113+ createDirectory packageDir
114+ setCurrentDirectory packageDir
115+ forM_ packages $ \package -> let branch = snd package in
116+ callProcess "git" $ ["clone"] ++ (if null branch then [] else ["--branch", branch]) ++ [repo ++ (fst package) ++ ".git"]
117+ setCurrentDirectory baseDir
118+
119+-------------------------------------------------------------------------------
120+makefileText :: String
121+-------------------------------------------------------------------------------
122+makefileText = intercalate "\n" lines'
123+ where lines' = [ "PCC := '../.cabal-sandbox/bin/pcc'"
124+ , "MODULE_DIR='packages'"
125+ , "SOURCE_DIR='src'"
126+ , "MODULES := $(shell find $(MODULE_DIR) -name '*.purs' | grep -v \\/test\\/ | grep -v \\/example\\/ | grep -v \\/examples\\/)"
127+ , "SOURCES := $(shell find $(SOURCE_DIR) -name '*.purs')"
128+ , "all: main"
129+ , "main:"
130+ , "\t$(PCC) $(MODULES) $(SOURCES)"
131+ , "clean:"
132+ , "\t@rm -rf output/*"
133+ ]
134+
135+-------------------------------------------------------------------------------
136+skipped :: [String]
137+-------------------------------------------------------------------------------
138+skipped =
139+ [ "ExplicitImportReExport.purs" -- OK, test has no main (would pass otherwise)
140+ ]
pcc/include/hash.hhnew file+42
@@ -0,0 +1,42 @@
1+///////////////////////////////////////////////////////////////////////////////
2+//
3+// Module : hash.hh
4+// Copyright : (c) Andy Arvanitis 2015
5+// License : MIT
6+//
7+// Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+// Stability : experimental
9+// Portability :
10+//
11+// Provides compile-time hashes for string literals.
12+//
13+///////////////////////////////////////////////////////////////////////////////
14+//
15+#ifndef PS_Hash_HH
16+#define PS_Hash_HH
17+
18+#include <cstdint>
19+
20+namespace PureScript {
21+
22+ // Hash function which uses an xor version of the djb2 algorithm
23+ //
24+ constexpr auto djb2(const char s[], const uint32_t hash = 5381) -> uint32_t {
25+ return !s[0] ? hash : djb2(s + 1, 33 * hash ^ s[0]);
26+ }
27+
28+ // Compile-time string literal hash
29+ //
30+ template <uint32_t H>
31+ struct _compile_time_hash_ {
32+ static constexpr long value = H;
33+ };
34+
35+ template <uint32_t H>
36+ constexpr long _compile_time_hash_<H>::value;
37+
38+ #define HASH(s) _compile_time_hash_<djb2(s)>::value
39+
40+} // namespace PureScript
41+
42+#endif // PS_Hash_HH
pcc/include/map_key.hhnew file+57
@@ -0,0 +1,57 @@
1+///////////////////////////////////////////////////////////////////////////////
2+//
3+// Module : map_key.hh
4+// Copyright : (c) Andy Arvanitis 2015
5+// License : MIT
6+//
7+// Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+// Stability : experimental
9+// Portability :
10+//
11+// Support for maps using keys with compile-time hashes.
12+//
13+///////////////////////////////////////////////////////////////////////////////
14+//
15+#ifndef PS_MapKey_HH
16+#define PS_MapKey_HH
17+
18+#include "hash.hh"
19+
20+namespace PureScript {
21+
22+ struct map_key_t {
23+
24+ const uint32_t hash;
25+
26+ explicit constexpr map_key_t(const uint32_t hash) : hash(hash) {}
27+
28+ class hasher {
29+ public:
30+ constexpr auto operator() (const map_key_t key) const -> size_t {
31+ return key.hash;
32+ }
33+ };
34+
35+ class equal {
36+ public:
37+ constexpr auto operator() (const map_key_t key1, const map_key_t key2) const -> bool {
38+ return key1.hash == key2.hash;
39+ }
40+ };
41+ };
42+
43+ // Compile-time map keys (from strings)
44+ //
45+ template <uint32_t H>
46+ struct _compile_time_key_ {
47+ static constexpr map_key_t value = map_key_t(H);
48+ };
49+
50+ template <uint32_t H>
51+ constexpr map_key_t _compile_time_key_<H>::value;
52+
53+ #define KEY(s) _compile_time_key_<djb2(s)>::value
54+
55+} // namespace PureScript
56+
57+#endif // PS_MapKey_HH
pcc/include/purescript.ccnew file+530
@@ -0,0 +1,530 @@
1+///////////////////////////////////////////////////////////////////////////////
2+//
3+// Module : purescript.cc
4+// Copyright : (c) Andy Arvanitis 2015
5+// License : MIT
6+//
7+// Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+// Stability : experimental
9+// Portability :
10+//
11+// Basic types and functions to support purescript-to-C++1x rendering
12+//
13+///////////////////////////////////////////////////////////////////////////////
14+//
15+#include "PureScript.hh"
16+
17+namespace PureScript {
18+
19+any::any(const any& val) : type(val.type) {
20+ switch (type) {
21+ case Type::Integer: i = val.i; break;
22+ case Type::Double: d = val.d; break;
23+ case Type::Character: c = val.c; break;
24+ case Type::Boolean: b = val.b; break;
25+ case Type::String: new (&s) shared_string (val.s); break;
26+ case Type::Map: new (&m) shared_map (val.m); break;
27+ case Type::Vector: new (&v) shared_vector (val.v); break;
28+ case Type::Function: new (&f) shared_fn (val.f); break;
29+ case Type::EffFunction: new (&e) shared_eff_fn (val.e); break;
30+ case Type::Thunk: new (&t) shared_thunk (val.t); break;
31+ case Type::Pointer: new (&p) shared_void_ptr (val.p); break;
32+
33+ default: assert(false && "Unsupported type in copy ctor");
34+ }
35+}
36+
37+void any::swap(any&& val) {
38+ type = val.type;
39+ switch (type) {
40+ case Type::Integer: i = val.i; break;
41+ case Type::Double: d = val.d; break;
42+ case Type::Character: c = val.c; break;
43+ case Type::Boolean: b = val.b; break;
44+ case Type::String: new (&s) shared_string (std::move(val.s)); break;
45+ case Type::Map: new (&m) shared_map (std::move(val.m)); break;
46+ case Type::Vector: new (&v) shared_vector (std::move(val.v)); break;
47+ case Type::Function: new (&f) shared_fn (std::move(val.f)); break;
48+ case Type::EffFunction: new (&e) shared_eff_fn (std::move(val.e)); break;
49+ case Type::Thunk: new (&t) shared_thunk (std::move(val.t)); break;
50+ case Type::Pointer: new (&p) shared_void_ptr (std::move(val.p)); break;
51+
52+ default: assert(false && "Unsupported type in move ctor");
53+ }
54+}
55+
56+any::~any() {
57+ // std::cout << "destroy" << std::endl;
58+ switch (type) {
59+ case Type::Integer: ; break;
60+ case Type::Double: ; break;
61+ case Type::Character: ; break;
62+ case Type::Boolean: ; break;
63+ case Type::String: s.~shared_string(); break;
64+ case Type::Map: m.~shared_map(); break;
65+ case Type::Vector: v.~shared_vector(); break;
66+ case Type::Function: f.~shared_fn(); break;
67+ case Type::EffFunction: e.~shared_eff_fn(); break;
68+ case Type::Thunk: t.~shared_thunk(); break;
69+ case Type::Pointer: p.~shared_void_ptr(); break;
70+
71+ default: assert(false && "Unsupported type in destructor");
72+ }
73+};
74+
75+ #define RETURN_VALUE(TYPE, VAL, FN) \
76+ if (type == TYPE) { \
77+ return FN(VAL); \
78+ } \
79+ const any* valuePtr = this; \
80+ do { \
81+ assert(valuePtr->type == Type::Thunk); \
82+ const any& value = (*valuePtr->t)(unthunk); \
83+ if (value.type == TYPE) { \
84+ return FN(value.VAL); \
85+ } \
86+ valuePtr = &value; \
87+ } while (valuePtr->type != Type::Unknown); \
88+ return FN(VAL);
89+
90+ template <typename T>
91+ auto any::cast() const -> typename std::enable_if<std::is_same<T, long>::value, T>::type {
92+ RETURN_VALUE(Type::Integer, i,)
93+ }
94+ template auto any::cast<long>() const -> long;
95+
96+ template <typename T>
97+ auto any::cast() const -> typename std::enable_if<std::is_same<T, double>::value, T>::type {
98+ RETURN_VALUE(Type::Double, d,)
99+ }
100+ template auto any::cast<double>() const -> double;
101+
102+ template <typename T>
103+ auto any::cast() const -> typename std::enable_if<std::is_same<T, char>::value, T>::type {
104+ RETURN_VALUE(Type::Character, c,)
105+ }
106+ template auto any::cast<char>() const -> char;
107+
108+ template <typename T>
109+ auto any::cast() const -> typename std::enable_if<std::is_same<T, bool>::value, T>::type {
110+ RETURN_VALUE(Type::Boolean, b,)
111+ }
112+ template auto any::cast<bool>() const -> bool;
113+
114+ template <typename T>
115+ auto any::cast() const -> typename std::enable_if<std::is_same<T, string>::value, const T&>::type {
116+ RETURN_VALUE(Type::String, s, *)
117+ }
118+ template auto any::cast<string>() const -> const string&;
119+
120+ template <typename T>
121+ auto any::cast() const -> typename std::enable_if<std::is_same<T, map>::value, const T&>::type {
122+ RETURN_VALUE(Type::Map, m, *)
123+ }
124+ template auto any::cast<any::map>() const -> const map&;
125+
126+ template <typename T>
127+ auto any::cast() const -> typename std::enable_if<std::is_same<T, vector>::value, const T&>::type {
128+ RETURN_VALUE(Type::Vector, v, *)
129+ }
130+ template auto any::cast<any::vector>() const -> const vector&;
131+
132+
133+ auto any::operator()(const any arg) const -> any {
134+ if (type == Type::Function) {
135+ return (*f)(arg);
136+ }
137+ const any* valuePtr = this;
138+ do {
139+ assert(valuePtr->type == Type::Thunk);
140+ const any& value = (*valuePtr->t)(unthunk);
141+ if (value.type == Type::Function) {
142+ return (*value.f)(arg);
143+ }
144+ valuePtr = &value;
145+ } while (valuePtr->type != Type::Unknown);
146+ return nullptr;
147+ }
148+
149+ auto any::operator()(const as_thunk) const -> const any& {
150+ assert(type == Type::Thunk);
151+ return (*t)(unthunk);
152+ }
153+
154+ auto any::call(const any& a) -> any {
155+ assert(a.type == Type::EffFunction || a.type == Type::Function);
156+ if (a.type == Type::EffFunction) {
157+ return (*a.e)();
158+ } else {
159+ return (*a.f)(false);
160+ }
161+ }
162+
163+ auto any::operator()() const -> any {
164+ if (type == Type::EffFunction || type == Type::Function) {
165+ return call(*this);
166+ }
167+ assert(type == Type::Thunk);
168+ const any* valuePtr = this;
169+ do {
170+ const any& value = (*valuePtr->t)(unthunk);
171+ if (value.type != Type::Thunk) {
172+ return call(value);
173+ }
174+ valuePtr = &value;
175+ } while (true);
176+ }
177+
178+ any::operator long() const {
179+ RETURN_VALUE(Type::Integer, i,)
180+ }
181+
182+ any::operator double() const {
183+ RETURN_VALUE(Type::Double, d,)
184+ }
185+
186+ any::operator bool() const {
187+ RETURN_VALUE(Type::Boolean, b,)
188+ }
189+
190+ any::operator const string&() const {
191+ RETURN_VALUE(Type::String, s, *)
192+ }
193+
194+ any::operator const map&() const {
195+ RETURN_VALUE(Type::Map, m, *)
196+ }
197+
198+ any::operator const vector&() const {
199+ RETURN_VALUE(Type::Vector, v, *)
200+ }
201+
202+ auto any::extractPointer() const -> const void* {
203+ RETURN_VALUE(Type::Pointer, p.get(),)
204+ }
205+
206+ auto any::extract_value(const any& a) -> const any& {
207+ if (a.type != Type::Thunk) {
208+ return a;
209+ }
210+ const any* valuePtr = &a;
211+ do {
212+ const any& value = (*valuePtr->t)(unthunk);
213+ if (value.type != Type::Thunk) {
214+ return value;
215+ }
216+ valuePtr = &value;
217+ } while (true);
218+ }
219+
220+ auto any::operator[](const map_key_t rhs) const -> const any& {
221+ RETURN_VALUE(Type::Map, m->at(rhs),)
222+ }
223+
224+ auto any::operator[](const vector::size_type rhs) const -> const any& {
225+ RETURN_VALUE(Type::Vector, v->at(rhs),)
226+ }
227+
228+ auto any::operator[](const any& rhs) const -> const any& {
229+ RETURN_VALUE(Type::Vector, v->at(rhs.cast<long>()),)
230+ }
231+
232+#define DEFINE_OPERATOR_LHS(K, T, OP, V, R, P) \
233+auto operator OP(const T lhs, const any& rhs_) -> R { \
234+ auto& rhs = any::extract_value(rhs_); \
235+ assert(rhs.type == any::Type::K); \
236+ return lhs OP P(rhs.V); \
237+}
238+
239+#define DEFINE_OPERATOR_RHS(K, T, OP, V, R, P) \
240+auto any::operator OP(const T rhs) const -> R { \
241+ auto& lhs = any::extract_value(*this); \
242+ assert(lhs.type == Type::K); \
243+ return P(lhs.V) OP rhs; \
244+}
245+
246+auto any::operator==(const any& rhs_) const -> bool {
247+ auto& lhs = extract_value(*this);
248+ auto& rhs = extract_value(rhs_);
249+ assert(lhs.type == rhs.type);
250+ switch (lhs.type) {
251+ case Type::Integer: return lhs.i == rhs.i;
252+ case Type::Double: return lhs.d == rhs.d;
253+ case Type::Character: return lhs.c == rhs.c;
254+ case Type::Boolean: return lhs.b == rhs.b;
255+ case Type::String: return (*lhs.s) == (*rhs.s);
256+ case Type::Pointer: return lhs.p == rhs.p;
257+ default: assert(false && "Unsupported type for '==' operator");
258+ }
259+ return false;
260+}
261+
262+DEFINE_OPERATOR_RHS(Integer, long, ==, i, bool,)
263+DEFINE_OPERATOR_RHS(Double, double, ==, d, bool,)
264+DEFINE_OPERATOR_RHS(Character, char, ==, c, bool,)
265+DEFINE_OPERATOR_RHS(Boolean, bool, ==, b, bool,)
266+DEFINE_OPERATOR_RHS(String, string&, ==, s, bool, *)
267+DEFINE_OPERATOR_RHS(String, char* const, ==, s, bool, *)
268+
269+auto any::operator!=(const any& rhs_) const -> bool {
270+ auto& lhs = extract_value(*this);
271+ auto& rhs = extract_value(rhs_);
272+ assert(lhs.type == rhs.type);
273+ switch (lhs.type) {
274+ case Type::Integer: return lhs.i != rhs.i;
275+ case Type::Double: return lhs.d != rhs.d;
276+ case Type::Character: return lhs.c != rhs.c;
277+ case Type::Boolean: return lhs.b != rhs.b;
278+ case Type::String: return (*lhs.s) != (*rhs.s);
279+ case Type::Pointer: return lhs.p != rhs.p;
280+ default: assert(false && "Unsupported type for '!=' operator");
281+ }
282+ return false;
283+}
284+
285+DEFINE_OPERATOR_RHS(Integer, long, !=, i, bool,)
286+DEFINE_OPERATOR_RHS(Double, double, !=, d, bool,)
287+DEFINE_OPERATOR_RHS(Character, char, !=, c, bool,)
288+DEFINE_OPERATOR_RHS(Boolean, bool, !=, b, bool,)
289+DEFINE_OPERATOR_RHS(String, string&, !=, s, bool, *)
290+DEFINE_OPERATOR_RHS(String, char* const, !=, s, bool, *)
291+
292+auto any::operator<(const any& rhs_) const -> bool {
293+ auto& lhs = extract_value(*this);
294+ auto& rhs = extract_value(rhs_);
295+ assert(lhs.type == rhs.type);
296+ switch (lhs.type) {
297+ case Type::Integer: return lhs.i < rhs.i;
298+ case Type::Double: return lhs.d < rhs.d;
299+ case Type::Character: return lhs.c < rhs.c;
300+ case Type::Boolean: return lhs.b < rhs.b;
301+ case Type::String: return (*lhs.s) < (*rhs.s);
302+ default: assert(false && "Unsupported type for '<' operator");
303+ }
304+ return false;
305+}
306+
307+DEFINE_OPERATOR_RHS(Integer, long, <, i, bool,)
308+DEFINE_OPERATOR_RHS(Double, double, <, d, bool,)
309+DEFINE_OPERATOR_RHS(Character, char, <, c, bool,)
310+DEFINE_OPERATOR_RHS(Boolean, bool, <, b, bool,)
311+DEFINE_OPERATOR_RHS(String, string&, <, s, bool, *)
312+DEFINE_OPERATOR_RHS(String, char* const, <, s, bool, *)
313+
314+auto any::operator<=(const any& rhs_) const -> bool {
315+ auto& lhs = extract_value(*this);
316+ auto& rhs = extract_value(rhs_);
317+ assert(lhs.type == rhs.type);
318+ switch (lhs.type) {
319+ case Type::Integer: return lhs.i <= rhs.i;
320+ case Type::Double: return lhs.d <= rhs.d;
321+ case Type::Character: return lhs.c <= rhs.c;
322+ case Type::Boolean: return lhs.b <= rhs.b;
323+ case Type::String: return (*lhs.s) <= (*rhs.s);
324+ default: assert(false && "Unsupported type for '<' operator");
325+ }
326+ return false;
327+}
328+
329+DEFINE_OPERATOR_RHS(Integer, long, <=, i, bool,)
330+DEFINE_OPERATOR_RHS(Double, double, <=, d, bool,)
331+DEFINE_OPERATOR_RHS(Character, char, <=, c, bool,)
332+DEFINE_OPERATOR_RHS(Boolean, bool, <=, b, bool,)
333+DEFINE_OPERATOR_RHS(String, string&, <=, s, bool, *)
334+DEFINE_OPERATOR_RHS(String, char* const, <=, s, bool, *)
335+
336+auto any::operator>(const any& rhs_) const -> bool {
337+ auto& lhs = extract_value(*this);
338+ auto& rhs = extract_value(rhs_);
339+ assert(lhs.type == rhs.type);
340+ switch (lhs.type) {
341+ case Type::Integer: return lhs.i > rhs.i;
342+ case Type::Double: return lhs.d > rhs.d;
343+ case Type::Character: return lhs.c > rhs.c;
344+ case Type::Boolean: return lhs.b > rhs.b;
345+ case Type::String: return (*lhs.s) > (*rhs.s);
346+ default: assert(false && "Unsupported type for '>' operator");
347+ }
348+ return false;
349+}
350+
351+DEFINE_OPERATOR_RHS(Integer, long, >, i, bool,)
352+DEFINE_OPERATOR_RHS(Double, double, >, d, bool,)
353+DEFINE_OPERATOR_RHS(Character, char, >, c, bool,)
354+DEFINE_OPERATOR_RHS(Boolean, bool, >, b, bool,)
355+DEFINE_OPERATOR_RHS(String, string&, >, s, bool, *)
356+DEFINE_OPERATOR_RHS(String, char* const, >, s, bool, *)
357+
358+auto any::operator>=(const any& rhs_) const -> bool {
359+ auto& lhs = extract_value(*this);
360+ auto& rhs = extract_value(rhs_);
361+ assert(lhs.type == rhs.type);
362+ switch (lhs.type) {
363+ case Type::Integer: return lhs.i >= rhs.i;
364+ case Type::Double: return lhs.d >= rhs.d;
365+ case Type::Character: return lhs.c >= rhs.c;
366+ case Type::Boolean: return lhs.b >= rhs.b;
367+ case Type::String: return (*lhs.s) >= (*rhs.s);
368+ default: assert(false && "Unsupported type for '>' operator");
369+ }
370+ return false;
371+}
372+
373+DEFINE_OPERATOR_RHS(Integer, long, >=, i, bool,)
374+DEFINE_OPERATOR_RHS(Double, double, >=, d, bool,)
375+DEFINE_OPERATOR_RHS(Character, char, >=, c, bool,)
376+DEFINE_OPERATOR_RHS(Boolean, bool, >=, b, bool,)
377+DEFINE_OPERATOR_RHS(String, string&, >=, s, bool, *)
378+DEFINE_OPERATOR_RHS(String, char* const, >=, s, bool, *)
379+
380+auto any::operator+(const any& rhs_) const -> any {
381+ auto& lhs = extract_value(*this);
382+ auto& rhs = extract_value(rhs_);
383+ assert(lhs.type == rhs.type);
384+ switch (lhs.type) {
385+ case Type::Integer: return lhs.i + rhs.i;
386+ case Type::Double: return lhs.d + rhs.d;
387+ case Type::Character: return any(char(lhs.c + rhs.c));
388+ case Type::String: return (*lhs.s) + (*rhs.s);
389+ default: assert(false && "Unsupported type for '+' operator");
390+ }
391+ return nullptr;
392+}
393+
394+DEFINE_OPERATOR_RHS(Integer, long, +, i, long,)
395+DEFINE_OPERATOR_RHS(Double, double, +, d, double,)
396+DEFINE_OPERATOR_RHS(Character, char, +, c, char,)
397+DEFINE_OPERATOR_RHS(String, string&, +, s, string, *)
398+DEFINE_OPERATOR_RHS(String, char* const, +, s, string, *)
399+
400+auto any::operator-(const any& rhs_) const -> any {
401+ auto& lhs = extract_value(*this);
402+ auto& rhs = extract_value(rhs_);
403+ assert(lhs.type == rhs.type);
404+ switch (lhs.type) {
405+ case Type::Integer: return lhs.i - rhs.i;
406+ case Type::Double: return lhs.d - rhs.d;
407+ case Type::Character: return any(char(lhs.c - rhs.c));
408+ default: assert(false && "Unsupported type for '-' binary operator");
409+ }
410+ return nullptr;
411+}
412+
413+DEFINE_OPERATOR_RHS(Integer, long, -, i, long,)
414+DEFINE_OPERATOR_RHS(Double, double, -, d, double,)
415+DEFINE_OPERATOR_RHS(Character, char, -, c, char,)
416+
417+auto any::operator*(const any& rhs_) const -> any {
418+ auto& lhs = extract_value(*this);
419+ auto& rhs = extract_value(rhs_);
420+ assert(lhs.type == rhs.type);
421+ switch (lhs.type) {
422+ case Type::Integer: return lhs.i * rhs.i;
423+ case Type::Double: return lhs.d * rhs.d;
424+ default: assert(false && "Unsupported type for '*' operator");
425+ }
426+ return nullptr;
427+}
428+
429+DEFINE_OPERATOR_RHS(Integer, long, *, i, long,)
430+DEFINE_OPERATOR_RHS(Double, double, *, d, double,)
431+
432+auto any::operator/(const any& rhs_) const -> any {
433+ auto& lhs = extract_value(*this);
434+ auto& rhs = extract_value(rhs_);
435+ assert(lhs.type == rhs.type);
436+ switch (lhs.type) {
437+ case Type::Integer: return lhs.i / rhs.i;
438+ case Type::Double: return lhs.d / rhs.d;
439+ default: assert(false && "Unsupported type for '/' operator");
440+ }
441+ return nullptr;
442+}
443+
444+DEFINE_OPERATOR_RHS(Integer, long, /, i, long,)
445+DEFINE_OPERATOR_RHS(Double, double, /, d, double,)
446+
447+auto any::operator%(const any& rhs_) const -> any {
448+ auto& lhs = extract_value(*this);
449+ auto& rhs = extract_value(rhs_);
450+ assert(lhs.type == rhs.type);
451+ switch (lhs.type) {
452+ case Type::Integer: return lhs.i % rhs.i;
453+ default: assert(false && "Unsupported type for '%' operator");
454+ }
455+ return nullptr;
456+}
457+
458+DEFINE_OPERATOR_RHS(Integer, long, %, i, long,)
459+
460+auto any::operator-() const -> any {
461+ auto& lhs = any::extract_value(*this);
462+ switch (lhs.type) {
463+ case Type::Integer: return (- lhs.i);
464+ case Type::Double: return (- lhs.d);
465+ default: assert(false && "Unsupported type for unary '-' operator");
466+ }
467+ return nullptr;
468+}
469+
470+DEFINE_OPERATOR_LHS(Integer, long, ==, i, bool,)
471+DEFINE_OPERATOR_LHS(Integer, long, !=, i, bool,)
472+DEFINE_OPERATOR_LHS(Integer, long, <, i, bool,)
473+DEFINE_OPERATOR_LHS(Integer, long, <=, i, bool,)
474+DEFINE_OPERATOR_LHS(Integer, long, >, i, bool,)
475+DEFINE_OPERATOR_LHS(Integer, long, >=, i, bool,)
476+
477+DEFINE_OPERATOR_LHS(Double, double, ==, d, bool,)
478+DEFINE_OPERATOR_LHS(Double, double, !=, d, bool,)
479+DEFINE_OPERATOR_LHS(Double, double, <, d, bool,)
480+DEFINE_OPERATOR_LHS(Double, double, <=, d, bool,)
481+DEFINE_OPERATOR_LHS(Double, double, >, d, bool,)
482+DEFINE_OPERATOR_LHS(Double, double, >=, d, bool,)
483+
484+DEFINE_OPERATOR_LHS(Character, char, ==, c, bool,)
485+DEFINE_OPERATOR_LHS(Character, char, !=, c, bool,)
486+DEFINE_OPERATOR_LHS(Character, char, <, c, bool,)
487+DEFINE_OPERATOR_LHS(Character, char, <=, c, bool,)
488+DEFINE_OPERATOR_LHS(Character, char, >, c, bool,)
489+DEFINE_OPERATOR_LHS(Character, char, >=, c, bool,)
490+
491+DEFINE_OPERATOR_LHS(Boolean, bool, ==, b, bool,)
492+DEFINE_OPERATOR_LHS(Boolean, bool, !=, b, bool,)
493+DEFINE_OPERATOR_LHS(Boolean, bool, <, b, bool,)
494+DEFINE_OPERATOR_LHS(Boolean, bool, <=, b, bool,)
495+DEFINE_OPERATOR_LHS(Boolean, bool, >, b, bool,)
496+DEFINE_OPERATOR_LHS(Boolean, bool, >=, b, bool,)
497+
498+DEFINE_OPERATOR_LHS(String, string&, ==, s, bool, *)
499+DEFINE_OPERATOR_LHS(String, string&, !=, s, bool, *)
500+DEFINE_OPERATOR_LHS(String, string&, <, s, bool, *)
501+DEFINE_OPERATOR_LHS(String, string&, <=, s, bool, *)
502+DEFINE_OPERATOR_LHS(String, string&, >, s, bool, *)
503+DEFINE_OPERATOR_LHS(String, string&, >=, s, bool, *)
504+
505+DEFINE_OPERATOR_LHS(String, char* const, ==, s, bool, *)
506+DEFINE_OPERATOR_LHS(String, char* const, !=, s, bool, *)
507+DEFINE_OPERATOR_LHS(String, char* const, <, s, bool, *)
508+DEFINE_OPERATOR_LHS(String, char* const, <=, s, bool, *)
509+DEFINE_OPERATOR_LHS(String, char* const, >, s, bool, *)
510+DEFINE_OPERATOR_LHS(String, char* const, >=, s, bool, *)
511+
512+DEFINE_OPERATOR_LHS(Integer, long, +, i, long,)
513+DEFINE_OPERATOR_LHS(Integer, long, -, i, long,)
514+DEFINE_OPERATOR_LHS(Integer, long, *, i, long,)
515+DEFINE_OPERATOR_LHS(Integer, long, /, i, long,)
516+DEFINE_OPERATOR_LHS(Integer, long, %, i, long,)
517+
518+DEFINE_OPERATOR_LHS(Double, double, +, d, double,)
519+DEFINE_OPERATOR_LHS(Double, double, -, d, double,)
520+DEFINE_OPERATOR_LHS(Double, double, *, d, double,)
521+DEFINE_OPERATOR_LHS(Double, double, /, d, double,)
522+
523+DEFINE_OPERATOR_LHS(Character, char, +, i, char,)
524+DEFINE_OPERATOR_LHS(Character, char, -, i, char,)
525+
526+DEFINE_OPERATOR_LHS(String, string&, +, s, string, *)
527+DEFINE_OPERATOR_LHS(String, char* const, +, s, string, *)
528+
529+
530+} // namespace PureScript
pcc/include/purescript.hhnew file+400
@@ -0,0 +1,400 @@
1+///////////////////////////////////////////////////////////////////////////////
2+//
3+// Module : purescript.hh
4+// Copyright : (c) Andy Arvanitis 2015
5+// License : MIT
6+//
7+// Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+// Stability : experimental
9+// Portability :
10+//
11+// Basic types and functions to support purescript-to-C++1x rendering
12+//
13+///////////////////////////////////////////////////////////////////////////////
14+//
15+#ifndef PureScript_HH
16+#define PureScript_HH
17+
18+// Standard includes
19+
20+#if defined(DEBUG)
21+ #include <cassert>
22+#else
23+ #define NDEBUG
24+ #undef assert
25+ #define assert(x)
26+#endif
27+
28+#include <memory>
29+#include <functional>
30+#include <string>
31+#include <vector>
32+#include <unordered_map>
33+#include <stdexcept>
34+
35+#include "map_key.hh"
36+#include "hash.hh"
37+
38+namespace PureScript {
39+
40+using string = std::string;
41+using runtime_error = std::runtime_error;
42+using nullptr_t = std::nullptr_t;
43+
44+// A variant data class designed to provide some features of dynamic typing.
45+//
46+class any {
47+
48+ public:
49+ enum class Type : std::int8_t {
50+ Unknown,
51+ Integer,
52+ Double,
53+ Character,
54+ Boolean,
55+ String,
56+ Map,
57+ Vector,
58+ Function,
59+ EffFunction,
60+ Thunk,
61+ Pointer
62+ };
63+
64+ Type type = Type::Unknown;
65+
66+ struct as_thunk {
67+ };
68+ static constexpr as_thunk unthunk = as_thunk{};
69+
70+ using map = std::unordered_map<map_key_t, const any, map_key_t::hasher, map_key_t::equal>;
71+ using vector = std::vector<any>;
72+ using fn = std::function<any(const any&)>;
73+ using eff_fn = std::function<any()>;
74+ using thunk = std::function<const any& (const as_thunk)>;
75+
76+ using shared_string = std::shared_ptr<string>;
77+ using shared_map = std::shared_ptr<map>;
78+ using shared_vector = std::shared_ptr<vector>;
79+
80+ using shared_fn = std::shared_ptr<fn>;
81+ using shared_eff_fn = std::shared_ptr<eff_fn>;
82+ using shared_thunk = std::shared_ptr<thunk>;
83+
84+ template <typename T>
85+ using shared = std::shared_ptr<T>;
86+
87+ using shared_void_ptr = std::shared_ptr<void>;
88+
89+ template <typename T>
90+ static constexpr auto make_shared(const T& arg) -> shared<T> {
91+ return std::make_shared<T>(arg);
92+ }
93+
94+ template <typename T>
95+ static constexpr auto make_shared(T&& arg) -> shared<T> {
96+ return std::make_shared<T>(std::move(arg));
97+ }
98+
99+ template <typename T, typename U>
100+ static constexpr auto static_cast_shared(U arg) -> T* {
101+ return static_cast<T*>(arg.get());
102+ }
103+
104+ private:
105+ union {
106+ long i;
107+ double d;
108+ char c;
109+ bool b;
110+ shared_string s;
111+ shared_map m;
112+ shared_vector v;
113+ shared_fn f;
114+ shared_eff_fn e;
115+ shared_thunk t;
116+ shared_void_ptr p;
117+ };
118+
119+ public:
120+
121+ any(const int val) : type(Type::Integer), i(val) {}
122+
123+ any(const long val) : type(Type::Integer), i(val) {}
124+
125+ any(const double val) : type(Type::Double), d(val) {}
126+
127+ any(const char val) : type(Type::Character), c(val) {}
128+
129+ any(const bool val) : type(Type::Boolean), b(val) {}
130+
131+ any(const string& val) : type(Type::String), s(make_shared<string>(val)) {}
132+ any(string&& val) : type(Type::String), s(make_shared<string>(std::move(val))) {}
133+
134+ any(const char val[]) : type(Type::String), s(make_shared<string>(val)) {}
135+
136+ any(const shared_string& val) : type(Type::String), s(val) {}
137+ any(shared_string&& val) : type(Type::String), s(std::move(val)) {}
138+
139+ any(const map& val) : type(Type::Map), m(make_shared<map>(val)) {}
140+ any(map&& val) : type(Type::Map), m(make_shared<map>(std::move(val))) {}
141+
142+ any(const shared_map& val) : type(Type::Map), m(val) {}
143+ any(shared_map&& val) : type(Type::Map), m(std::move(val)) {}
144+
145+ any(const vector& val) : type(Type::Vector), v(make_shared<vector>(val)) {}
146+ any(vector&& val) : type(Type::Vector), v(make_shared<vector>(std::move(val))) {}
147+
148+ any(const shared_vector& val) : type(Type::Vector), v(val) {}
149+ any(shared_vector&& val) : type(Type::Vector), v(std::move(val)) {}
150+
151+ any(const shared_fn& val) : type(Type::Function), f(val) {}
152+ any(shared_fn&& val) : type(Type::Function), f(std::move(val)) {}
153+
154+ template <typename T>
155+ any(const T& val, typename std::enable_if<std::is_assignable<fn,T>::value>::type* = 0)
156+ : type(Type::Function), f(make_shared<fn>(val)) {}
157+
158+ // template <typename T>
159+ // any(T&& val, typename std::enable_if<std::is_assignable<fn,T>::value>::type* = 0)
160+ // : type(Type::Function), f(std::move(val)) {}
161+
162+ any(const shared_eff_fn& val) : type(Type::EffFunction), e(val) {}
163+ any(shared_eff_fn&& val) : type(Type::EffFunction), e(std::move(val)) {}
164+
165+ template <typename T>
166+ any(const T& val, typename std::enable_if<std::is_assignable<eff_fn,T>::value>::type* = 0)
167+ : type(Type::EffFunction), e(make_shared<eff_fn>(val)) {}
168+
169+ any(const shared_thunk& val) : type(Type::Thunk), t(val) {}
170+ any(shared_thunk&& val) : type(Type::Thunk), t(std::move(val)) {}
171+
172+ template <typename T>
173+ any(const T& val, typename std::enable_if<std::is_assignable<thunk,T>::value>::type* = 0)
174+ : type(Type::Thunk), t(make_shared<thunk>(val)) {}
175+
176+ template <typename T>
177+ any(const T& val, typename std::enable_if<std::is_assignable<shared_void_ptr,T>::value>::type* = 0)
178+ : type(Type::Pointer), p(val) {}
179+
180+ any(std::nullptr_t) : type(Type::Pointer), p(nullptr) {}
181+
182+ template <typename T>
183+ any(T&& val, typename std::enable_if<std::is_assignable<shared_void_ptr,T>::value>::type* = 0)
184+ : type(Type::Pointer), p(std::move(val)) {}
185+
186+ any(const any&);
187+
188+ void swap(any&&);
189+
190+ any(any&& val) {
191+ swap(std::move(val));
192+ }
193+
194+ auto operator=(any val) -> any& {
195+ swap(std::move(val));
196+ return *this;
197+ }
198+
199+ any() = delete;
200+ ~any();
201+
202+ template <typename T>
203+ auto cast() const -> typename std::enable_if<std::is_same<T, long>::value, T>::type;
204+
205+ template <typename T>
206+ auto cast() const -> typename std::enable_if<std::is_same<T, double>::value, T>::type;
207+
208+ template <typename T>
209+ auto cast() const -> typename std::enable_if<std::is_same<T, char>::value, T>::type;
210+
211+ template <typename T>
212+ auto cast() const -> typename std::enable_if<std::is_same<T, bool>::value, T>::type;
213+
214+ template <typename T>
215+ auto cast() const -> typename std::enable_if<std::is_same<T, string>::value, const T&>::type;
216+
217+ template <typename T>
218+ auto cast() const -> typename std::enable_if<std::is_same<T, map>::value, const T&>::type;
219+
220+ template <typename T>
221+ auto cast() const -> typename std::enable_if<std::is_same<T, vector>::value, const T&>::type;
222+
223+ template <typename T>
224+ auto cast() const -> typename std::enable_if<std::is_assignable<shared_void_ptr,T>::value, typename T::element_type*>::type {
225+ if (type == Type::Pointer) {
226+ return static_cast_shared<typename T::element_type>(p);
227+ }
228+ const any* valuePtr = this;
229+ do {
230+ assert(valuePtr->type == Type::Thunk);
231+ const any& value = (*valuePtr->t)(unthunk);
232+ if (value.type == Type::Pointer) {
233+ return static_cast_shared<typename T::element_type>(value.p);
234+ }
235+ valuePtr = &value;
236+ } while (valuePtr->type != Type::Unknown);
237+ return nullptr;
238+ }
239+
240+ auto operator()(const any) const -> any;
241+
242+ auto operator()(const as_thunk) const -> const any&;
243+
244+ auto operator()() const -> any;
245+
246+ static auto call(const any& a) -> any;
247+
248+ explicit operator long() const;
249+ explicit operator double() const;
250+ explicit operator bool() const;
251+
252+ operator const string&() const;
253+ operator const map&() const;
254+ operator const vector&() const;
255+
256+ auto operator[](const map_key_t) const -> const any&;
257+ auto operator[](const vector::size_type) const -> const any&;
258+ auto operator[](const any&) const -> const any&;
259+
260+ auto extractPointer() const -> const void*;
261+
262+ static auto extract_value(const any&) -> const any&;
263+
264+ auto operator==(const any&) const -> bool;
265+ auto operator==(const long) const -> bool;
266+ auto operator==(const double) const -> bool;
267+ auto operator==(const char) const -> bool;
268+ auto operator==(const bool) const -> bool;
269+ auto operator==(const string&) const -> bool;
270+ auto operator==(const char * const) const -> bool;
271+
272+ auto operator!=(const any&) const -> bool;
273+ auto operator!=(const long) const -> bool;
274+ auto operator!=(const double) const -> bool;
275+ auto operator!=(const char) const -> bool;
276+ auto operator!=(const bool) const -> bool;
277+ auto operator!=(const string&) const -> bool;
278+ auto operator!=(const char * const) const -> bool;
279+
280+ auto operator<(const any&) const -> bool;
281+ auto operator<(const long) const -> bool;
282+ auto operator<(const double) const -> bool;
283+ auto operator<(const char) const -> bool;
284+ auto operator<(const bool) const -> bool;
285+ auto operator<(const string&) const -> bool;
286+ auto operator<(const char * const) const -> bool;
287+
288+ auto operator<=(const any&) const -> bool;
289+ auto operator<=(const long) const -> bool;
290+ auto operator<=(const double) const -> bool;
291+ auto operator<=(const char) const -> bool;
292+ auto operator<=(const bool) const -> bool;
293+ auto operator<=(const string&) const -> bool;
294+ auto operator<=(const char * const) const -> bool;
295+
296+ auto operator>(const any&) const -> bool;
297+ auto operator>(const long) const -> bool;
298+ auto operator>(const double) const -> bool;
299+ auto operator>(const char) const -> bool;
300+ auto operator>(const bool) const -> bool;
301+ auto operator>(const string&) const -> bool;
302+ auto operator>(const char * const) const -> bool;
303+
304+ auto operator>=(const any&) const -> bool;
305+ auto operator>=(const long) const -> bool;
306+ auto operator>=(const double) const -> bool;
307+ auto operator>=(const char) const -> bool;
308+ auto operator>=(const bool) const -> bool;
309+ auto operator>=(const string&) const -> bool;
310+ auto operator>=(const char * const) const -> bool;
311+
312+ auto operator+(const any&) const -> any;
313+ auto operator+(const long) const -> long;
314+ auto operator+(const double) const -> double;
315+ auto operator+(const char) const -> char;
316+ auto operator+(const string&) const -> string;
317+ auto operator+(const char * const) const -> string;
318+
319+ auto operator-(const any&) const -> any;
320+ auto operator-(const long) const -> long;
321+ auto operator-(const double) const -> double;
322+ auto operator-(const char) const -> char;
323+
324+ auto operator*(const any&) const -> any;
325+ auto operator*(const long) const -> long;
326+ auto operator*(const double) const -> double;
327+
328+ auto operator/(const any&) const -> any;
329+ auto operator/(const long) const -> long;
330+ auto operator/(const double) const -> double;
331+
332+ auto operator%(const any&) const -> any;
333+ auto operator%(const long) const -> long;
334+
335+ auto operator-() const -> any; // unary negate
336+
337+ friend auto operator==(const long, const any&) -> bool;
338+ friend auto operator!=(const long, const any&) -> bool;
339+ friend auto operator< (const long, const any&) -> bool;
340+ friend auto operator<=(const long, const any&) -> bool;
341+ friend auto operator> (const long, const any&) -> bool;
342+ friend auto operator>=(const long, const any&) -> bool;
343+
344+ friend auto operator==(const double, const any&) -> bool;
345+ friend auto operator!=(const double, const any&) -> bool;
346+ friend auto operator< (const double, const any&) -> bool;
347+ friend auto operator<=(const double, const any&) -> bool;
348+ friend auto operator> (const double, const any&) -> bool;
349+ friend auto operator>=(const double, const any&) -> bool;
350+
351+ friend auto operator==(const char, const any&) -> bool;
352+ friend auto operator!=(const char, const any&) -> bool;
353+ friend auto operator< (const char, const any&) -> bool;
354+ friend auto operator<=(const char, const any&) -> bool;
355+ friend auto operator> (const char, const any&) -> bool;
356+ friend auto operator>=(const char, const any&) -> bool;
357+
358+ friend auto operator==(const bool, const any&) -> bool;
359+ friend auto operator!=(const bool, const any&) -> bool;
360+ friend auto operator< (const bool, const any&) -> bool;
361+ friend auto operator<=(const bool, const any&) -> bool;
362+ friend auto operator> (const bool, const any&) -> bool;
363+ friend auto operator>=(const bool, const any&) -> bool;
364+
365+ friend auto operator==(const string&, const any&) -> bool;
366+ friend auto operator!=(const string&, const any&) -> bool;
367+ friend auto operator< (const string&, const any&) -> bool;
368+ friend auto operator<=(const string&, const any&) -> bool;
369+ friend auto operator> (const string&, const any&) -> bool;
370+ friend auto operator>=(const string&, const any&) -> bool;
371+
372+ friend auto operator==(const char* const, const any&) -> bool;
373+ friend auto operator!=(const char* const, const any&) -> bool;
374+ friend auto operator< (const char* const, const any&) -> bool;
375+ friend auto operator<=(const char* const, const any&) -> bool;
376+ friend auto operator> (const char* const, const any&) -> bool;
377+ friend auto operator>=(const char* const, const any&) -> bool;
378+
379+ friend auto operator+(const long, const any&) -> long;
380+ friend auto operator-(const long, const any&) -> long;
381+ friend auto operator*(const long, const any&) -> long;
382+ friend auto operator/(const long, const any&) -> long;
383+ friend auto operator%(const long, const any&) -> long;
384+
385+ friend auto operator+(const double, const any&) -> double;
386+ friend auto operator-(const double, const any&) -> double;
387+ friend auto operator*(const double, const any&) -> double;
388+ friend auto operator/(const double, const any&) -> double;
389+
390+ friend auto operator+(const char, const any&) -> char;
391+ friend auto operator-(const char, const any&) -> char;
392+
393+ friend auto operator+(const string&, const any&) -> string;
394+ friend auto operator+(const char* const, const any&) -> string;
395+
396+};
397+
398+} // namespace PureScript
399+
400+#endif // PureScript_HH
purescript.cabal+35
@@ -25,6 +25,7 @@ extra-source-files: examples/passing/*.purs
2525 , tests/support/bower.json
2626 , tests/support/setup-win.cmd
2727 , psci/tests/data/Sample.purs
28+ , pcc/include/*.hh
2829
2930source-repository head
3031 type: git
@@ -80,6 +81,21 @@ library
8081 Language.PureScript.CodeGen.JS.Optimizer.MagicDo
8182 Language.PureScript.CodeGen.JS.Optimizer.TCO
8283 Language.PureScript.CodeGen.JS.Optimizer.Unused
84+
85+ Language.PureScript.CodeGen.Cpp
86+ Language.PureScript.CodeGen.Cpp.AST
87+ Language.PureScript.CodeGen.Cpp.Common
88+ Language.PureScript.CodeGen.Cpp.File
89+ Language.PureScript.CodeGen.Cpp.Optimizer
90+ Language.PureScript.CodeGen.Cpp.Optimizer.Blocks
91+ Language.PureScript.CodeGen.Cpp.Optimizer.Common
92+ Language.PureScript.CodeGen.Cpp.Optimizer.Inliner
93+ Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo
94+ Language.PureScript.CodeGen.Cpp.Optimizer.TCO
95+ Language.PureScript.CodeGen.Cpp.Optimizer.Unused
96+ Language.PureScript.CodeGen.Cpp.Types
97+ Language.PureScript.Pretty.Cpp
98+
8399 Language.PureScript.Constants
84100 Language.PureScript.CoreFn
85101 Language.PureScript.CoreFn.Ann
@@ -241,6 +257,18 @@ executable psc-bundle
241257 ghc-options: -Wall -O2
242258 hs-source-dirs: psc-bundle
243259
260+executable pcc
261+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
262+ file-embed >= 0.0.7 && < 0.0.8,
263+ bytestring -any,
264+ mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
265+ time -any, transformers -any, transformers-compat -any
266+ main-is: Main.hs
267+ buildable: True
268+ hs-source-dirs: pcc
269+ other-modules:
270+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind
271+
244272test-suite tests
245273 build-depends: base >=4 && <5, containers -any, directory -any,
246274 filepath -any, mtl -any, parsec -any, purescript -any,
@@ -264,3 +292,10 @@ test-suite psci-tests
264292 buildable: True
265293 hs-source-dirs: psci psci/tests tests/common
266294 ghc-options: -Wall
295+
296+test-suite pcc-tests
297+ build-depends: base >=4 && <5, directory -any, filepath -any, process -any
298+ type: exitcode-stdio-1.0
299+ main-is: TestMain.hs
300+ buildable: True
301+ hs-source-dirs: pcc
src/Language/PureScript/CodeGen/Cpp.hsnew file+528
@@ -0,0 +1,528 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module generates code in the simplified C++1x intermediate representation from Purescript code
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GADTs #-}
17+{-# LANGUAGE ViewPatterns #-}
18+{-# LANGUAGE FlexibleContexts #-}
19+{-# LANGUAGE ScopedTypeVariables #-}
20+{-# LANGUAGE PatternGuards #-}
21+
22+module Language.PureScript.CodeGen.Cpp
23+ ( module AST
24+ , module Common
25+ , moduleToCpp
26+ , P.prettyPrintCpp
27+ ) where
28+
29+import Data.List
30+import Data.Function (on)
31+import qualified Data.Map as M
32+
33+import Control.Monad (forM, replicateM)
34+import Control.Monad.Reader (MonadReader)
35+import Control.Monad.Supply.Class
36+import Language.PureScript.AST.SourcePos
37+import Language.PureScript.CodeGen.Cpp.AST as AST
38+import Language.PureScript.CodeGen.Cpp.Common as Common
39+import Language.PureScript.CodeGen.Cpp.File
40+import Language.PureScript.CodeGen.Cpp.Optimizer
41+import Language.PureScript.CodeGen.Cpp.Optimizer.TCO
42+import Language.PureScript.CodeGen.Cpp.Types
43+import Language.PureScript.CoreFn
44+import Language.PureScript.Names
45+import Language.PureScript.Options
46+import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames)
47+import Language.PureScript.Traversals (sndM)
48+
49+import qualified Language.PureScript.Constants as C
50+import qualified Language.PureScript.Environment as E
51+import qualified Language.PureScript.Pretty.Cpp as P
52+import qualified Language.PureScript.Types as T
53+
54+-- import Debug.Trace
55+
56+-- |
57+-- Generate code in the simplified C++1x intermediate representation for all declarations in a
58+-- module.
59+--
60+---------------------------------------------------------------------------------------------------
61+moduleToCpp :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m)
62+ => E.Environment -> Module Ann -> m [Cpp]
63+---------------------------------------------------------------------------------------------------
64+moduleToCpp env (Module _ mn imps _ foreigns decls) = do
65+ cppImports <- traverse (pure . runModuleName) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
66+ let cppImports' = "PureScript" : cppImports
67+ cppDecls <- concat <$> mapM bindToCpp decls
68+ optimized <- traverse optimize cppDecls
69+ -- datas <- datasToCpps env mn
70+ synonyms <- synonymsToCpp env mn
71+ let moduleHeader = fileBegin mn "HH"
72+ ++ P.linebreak
73+ ++ ((\i -> CppInclude i i) <$> cppImports')
74+ ++ (if not (null foreigns)
75+ then [CppInclude [] (runModuleName mn ++ "_ffi")]
76+ else []
77+ )
78+ ++ P.linebreak
79+ ++ [CppNamespace (runModuleName mn) $
80+ (CppUseNamespace <$> cppImports') ++ P.linebreak
81+ ++ synonyms
82+ ++ toHeader optimized
83+ ++ toHeaderFns optimized
84+ ]
85+ ++ P.linebreak
86+ ++ fileEnd mn "HH"
87+ let bodyCpps = toBodyDecl optimized ++ toBody optimized
88+ moduleBody = CppInclude (runModuleName mn) (runModuleName mn) : P.linebreak
89+ ++ (if null bodyCpps
90+ then []
91+ else [CppNamespace (runModuleName mn) $
92+ (CppUseNamespace <$> cppImports') ++ P.linebreak ++ bodyCpps])
93+ ++ P.linebreak
94+ ++ (if isMain mn then [nativeMain] ++ P.linebreak else [])
95+ return $ moduleHeader ++ CppEndOfHeader : moduleBody
96+
97+ where
98+ -- |
99+ -- Generate code in the simplified C++1x intermediate representation for a declaration
100+ --
101+ -------------------------------------------------------------------------------------------------
102+ bindToCpp :: Bind Ann -> m [Cpp]
103+ -------------------------------------------------------------------------------------------------
104+ bindToCpp (NonRec ident val) = return <$> declToCpp [] ident val
105+ bindToCpp (Rec vals) = forM vals (uncurry $ declToCpp [CppRecursive])
106+
107+ -- |
108+ -- Desugar a declaration into a variable introduction or named function
109+ -- declaration.
110+ -------------------------------------------------------------------------------------------------
111+ declToCpp :: [CppValueQual] -> Ident -> Expr Ann -> m Cpp
112+ -------------------------------------------------------------------------------------------------
113+ declToCpp _ _ (Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
114+ return CppNoOp
115+
116+ declToCpp _ ident (Abs _ arg@(Ident "dict")
117+ body@(Accessor _ _ (Var _ (Qualified Nothing arg'))))
118+ | arg' == arg = do
119+ block <- asReturnBlock <$> valueToCpp body
120+ let fn' = CppFunction (identToCpp ident)
121+ [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]
122+ (Just $ CppAny [CppConst, CppRef])
123+ []
124+ block
125+ return fn'
126+
127+ declToCpp vqs ident (Abs (_, com, _, _) arg body) = do
128+ block <- asReturnBlock <$> valueToCpp body
129+ let block' = convertNestedLambdas block
130+ fn' = CppFunction (identToCpp ident) [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]
131+ (Just $ CppAny [])
132+ vqs
133+ block'
134+ return (CppComment com fn')
135+
136+ declToCpp _ ident (Constructor _ _ (ProperName _) fields) = return $
137+ CppFunction (identToCpp ident) (farg <$> f)
138+ (Just $ CppAny [])
139+ []
140+ (CppBlock (fieldLambdas fs))
141+ where
142+ name = qualifiedToStr (ModuleName []) id (Qualified (Just mn) ident)
143+ fields' = identToCpp <$> fields
144+ (f, fs) | (f' : fs') <- fields' = ([f'], fs')
145+ | otherwise = ([], [])
146+ farg = \x -> (x, Just $ CppAny [CppConst, CppRef])
147+ fieldLambdas flds
148+ | (f' : fs') <- flds = [CppReturn $ CppLambda [CppCaptureAll] (farg <$> [f'])
149+ (Just $ CppAny [])
150+ (CppBlock $ fieldLambdas fs')]
151+ | otherwise = [CppReturn (CppObjectLiteral ((ctorKey, CppStringLiteralHash name) : zip fields' (CppVar <$> fields')))]
152+
153+ declToCpp _ ident val = do
154+ val' <- valueToCpp val
155+ return $ CppVariableIntroduction (identToCpp ident, Just $ CppAny [CppConst]) [] (Just val')
156+
157+ -------------------------------------------------------------------------------------------------
158+ toLambda :: [CppCaptureType] -> Cpp -> Cpp
159+ -------------------------------------------------------------------------------------------------
160+ toLambda cs (CppFunction name args _ qs body) =
161+ CppVariableIntroduction (name, Just $ CppAny [CppConst])
162+ (filter (==CppStatic) qs)
163+ (Just (CppLambda cs' args (Just $ CppAny []) body))
164+ where
165+ cs' | (not . null) (qs `intersect` [CppInline, CppStatic]) = []
166+ | otherwise = cs
167+ toLambda cs (CppComment com cpp) = CppComment com (toLambda cs cpp)
168+ toLambda _ _ = error "Not a function!"
169+
170+ -------------------------------------------------------------------------------------------------
171+ asReturnBlock :: Cpp -> Cpp
172+ -------------------------------------------------------------------------------------------------
173+ asReturnBlock cpp = CppBlock [CppReturn cpp]
174+
175+ -------------------------------------------------------------------------------------------------
176+ convertNestedLambdas :: Cpp -> Cpp
177+ -------------------------------------------------------------------------------------------------
178+ convertNestedLambdas = everywhereOnCpp go
179+ where
180+ go :: Cpp -> Cpp
181+ go f@(CppFunction {}) = toLambda [CppCaptureAll] f
182+ go (CppLambda [] args rtyp body) = CppLambda [CppCaptureAll] args rtyp body
183+ go cpp = cpp
184+
185+ -------------------------------------------------------------------------------------------------
186+ convertRecursiveFns :: [Cpp] -> [Cpp]
187+ -------------------------------------------------------------------------------------------------
188+ convertRecursiveFns cpps
189+ | not $ null fns = dict : (accessor topdict <$> fns) ++ (everywhereOnCpp removeRec <$> cpps)
190+ where
191+ fns :: [(String, Cpp)]
192+ fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps
193+
194+ recursive :: Cpp -> [Cpp]
195+ recursive cpp'@(CppFunction _ _ _ qs _) | CppRecursive `elem` qs = [cpp']
196+ recursive _ = []
197+
198+ removeRec :: Cpp -> Cpp
199+ removeRec(CppFunction _ _ _ qs _) | CppRecursive `elem` qs = CppNoOp
200+ removeRec cpp' = cpp'
201+
202+ dict :: Cpp
203+ dict = CppVariableIntroduction (topdict, Just $ CppAny [CppConst]) []
204+ (Just $ CppObjectLiteral fns)
205+
206+ accessor :: String -> (String, Cpp) -> Cpp
207+ accessor dictname (name, _) = CppVariableIntroduction (name, Just $ CppAny [CppConst]) [] (Just accessed)
208+ where
209+ dict' = CppVar dictname
210+ accessed = CppApp (CppIndexer (CppStringLiteral name) dict') [dict']
211+
212+ toelem :: Cpp -> (String, Cpp)
213+ toelem (CppFunction name args rtyp _ (CppBlock body)) =
214+ (name, withdict $ CppLambda [CppCaptureAll] args rtyp (CppBlock $ (accessor localdict <$> fns) ++ body))
215+ toelem _ = error "not a function"
216+
217+ withdict :: Cpp -> Cpp
218+ withdict cpp' =
219+ CppLambda [CppCaptureAll] [(localdict, Just $ CppAny [CppConst, CppRef])]
220+ (Just $ CppAny [])
221+ (CppBlock [CppReturn cpp'])
222+ topdict :: String
223+ topdict = "__dict__"
224+ localdict :: String
225+ localdict = "_dict_"
226+
227+ convertRecursiveFns cpps = cpps
228+
229+ -- |
230+ -- Generate code in the simplified C++1x intermediate representation for a value or expression.
231+ --
232+ -------------------------------------------------------------------------------------------------
233+ valueToCpp :: Expr Ann -> m Cpp
234+ -------------------------------------------------------------------------------------------------
235+ valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) =
236+ return $ CppApp (CppVar $ qualifiedToStr' id ident) []
237+
238+ valueToCpp (Var (_, _, _, Just (IsConstructor _ _)) ident) =
239+ return . CppVar $ qualifiedToStr' id ident
240+
241+ valueToCpp (Var _ ident) =
242+ return $ varToCpp ident
243+
244+ valueToCpp (Literal _ (NumericLiteral n)) =
245+ return (CppNumericLiteral n)
246+
247+ valueToCpp (Literal _ (StringLiteral s)) =
248+ return (CppStringLiteral s)
249+
250+ valueToCpp (Literal _ (CharLiteral c)) =
251+ return (CppCharLiteral c)
252+
253+ valueToCpp (Literal _ (BooleanLiteral b)) =
254+ return (CppBooleanLiteral b)
255+
256+ valueToCpp (Literal _ (ArrayLiteral xs)) =
257+ CppArrayLiteral <$> mapM valueToCpp xs
258+
259+ valueToCpp (Literal _ (ObjectLiteral ps)) =
260+ CppObjectLiteral <$> sortBy (compare `on` fst) <$> mapM (sndM valueToCpp) ps
261+
262+ valueToCpp (Accessor _ prop val) =
263+ CppIndexer <$> pure (CppStringLiteral prop) <*> valueToCpp val
264+
265+ -- TODO: use a more efficient way of copying/updating the map?
266+ valueToCpp (ObjectUpdate (_, _, Just ty, _) obj ps) = do
267+ obj' <- valueToCpp obj
268+ updatedFields <- mapM (sndM valueToCpp) ps
269+ let origKeys = (allKeys ty) \\ (fst <$> updatedFields)
270+ origFields = (\key -> (key, CppIndexer (CppStringLiteral key) obj')) <$> origKeys
271+ return $ CppObjectLiteral . sortBy (compare `on` fst) $ origFields ++ updatedFields
272+ where
273+ allKeys :: T.Type -> [String]
274+ allKeys (T.TypeApp (T.TypeConstructor _) r@(T.RCons {})) = fst <$> (fst $ T.rowToList r)
275+ allKeys (T.ForAll _ t _) = allKeys t
276+ allKeys _ = error $ show "Not a recognized row type"
277+
278+ valueToCpp (ObjectUpdate _ _ _) = error $ "Bad Type in object update!"
279+
280+ valueToCpp (Abs _ arg body) = do
281+ cpp <- valueToCpp body
282+ let cpp' = convertNestedLambdas cpp
283+ return $ CppLambda [] [(identToCpp arg, Just $ CppAny [CppConst, CppRef])] (Just $ CppAny []) (asReturnBlock cpp')
284+
285+ -- valueToCpp (App _ e (Var _ (Qualified (Just (ModuleName [ProperName "Prim"])) (Ident "undefined")))) =
286+ -- valueToCpp e
287+
288+ valueToCpp e@App{} = do
289+ let (f, args) = unApp e []
290+ args' <- mapM valueToCpp args
291+ case f of
292+ Var (_, _, _, Just IsNewtype) _ -> return (head args')
293+ Var (_, _, _, Just IsTypeClassConstructor) (Qualified mn' (Ident classname)) ->
294+ let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname)) in
295+ return . CppObjectLiteral $ zip ((sort $ superClassDictionaryNames constraints) ++ (fst <$> fns)) args'
296+ _ -> -- TODO: verify this
297+ flip (foldl (\fn a -> CppApp fn [a])) args' <$> valueToCpp f
298+
299+ valueToCpp (Case (maybeSpan, _, ty, _) values binders) = do
300+ vals <- mapM valueToCpp values
301+ bindersToCpp maybeSpan ty binders vals
302+
303+ valueToCpp (Let _ ds val) = do
304+ ds' <- concat <$> mapM bindToCpp ds
305+ ret <- valueToCpp val
306+ let ds'' = tco defaultOptions <$> ds'
307+ let rs = if hasRecursion ds''
308+ then convertRecursiveFns ds''
309+ else ds''
310+ let cpps = convertNestedLambdas <$> rs
311+ return $ CppApp (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret]))) []
312+ where
313+ hasRecursion :: [Cpp] -> Bool
314+ hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'
315+ where
316+ fnames :: [String]
317+ fnames = concatMap (everythingOnCpp (++) fname) cpps'
318+
319+ fname :: Cpp -> [String]
320+ fname (CppFunction name _ _ _ _) = [name]
321+ fname _ = []
322+
323+ hasRecursiveRef :: Cpp -> Bool
324+ hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body
325+ hasRecursiveRef _ = False
326+
327+ ref :: Cpp -> Bool
328+ ref (CppVar name) | name `elem` fnames = True
329+ ref _ = False
330+
331+ valueToCpp Constructor{} = return CppNoOp
332+
333+ -- |
334+ -- Generate code in the simplified C++1x intermediate representation for a reference to a
335+ -- variable.
336+ --
337+ -------------------------------------------------------------------------------------------------
338+ varToCpp :: Qualified Ident -> Cpp
339+ -------------------------------------------------------------------------------------------------
340+ varToCpp (Qualified Nothing ident) = CppVar (identToCpp ident)
341+ varToCpp qual = qualifiedToCpp id qual
342+
343+ -- |
344+ -- Generate code in the simplified C++1x intermediate representation for pattern match binders
345+ -- and guards.
346+ --
347+ -------------------------------------------------------------------------------------------------
348+ bindersToCpp :: Maybe SourceSpan -> Maybe T.Type -> [CaseAlternative Ann] -> [Cpp] -> m Cpp
349+ -------------------------------------------------------------------------------------------------
350+ bindersToCpp maybeSpan _ binders vals = do
351+ valNames <- replicateM (length vals) freshName
352+ let assignments = zipWith mkVarDecl valNames (map Just vals)
353+ cpps <- forM binders $ \(CaseAlternative bs result) -> do
354+ ret <- guardsToCpp result
355+ go valNames ret bs
356+ return $ CppApp (CppLambda []
357+ []
358+ (Just $ CppAny [])
359+ (CppBlock (assignments ++ concat cpps ++ [failedPatternError valNames]))) []
360+ where
361+ mkVarDecl :: String -> Maybe Cpp -> Cpp
362+ mkVarDecl name = CppVariableIntroduction (name, Nothing) []
363+ go :: [String] -> [Cpp] -> [Binder Ann] -> m [Cpp]
364+ go _ done [] = return done
365+ go (v:vs) done' (b:bs) = do
366+ done'' <- go vs done' bs
367+ binderToCpp v done'' b
368+ go _ _ _ = error "Invalid arguments to bindersToCpp"
369+
370+ failedPatternError :: [String] -> Cpp
371+ failedPatternError _ =
372+ CppThrow $ CppApp (CppVar "runtime_error") [CppStringLiteral errorMessage]
373+
374+ errorMessage :: String
375+ errorMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
376+
377+ guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [Cpp]
378+ guardsToCpp (Left gs) = forM gs $ \(cond, val) -> do
379+ cond' <- valueToCpp cond
380+ done <- valueToCpp val
381+ return $ CppIfElse cond' (asReturnBlock done) Nothing
382+ guardsToCpp (Right v) = return . CppReturn <$> valueToCpp v
383+
384+ -- |
385+ -- Generate code in the simplified C++1x intermediate representation for a pattern match
386+ -- binder.
387+ --
388+ -------------------------------------------------------------------------------------------------
389+ binderToCpp :: String -> [Cpp] -> Binder Ann -> m [Cpp]
390+ -------------------------------------------------------------------------------------------------
391+ binderToCpp _ done (NullBinder{}) = return done
392+
393+ binderToCpp varName done (LiteralBinder _ l) =
394+ literalToBinderCpp varName done l
395+
396+ binderToCpp varName done (VarBinder _ ident) =
397+ return (CppVariableIntroduction (identToCpp ident, Just $ CppAny [CppConst]) [] (Just (CppVar varName)) : done)
398+
399+ binderToCpp varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
400+ binderToCpp varName done b
401+
402+ binderToCpp varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
403+ cpps <- go (zip fields bs) done
404+ let ctor' = qualifiedToStr (ModuleName []) (Ident . runProperName) ctor
405+ return $ case ctorType of
406+ ProductType -> cpps
407+ SumType ->
408+ [ CppIfElse (CppBinary Equal (CppIndexer (CppStringLiteral ctorKey) (CppVar varName))
409+ (CppStringLiteralHash ctor'))
410+ (CppBlock cpps)
411+ Nothing ]
412+ where
413+ go :: [(Ident, Binder Ann)] -> [Cpp] -> m [Cpp]
414+ go [] done' = return done'
415+ go ((field, binder) : remain) done' = do
416+ argVar <- freshName
417+ done'' <- go remain done'
418+ cpps <- binderToCpp argVar done'' binder
419+ return (CppVariableIntroduction (argVar, Nothing)
420+ []
421+ (Just (CppIndexer (CppStringLiteral $ identToCpp field) (CppVar varName)))
422+ : cpps)
423+
424+ binderToCpp _ _ b@(ConstructorBinder{}) =
425+ error $ "Invalid ConstructorBinder in binderToCpp: " ++ show b
426+
427+ binderToCpp varName done (NamedBinder _ ident binder) = do
428+ cpp <- binderToCpp varName done binder
429+ return (CppVariableIntroduction (identToCpp ident, Just $ CppAny [CppConst]) [] (Just (CppVar varName)) : cpp)
430+
431+ -------------------------------------------------------------------------------------------------
432+ literalToBinderCpp :: String -> [Cpp] -> Literal (Binder Ann) -> m [Cpp]
433+ -------------------------------------------------------------------------------------------------
434+ literalToBinderCpp varName done (NumericLiteral num) =
435+ return [CppIfElse (CppBinary Equal (CppVar varName) (CppNumericLiteral num)) (CppBlock done) Nothing]
436+
437+ literalToBinderCpp varName done (CharLiteral c) =
438+ return [CppIfElse (CppBinary Equal (CppCast charType $ CppVar varName)
439+ (CppCharLiteral c))
440+ (CppBlock done)
441+ Nothing]
442+
443+ literalToBinderCpp varName done (StringLiteral str) =
444+ return [CppIfElse (CppBinary Equal (CppCast stringType $ CppVar varName)
445+ (CppStringLiteral str))
446+ (CppBlock done)
447+ Nothing]
448+
449+ literalToBinderCpp varName done (BooleanLiteral True) =
450+ return [CppIfElse (CppVar varName) (CppBlock done) Nothing]
451+
452+ literalToBinderCpp varName done (BooleanLiteral False) =
453+ return [CppIfElse (CppUnary CppNot (CppVar varName)) (CppBlock done) Nothing]
454+
455+ literalToBinderCpp varName done (ObjectLiteral bs) = go done bs
456+ where
457+ go :: [Cpp] -> [(String, Binder Ann)] -> m [Cpp]
458+ go done' [] = return done'
459+ go done' ((prop, binder):bs') = do
460+ propVar <- freshName
461+ done'' <- go done' bs'
462+ cpp <- binderToCpp propVar done'' binder
463+ return (CppVariableIntroduction (propVar, Nothing)
464+ []
465+ (Just (CppIndexer (CppStringLiteral prop) (CppVar varName)))
466+ : cpp)
467+
468+ literalToBinderCpp varName done (ArrayLiteral bs) = do
469+ cpp <- go done 0 bs
470+ let cond = case length bs of
471+ 0 -> CppBinary Dot (CppCast arrayType $ CppVar varName)
472+ (CppApp (CppVar "empty") [])
473+ n -> let var = CppCast arrayType $ CppVar varName in
474+ CppBinary Equal (CppBinary Dot var (CppApp (CppVar "size") []))
475+ (CppNumericLiteral (Left (fromIntegral n)))
476+ return [ CppIfElse cond (CppBlock cpp) Nothing ]
477+ where
478+ go :: [Cpp] -> Integer -> [Binder Ann] -> m [Cpp]
479+ go done' _ [] = return done'
480+ go done' index (binder:bs') = do
481+ elVar <- freshName
482+ done'' <- go done' (index + 1) bs'
483+ cpp <- binderToCpp elVar done'' binder
484+ return (CppVariableIntroduction (elVar, Nothing) []
485+ (Just (CppIndexer (CppNumericLiteral (Left index)) (CppVar varName))) : cpp)
486+
487+ -------------------------------------------------------------------------------------------------
488+
489+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
490+ unApp (App _ val arg) args = unApp val (arg : args)
491+ unApp other args = (other, args)
492+
493+ qualifiedToCpp :: (a -> Ident) -> Qualified a -> Cpp
494+ qualifiedToCpp f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = CppVar . runIdent $ f a
495+ qualifiedToCpp f (Qualified (Just mn') a)
496+ | mn /= mn' = CppAccessor (CppVar . identToCpp $ f a) (CppVar (moduleNameToCpp mn'))
497+ qualifiedToCpp f (Qualified _ a) = CppVar $ identToCpp (f a)
498+
499+ qualifiedToStr' :: (a -> Ident) -> Qualified a -> String
500+ qualifiedToStr' = qualifiedToStr mn
501+
502+ -- |
503+ -- Find a class in scope by name, retrieving its list of constraints, function names and types.
504+ --
505+ findClass :: Qualified ProperName -> Maybe ([String], [T.Constraint], [(String, T.Type)])
506+ findClass name
507+ | Just (params, fns, constraints) <- M.lookup name (E.typeClasses env),
508+ fns' <- (\(i,t) -> (runIdent i, t)) <$> fns
509+ = Just (fst <$> params, constraints, (sortBy (compare `on` normalizedName . fst) fns'))
510+ findClass _ = Nothing
511+
512+-------------------------------------------------------------------------------------------------
513+synonymsToCpp :: Monad m => E.Environment -> ModuleName -> m [Cpp]
514+-------------------------------------------------------------------------------------------------
515+synonymsToCpp env mn
516+ | tcs <- E.typeClasses env,
517+ ds@(_:_) <- M.toList
518+ . M.filterWithKey (\k@(Qualified mn' _) _ -> mn' == Just mn && M.lookup k tcs == Nothing)
519+ $ E.typeSynonyms env = do
520+ let names' = qualifiedToStr mn (Ident . runProperName) . fst <$> ds
521+ typs = replicate (length ds) (CppAny [])
522+ syns = zip names' typs
523+ cpps = toTypeAlias <$> syns
524+ return $ cpps
525+ | otherwise = return []
526+ where
527+ toTypeAlias :: (String, CppType) -> Cpp
528+ toTypeAlias (n, t) = CppTypeAlias (n, []) t []
src/Language/PureScript/CodeGen/Cpp/AST.hsnew file+352
@@ -0,0 +1,352 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp.AST
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for the intermediate simplified-C++11 AST
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+{-# LANGUAGE CPP #-}
18+
19+module Language.PureScript.CodeGen.Cpp.AST where
20+
21+#if __GLASGOW_HASKELL__ < 710
22+import Control.Applicative (Applicative, (<$>), (<*>))
23+import Data.Traversable (traverse)
24+#endif
25+import Control.Monad.Identity
26+import Data.Data
27+import Language.PureScript.Comments
28+import Language.PureScript.CodeGen.Cpp.Types
29+import Language.PureScript.Traversals
30+
31+-- |
32+-- Built-in unary operators
33+--
34+data CppUnaryOp
35+ -- |
36+ -- Numeric negation
37+ --
38+ = CppNegate
39+ -- |
40+ -- Boolean negation
41+ --
42+ | CppNot
43+ -- |
44+ -- Bitwise negation
45+ --
46+ | CppBitwiseNot
47+ -- |
48+ -- Numeric unary \'plus\'
49+ --
50+ | CppPositive
51+ -- |
52+ -- Constructor
53+ --
54+ | CppNew deriving (Show, Eq, Data, Typeable)
55+
56+-- |
57+-- Built-in binary operators
58+--
59+data BinaryOp
60+ -- |
61+ -- Numeric addition
62+ --
63+ = Add
64+ -- |
65+ -- Numeric subtraction
66+ --
67+ | Subtract
68+ -- |
69+ -- Numeric multiplication
70+ --
71+ | Multiply
72+ -- |
73+ -- Numeric division
74+ --
75+ | Divide
76+ -- |
77+ -- Remainder
78+ --
79+ | Modulus
80+ -- |
81+ -- TODO: revisit this
82+ --
83+ | Dot
84+ -- |
85+ -- Generic equality test
86+ --
87+ | Equal
88+ -- |
89+ -- Generic inequality test
90+ --
91+ | NotEqual
92+ -- |
93+ -- Numeric less-than
94+ --
95+ | LessThan
96+ -- |
97+ -- Numeric less-than-or-equal
98+ --
99+ | LessThanOrEqual
100+ -- |
101+ -- Numeric greater-than
102+ --
103+ | GreaterThan
104+ -- |
105+ -- Numeric greater-than-or-equal
106+ --
107+ | GreaterThanOrEqual
108+ -- |
109+ -- Boolean and
110+ --
111+ | And
112+ -- |
113+ -- Boolean or
114+ --
115+ | Or
116+ -- |
117+ -- Bitwise and
118+ --
119+ | BitwiseAnd
120+ -- |
121+ -- Bitwise or
122+ --
123+ | BitwiseOr
124+ -- |
125+ -- Bitwise xor
126+ --
127+ | BitwiseXor
128+ -- |
129+ -- Bitwise left shift
130+ --
131+ | ShiftLeft
132+ -- |
133+ -- Bitwise right shift
134+ --
135+ | ShiftRight
136+ --
137+ deriving (Show, Eq, Data, Typeable)
138+
139+-- |
140+-- Data type for simplified C++11 expressions
141+--
142+data Cpp
143+ -- |
144+ -- A numeric literal
145+ --
146+ = CppNumericLiteral (Either Integer Double)
147+ -- |
148+ -- A string literal
149+ --
150+ | CppStringLiteral String
151+ -- |
152+ -- A character literal
153+ --
154+ | CppCharLiteral Char
155+ -- |
156+ -- A boolean literal
157+ --
158+ | CppBooleanLiteral Bool
159+ -- |
160+ -- A unary operator application
161+ --
162+ | CppUnary CppUnaryOp Cpp
163+ -- |
164+ -- A binary operator application
165+ --
166+ | CppBinary BinaryOp Cpp Cpp
167+ -- |
168+ -- An array literal
169+ --
170+ | CppArrayLiteral [Cpp]
171+ -- |
172+ -- An array indexer expression
173+ --
174+ | CppIndexer Cpp Cpp
175+ -- |
176+ -- An object literal
177+ --
178+ | CppObjectLiteral [(String, Cpp)]
179+ -- |
180+ -- An general property accessor expression (optional type, property, expr)
181+ --
182+ | CppAccessor Cpp Cpp
183+ -- |
184+ -- A function introduction (name, arguments, return type, qualifiers, body)
185+ --
186+ | CppFunction String [(String, Maybe CppType)] (Maybe CppType) [CppValueQual] Cpp
187+ -- |
188+ -- A lambda introduction (arguments, return type, body)
189+ --
190+ | CppLambda [CppCaptureType] [(String, Maybe CppType)] (Maybe CppType) Cpp
191+ -- |
192+ -- Value type cast
193+ --
194+ | CppCast CppType Cpp
195+ -- |
196+ -- Function application
197+ --
198+ | CppApp Cpp [Cpp]
199+ -- |
200+ -- Variable
201+ --
202+ | CppVar String
203+ -- |
204+ -- A block of expressions in braces
205+ --
206+ | CppBlock [Cpp]
207+ -- |
208+ -- A C++ namespace
209+ --
210+ | CppNamespace String [Cpp]
211+ -- |
212+ -- A C++ #include
213+ --
214+ | CppInclude String String
215+ -- |
216+ -- A C++ using namespace declaration
217+ --
218+ | CppUseNamespace String
219+ -- |
220+ -- Type alias, e.g. "using T = U" (new name and template types, original type)
221+ --
222+ | CppTypeAlias (String,[(String, Int)]) CppType String
223+ -- |
224+ -- A variable introduction and optional initialization
225+ --
226+ | CppVariableIntroduction (String, Maybe CppType) [CppValueQual] (Maybe Cpp)
227+ -- |
228+ -- A variable assignment
229+ --
230+ | CppAssignment Cpp Cpp
231+ -- |
232+ -- While loop
233+ --
234+ | CppWhile Cpp Cpp
235+ -- |
236+ -- If-then-else statement
237+ --
238+ | CppIfElse Cpp Cpp (Maybe Cpp)
239+ -- |
240+ -- Return statement
241+ --
242+ | CppReturn Cpp
243+ -- |
244+ -- Throw statement
245+ --
246+ | CppThrow Cpp
247+ -- |
248+ -- Continue statement
249+ --
250+ | CppContinue
251+ -- |
252+ -- A string literal compile-time hash
253+ --
254+ | CppStringLiteralHash String
255+ -- |
256+ -- Empty statement/expression
257+ --
258+ | CppNoOp
259+ -- |
260+ -- Marker for header/source split
261+ --
262+ | CppEndOfHeader
263+ -- |
264+ -- Raw C++11 (generated when parsing fails for an inline foreign import declaration)
265+ --
266+ | CppRaw String
267+ -- |
268+ -- Commented C++11
269+ --
270+ | CppComment [Comment] Cpp deriving (Show, Eq, Data, Typeable)
271+
272+--
273+-- Traversals
274+--
275+
276+everywhereOnCpp :: (Cpp -> Cpp) -> Cpp -> Cpp
277+everywhereOnCpp f = go
278+ where
279+ go :: Cpp -> Cpp
280+ go (CppUnary op j) = f (CppUnary op (go j))
281+ go (CppBinary op j1 j2) = f (CppBinary op (go j1) (go j2))
282+ go (CppArrayLiteral cpp) = f (CppArrayLiteral (map go cpp))
283+ go (CppIndexer j1 j2) = f (CppIndexer (go j1) (go j2))
284+ go (CppObjectLiteral cpp) = f (CppObjectLiteral (map (fmap go) cpp))
285+ go (CppAccessor prop j) = f (CppAccessor (go prop) (go j))
286+ go (CppFunction name args rty qs j) = f (CppFunction name args rty qs (go j))
287+ go (CppLambda cps args rty j) = f (CppLambda cps args rty (go j))
288+ go (CppCast t cpp) = f (CppCast t (go cpp))
289+ go (CppApp j cpp) = f (CppApp (go j) (map go cpp))
290+ go (CppBlock cpp) = f (CppBlock (map go cpp))
291+ go (CppNamespace name cpp) = f (CppNamespace name (map go cpp))
292+ go (CppVariableIntroduction name qs j) = f (CppVariableIntroduction name qs (fmap go j))
293+ go (CppAssignment j1 j2) = f (CppAssignment (go j1) (go j2))
294+ go (CppWhile j1 j2) = f (CppWhile (go j1) (go j2))
295+ go (CppIfElse j1 j2 j3) = f (CppIfElse (go j1) (go j2) (fmap go j3))
296+ go (CppReturn cpp) = f (CppReturn (go cpp))
297+ go (CppThrow cpp) = f (CppThrow (go cpp))
298+ go (CppComment com j) = f (CppComment com (go j))
299+ go other = f other
300+
301+everywhereOnCppTopDown :: (Cpp -> Cpp) -> Cpp -> Cpp
302+everywhereOnCppTopDown f = runIdentity . everywhereOnCppTopDownM (Identity . f)
303+
304+everywhereOnCppTopDownM :: (Applicative m, Monad m) => (Cpp -> m Cpp) -> Cpp -> m Cpp
305+everywhereOnCppTopDownM f = f >=> go
306+ where
307+ f' = f >=> go
308+ go (CppUnary op j) = CppUnary op <$> f' j
309+ go (CppBinary op j1 j2) = CppBinary op <$> f' j1 <*> f' j2
310+ go (CppArrayLiteral cpp) = CppArrayLiteral <$> traverse f' cpp
311+ go (CppIndexer j1 j2) = CppIndexer <$> f' j1 <*> f' j2
312+ go (CppObjectLiteral cpp) = CppObjectLiteral <$> traverse (sndM f') cpp
313+ go (CppAccessor prop j) = CppAccessor prop <$> f' j
314+ go (CppFunction name args rty qs j) = CppFunction name args rty qs <$> f' j
315+ go (CppLambda cps args rty j) = CppLambda cps args rty <$> f' j
316+ go (CppCast t cpp) = CppCast t <$> f' cpp
317+ go (CppApp j cpp) = CppApp <$> f' j <*> traverse f' cpp
318+ go (CppBlock cpp) = CppBlock <$> traverse f' cpp
319+ go (CppNamespace name cpp) = CppNamespace name <$> traverse f' cpp
320+ go (CppVariableIntroduction name qs j) = CppVariableIntroduction name qs <$> traverse f' j
321+ go (CppAssignment j1 j2) = CppAssignment <$> f' j1 <*> f' j2
322+ go (CppWhile j1 j2) = CppWhile <$> f' j1 <*> f' j2
323+ go (CppIfElse j1 j2 j3) = CppIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3
324+ go (CppReturn j) = CppReturn <$> f' j
325+ go (CppThrow j) = CppThrow <$> f' j
326+ go (CppComment com j) = CppComment com <$> f' j
327+ go other = f other
328+
329+everythingOnCpp :: (r -> r -> r) -> (Cpp -> r) -> Cpp -> r
330+everythingOnCpp (<>) f = go
331+ where
332+ go j@(CppUnary _ j1) = f j <> go j1
333+ go j@(CppBinary _ j1 j2) = f j <> go j1 <> go j2
334+ go j@(CppArrayLiteral cpp) = foldl (<>) (f j) (map go cpp)
335+ go j@(CppIndexer j1 j2) = f j <> go j1 <> go j2
336+ go j@(CppObjectLiteral cpp) = foldl (<>) (f j) (map (go . snd) cpp)
337+ go j@(CppAccessor j1 j2) = f j <> go j1 <> go j2
338+ go j@(CppFunction _ _ _ _ j1) = f j <> go j1
339+ go j@(CppLambda _ _ _ j1) = f j <> go j1
340+ go j@(CppCast _ cpp) = f j <> go cpp
341+ go j@(CppApp j1 cpp) = foldl (<>) (f j <> go j1) (map go cpp)
342+ go j@(CppBlock cpp) = foldl (<>) (f j) (map go cpp)
343+ go j@(CppNamespace _ cpp) = foldl (<>) (f j) (map go cpp)
344+ go j@(CppVariableIntroduction _ _ (Just j1)) = f j <> go j1
345+ go j@(CppAssignment j1 j2) = f j <> go j1 <> go j2
346+ go j@(CppWhile j1 j2) = f j <> go j1 <> go j2
347+ go j@(CppIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
348+ go j@(CppIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
349+ go j@(CppReturn j1) = f j <> go j1
350+ go j@(CppThrow j1) = f j <> go j1
351+ go j@(CppComment _ j1) = f j <> go j1
352+ go other = f other
src/Language/PureScript/CodeGen/Cpp/Common.hsnew file+205
@@ -0,0 +1,205 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Common
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Common code generation utility functions
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE PatternGuards #-}
17+
18+module Language.PureScript.CodeGen.Cpp.Common where
19+
20+import Data.Char
21+import Data.List (intercalate)
22+
23+import Language.PureScript.Names
24+
25+-- |
26+-- Convert an Ident into a valid C++11 identifier:
27+--
28+-- * Alphanumeric characters are kept unmodified.
29+--
30+-- * Reserved C++11 identifiers are wrapped with '_'
31+--
32+-- * Symbols are wrapped with '_' between a symbol name or their ordinal value.
33+--
34+identToCpp :: Ident -> String
35+identToCpp (Ident name) | nameIsCppReserved name = '_' : name ++ "_"
36+identToCpp (Ident name) = concatMap identCharToString name
37+identToCpp (Op op) = concatMap identCharToString op
38+
39+-- |
40+-- Test if a string is a valid Cpp identifier without escaping.
41+--
42+identNeedsEscaping :: String -> Bool
43+identNeedsEscaping s = s /= identToCpp (Ident s)
44+
45+-- |
46+-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
47+-- ordinal value.
48+--
49+identCharToString :: Char -> String
50+identCharToString c | isAlphaNum c = [c]
51+identCharToString '_' = "_"
52+identCharToString '.' = "_dot_"
53+identCharToString '$' = "_dollar_"
54+identCharToString '~' = "_tilde_"
55+identCharToString '=' = "_eq_"
56+identCharToString '<' = "_less_"
57+identCharToString '>' = "_greater_"
58+identCharToString '!' = "_bang_"
59+identCharToString '#' = "_hash_"
60+identCharToString '%' = "_percent_"
61+identCharToString '^' = "_up_"
62+identCharToString '&' = "_amp_"
63+identCharToString '|' = "_bar_"
64+identCharToString '*' = "_times_"
65+identCharToString '/' = "_div_"
66+identCharToString '+' = "_plus_"
67+identCharToString '-' = "_minus_"
68+identCharToString ':' = "_colon_"
69+identCharToString '\\' = "_bslash_"
70+identCharToString '?' = "_qmark_"
71+identCharToString '@' = "_at_"
72+identCharToString '\'' = "_prime_"
73+identCharToString c = '_' : show (ord c) ++ "_"
74+
75+-- |
76+-- Checks whether an identifier name is reserved in C++11.
77+--
78+nameIsCppReserved :: String -> Bool
79+nameIsCppReserved name =
80+ name `elem` [ "alignas"
81+ , "alignof"
82+ , "and"
83+ , "and_eq"
84+ , "any"
85+ , "asm"
86+ , "assert"
87+ , "auto"
88+ , "bitand"
89+ , "bitor"
90+ , "bool"
91+ , "boost"
92+ , "break"
93+ , "case"
94+ , "cast"
95+ , "catch"
96+ , "char"
97+ , "char16_t"
98+ , "char32_t"
99+ , "class"
100+ , "compl"
101+ , "concept"
102+ , "const"
103+ , "constexpr"
104+ , "const_cast"
105+ , "continue"
106+ , "decltype"
107+ , "default"
108+ , "delete"
109+ , "djb2"
110+ , "do"
111+ , "double"
112+ , "dynamic_cast"
113+ , "else"
114+ , "enum"
115+ , "explicit"
116+ , "export"
117+ , "extern"
118+ , "false"
119+ , "final"
120+ , "float"
121+ , "for"
122+ , "friend"
123+ , "goto"
124+ , "HASH"
125+ , "if"
126+ , "import"
127+ , "inline"
128+ , "int"
129+ , "KEY"
130+ , "list"
131+ , "long"
132+ , "map_key_t"
133+ , "mutable"
134+ , "namespace"
135+ , "new"
136+ , "nil"
137+ , "noexcept"
138+ , "not"
139+ , "not_eq"
140+ , "NULL"
141+ , "null"
142+ , "nullptr"
143+ , "nullptr_t"
144+ , "operator"
145+ , "or"
146+ , "or_eq"
147+ , "override"
148+ , "param"
149+ , "private"
150+ , "protected"
151+ , "public"
152+ , "PureScript"
153+ , "register"
154+ , "reinterpret_cast"
155+ , "requires"
156+ , "return"
157+ , "runtime_error"
158+ , "shared_list"
159+ , "short"
160+ , "signed"
161+ , "sizeof"
162+ , "static"
163+ , "static_assert"
164+ , "static_cast"
165+ , "std"
166+ , "string"
167+ , "struct"
168+ , "switch"
169+ , "template"
170+ , "this"
171+ , "thread_local"
172+ , "throw"
173+ , "true"
174+ , "try"
175+ , "typedef"
176+ , "typeid"
177+ , "typename"
178+ , "typeof"
179+ , "union"
180+ , "unsigned"
181+ , "using"
182+ , "virtual"
183+ , "void"
184+ , "volatile"
185+ , "wchar_t"
186+ , "while"
187+ , "xor"
188+ , "xor_eq" ] || properNameIsCppReserved name
189+
190+normalizedName :: String -> String
191+normalizedName ('_' : s) | last s == '_', s' <- init s, nameIsCppReserved s' = s'
192+normalizedName s = s
193+
194+moduleNameToCpp :: ModuleName -> String
195+moduleNameToCpp (ModuleName pns) =
196+ let name = intercalate "_" (runProperName `map` pns)
197+ in if properNameIsCppReserved name then '_' : name ++ "_" else name
198+
199+-- |
200+-- Checks whether a proper name is reserved in C++11.
201+--
202+properNameIsCppReserved :: String -> Bool
203+properNameIsCppReserved name =
204+ name `elem` [ "Private"
205+ , "PureScript" ]
src/Language/PureScript/CodeGen/Cpp/File.hsnew file+158
@@ -0,0 +1,158 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.File
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- File generation utility functions
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE PatternGuards #-}
17+
18+module Language.PureScript.CodeGen.Cpp.File where
19+
20+import Data.Maybe
21+
22+import Language.PureScript.CodeGen.Cpp.AST
23+-- import Language.PureScript.CodeGen.Cpp.Templates
24+import Language.PureScript.CodeGen.Cpp.Types
25+import Language.PureScript.Names
26+
27+import qualified Language.PureScript.Pretty.Cpp as P
28+import qualified Language.PureScript.Pretty.Common as P
29+
30+---------------------------------------------------------------------------------------------------
31+toHeader :: [Cpp] -> [Cpp]
32+---------------------------------------------------------------------------------------------------
33+toHeader = catMaybes . map go
34+ where
35+ go :: Cpp -> Maybe Cpp
36+ go (CppNamespace name cpps) = Just (CppNamespace name (toHeader cpps))
37+ go cpp@(CppUseNamespace{}) = Just cpp
38+ go (CppFunction _ [(_, atyp)] _ _ (CppBlock [CppReturn (CppApp _ [_])])) | atyp == Just CppAuto
39+ = Just CppNoOp
40+ go (CppFunction name args rtyp qs _) =
41+ let args' = (\(_,t) -> ("", t)) <$> args in
42+ Just (CppFunction name args' rtyp qs CppNoOp)
43+ go (CppVariableIntroduction _ _ (Just CppNumericLiteral {})) =
44+ Nothing
45+ go (CppVariableIntroduction _ _ (Just CppStringLiteral {})) =
46+ Nothing
47+ go (CppVariableIntroduction _ _ (Just CppBooleanLiteral {})) =
48+ Nothing
49+ -- Generate thunks for top-level values
50+ go (CppVariableIntroduction (name, _) _ (Just _)) =
51+ Just $ CppVariableIntroduction (name, Just $ CppAny [CppConst]) [CppExtern] Nothing
52+ go (CppComment comms cpp')
53+ | Just cpp <- go cpp' = Just $ case cpp of CppFunction {} -> cpp
54+ _ -> CppComment comms cpp
55+ go _ = Nothing
56+
57+---------------------------------------------------------------------------------------------------
58+toHeaderFns :: [Cpp] -> [Cpp]
59+---------------------------------------------------------------------------------------------------
60+toHeaderFns = catMaybes . map go
61+ where
62+ go :: Cpp -> Maybe Cpp
63+ go (CppNamespace name cpps) = Just (CppNamespace name (toHeaderFns cpps))
64+ go (CppFunction name [(_, atyp)] _ _ (CppBlock [CppReturn (CppApp cpp [_])]))
65+ | atyp == Just CppAuto
66+ = Just (CppVariableIntroduction (name, Nothing) [] (Just cpp))
67+
68+ go cpp@(CppVariableIntroduction _ _ (Just CppNumericLiteral {})) =
69+ Just cpp
70+ go cpp@(CppVariableIntroduction _ _ (Just CppStringLiteral {})) =
71+ Just cpp
72+ go cpp@(CppVariableIntroduction _ _ (Just CppBooleanLiteral {})) =
73+ Just cpp
74+
75+ go (CppComment comms cpp') | Just cpp <- go cpp' = Just (CppComment comms cpp)
76+ go _ = Nothing
77+
78+---------------------------------------------------------------------------------------------------
79+toBodyDecl :: [Cpp] -> [Cpp]
80+---------------------------------------------------------------------------------------------------
81+toBodyDecl = catMaybes . map go
82+ where
83+ go :: Cpp -> Maybe Cpp
84+ go (CppComment comms cpp') | Just commented <- go cpp' = Just (CppComment comms commented)
85+ go _ = Nothing
86+
87+---------------------------------------------------------------------------------------------------
88+toBody :: [Cpp] -> [Cpp]
89+---------------------------------------------------------------------------------------------------
90+toBody = catMaybes . map go
91+ where
92+ go :: Cpp -> Maybe Cpp
93+ go (CppNamespace name cpps) =
94+ let cpps' = toBody cpps in
95+ if all isNoOp cpps'
96+ then Nothing
97+ else Just (CppNamespace name cpps')
98+ where
99+ isNoOp :: Cpp -> Bool
100+ isNoOp CppNoOp = True
101+ isNoOp (CppComment _ cpp) | isNoOp cpp = True
102+ isNoOp (CppUseNamespace{}) = True
103+ isNoOp (CppNamespace _ cpps') = all isNoOp cpps'
104+ isNoOp (CppRaw _) = True
105+ isNoOp _ = False
106+ go cpp@(CppUseNamespace{}) = Just cpp
107+ go cpp@(CppFunction {}) = Just cpp
108+ go (CppVariableIntroduction _ _ (Just CppNumericLiteral {})) =
109+ Nothing
110+ go (CppVariableIntroduction _ _ (Just CppStringLiteral {})) =
111+ Nothing
112+ go (CppVariableIntroduction _ _ (Just CppBooleanLiteral {})) =
113+ Nothing
114+ -- Generate thunks for top-level values
115+ go (CppVariableIntroduction (name, _) _ (Just cpp)) =
116+ Just $ CppVariableIntroduction (name, Just $ CppAny [CppConst]) [] (Just lambda)
117+ where
118+ val = CppVariableIntroduction ("_value_", Just $ CppAny [CppConst]) [CppStatic] (Just $ addCaptures cpp)
119+ block = CppBlock [val, CppReturn (CppVar "_value_")]
120+ lambda = CppLambda [] [("", Just $ thunkMarkerType)] (Just $ CppAny [CppConst, CppRef]) block
121+ addCaptures :: Cpp -> Cpp
122+ addCaptures = everywhereOnCpp addCapture
123+ where
124+ addCapture :: Cpp -> Cpp
125+ addCapture (CppLambda [] args rty body) = CppLambda [CppCaptureAll] args rty body
126+ addCapture cpp' = cpp'
127+ go (CppComment comms cpp') | Just commented <- go cpp' = Just (CppComment comms commented)
128+ go _ = Nothing
129+
130+---------------------------------------------------------------------------------------------------
131+
132+fileBegin :: ModuleName -> String -> [Cpp]
133+fileBegin mn suffix = [CppRaw ("#ifndef " ++ fileModName mn suffix),
134+ CppRaw ("#define " ++ fileModName mn suffix)]
135+
136+fileEnd :: ModuleName -> String -> [Cpp]
137+fileEnd mn suffix = [CppRaw ("#endif // " ++ fileModName mn suffix)]
138+
139+fileModName :: ModuleName -> String -> String
140+fileModName mn suffix = P.dotsTo '_' (runModuleName mn ++ '_' : suffix)
141+
142+isMain :: ModuleName -> Bool
143+isMain (ModuleName [ProperName "Main"]) = True
144+isMain _ = False
145+
146+nativeMain :: Cpp
147+nativeMain = CppFunction "main"
148+ [ ([], Just $ CppPrimitive "int")
149+ , ([], Just $ CppPrimitive "char *[]")
150+ ]
151+ (Just $ CppPrimitive "int")
152+ []
153+ (CppBlock [ CppUseNamespace "Main"
154+ , CppApp (CppApp (CppAccessor (CppVar "main") (CppVar "Main"))
155+ [CppVar unthunkMarkerValue])
156+ []
157+ , CppReturn (CppNumericLiteral (Left 0))
158+ ])
src/Language/PureScript/CodeGen/Cpp/Optimizer.hsnew file+92
@@ -0,0 +1,92 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp.Optimizer
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module optimizes code in the simplified-C++11 intermediate representation.
13+--
14+-- The following optimizations are supported:
15+--
16+-- * Collapsing nested blocks
17+--
18+-- * Tail call elimination
19+--
20+-- * Inlining of (>>=) and ret for the Eff monad
21+--
22+-- * Removal of unnecessary thunks
23+--
24+-- * Eta conversion
25+--
26+-- * Inlining variables
27+--
28+-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
29+--
30+-- * Inlining primitive C++11 operators
31+--
32+-----------------------------------------------------------------------------
33+
34+{-# LANGUAGE FlexibleContexts #-}
35+{-# LANGUAGE CPP #-}
36+
37+module Language.PureScript.CodeGen.Cpp.Optimizer (
38+ optimize
39+) where
40+
41+#if __GLASGOW_HASKELL__ < 710
42+import Control.Applicative (Applicative)
43+#endif
44+import Control.Monad.Reader (MonadReader, ask, asks)
45+import Control.Monad.Supply.Class (MonadSupply)
46+
47+import Language.PureScript.CodeGen.Cpp.AST
48+import Language.PureScript.Options
49+import qualified Language.PureScript.Constants as C
50+
51+import Language.PureScript.CodeGen.Cpp.Optimizer.Blocks
52+import Language.PureScript.CodeGen.Cpp.Optimizer.Common
53+import Language.PureScript.CodeGen.Cpp.Optimizer.Inliner
54+import Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo
55+import Language.PureScript.CodeGen.Cpp.Optimizer.TCO
56+import Language.PureScript.CodeGen.Cpp.Optimizer.Unused
57+
58+-- |
59+-- Apply a series of optimizer passes to simplified C++11 code
60+--
61+optimize :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => Cpp -> m Cpp
62+optimize cpp = do
63+ noOpt <- asks optionsNoOptimizations
64+ if noOpt then return cpp else optimize' cpp
65+
66+optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => Cpp -> m Cpp
67+optimize' cpp = do
68+ opts <- ask
69+ untilFixedPoint (inlineFnComposition . applyAll
70+ [ collapseNestedBlocks
71+ , collapseNestedIfs
72+ , tco opts
73+ , magicDo opts
74+ , removeCodeAfterReturnStatements
75+ , removeUnusedArg
76+ , removeUndefinedApp
77+ , unThunk
78+ , etaConvert
79+ , evaluateIifes
80+ , inlineVariables
81+ , inlineValues
82+ , inlineOperator (C.prelude, (C.$)) $ \f x -> CppApp f [x]
83+ , inlineOperator (C.prelude, (C.#)) $ \x f -> CppApp f [x]
84+ , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip CppIndexer
85+ , inlineCommonOperators ]) cpp
86+
87+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
88+untilFixedPoint f = go
89+ where
90+ go a = do
91+ a' <- f a
92+ if a' == a then return a' else go a'
src/Language/PureScript/CodeGen/Cpp/Optimizer/Blocks.hsnew file+42
@@ -0,0 +1,42 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp.Optimizer.Blocks
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Optimizer steps for simplifying C++ blocks
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.Cpp.Optimizer.Blocks
17+ ( collapseNestedBlocks
18+ , collapseNestedIfs
19+ ) where
20+
21+import Language.PureScript.CodeGen.Cpp.AST
22+
23+-- |
24+-- Collapse blocks which appear nested directly below another block
25+--
26+collapseNestedBlocks :: Cpp -> Cpp
27+collapseNestedBlocks = everywhereOnCpp collapse
28+ where
29+ collapse :: Cpp -> Cpp
30+ collapse (CppBlock sts) = CppBlock (concatMap go sts)
31+ collapse cpp = cpp
32+ go :: Cpp -> [Cpp]
33+ go (CppBlock sts) = sts
34+ go s = [s]
35+
36+collapseNestedIfs :: Cpp -> Cpp
37+collapseNestedIfs = everywhereOnCpp collapse
38+ where
39+ collapse :: Cpp -> Cpp
40+ collapse (CppIfElse cond1 (CppBlock [CppIfElse cond2 body Nothing]) Nothing) =
41+ CppIfElse (CppBinary And cond1 cond2) body Nothing
42+ collapse cpp = cpp
src/Language/PureScript/CodeGen/Cpp/Optimizer/Common.hsnew file+75
@@ -0,0 +1,75 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp.Optimizer.Common
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Common functions used by the various optimizer phases
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.Cpp.Optimizer.Common where
17+
18+import Data.Maybe (fromMaybe)
19+
20+import Language.PureScript.CodeGen.Cpp.AST
21+
22+applyAll :: [a -> a] -> a -> a
23+applyAll = foldl1 (.)
24+
25+replaceIdent :: String -> Cpp -> Cpp -> Cpp
26+replaceIdent var1 cpp = everywhereOnCpp replace
27+ where
28+ replace (CppVar var2) | var1 == var2 = cpp
29+ replace other = other
30+
31+replaceIdents :: [(String, Cpp)] -> Cpp -> Cpp
32+replaceIdents vars = everywhereOnCpp replace
33+ where
34+ replace v@(CppVar var) = fromMaybe v $ lookup var vars
35+ replace other = other
36+
37+isReassigned :: String -> Cpp -> Bool
38+isReassigned var1 = everythingOnCpp (||) check
39+ where
40+ check :: Cpp -> Bool
41+ check (CppFunction _ args _ _ _) | var1 `elem` (map fst args) = True
42+ check (CppVariableIntroduction arg _ _) | var1 == fst arg = True
43+ check (CppAssignment (CppVar arg) _) | var1 == arg = True
44+ check _ = False
45+
46+isRebound :: Cpp -> Cpp -> Bool
47+isRebound cpp d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnCpp (++) variablesOf cpp)
48+ where
49+ variablesOf (CppVar var) = [var]
50+ variablesOf _ = []
51+
52+isUsed :: String -> Cpp -> Bool
53+isUsed var1 = everythingOnCpp (||) check
54+ where
55+ check :: Cpp -> Bool
56+ check (CppVar var2) | var1 == var2 = True
57+ check (CppAssignment target _) | var1 == targetVariable target = True
58+ check _ = False
59+
60+targetVariable :: Cpp -> String
61+targetVariable (CppVar var) = var
62+targetVariable (CppAccessor _ tgt) = targetVariable tgt
63+targetVariable (CppIndexer _ tgt) = targetVariable tgt
64+targetVariable _ = error "Invalid argument to targetVariable"
65+
66+isUpdated :: String -> Cpp -> Bool
67+isUpdated var1 = everythingOnCpp (||) check
68+ where
69+ check :: Cpp -> Bool
70+ check (CppAssignment target _) | var1 == targetVariable target = True
71+ check _ = False
72+
73+removeFromBlock :: ([Cpp] -> [Cpp]) -> Cpp -> Cpp
74+removeFromBlock go (CppBlock sts) = CppBlock (go sts)
75+removeFromBlock _ cpp = cpp
src/Language/PureScript/CodeGen/Cpp/Optimizer/Inliner.hsnew file+319
@@ -0,0 +1,319 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp.Optimizer.Inliner
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module provides basic inlining capabilities
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE CPP #-}
17+
18+module Language.PureScript.CodeGen.Cpp.Optimizer.Inliner (
19+ inlineVariables,
20+ inlineValues,
21+ inlineOperator,
22+ inlineCommonOperators,
23+ inlineFnComposition,
24+ etaConvert,
25+ unThunk,
26+ evaluateIifes
27+) where
28+
29+#if __GLASGOW_HASKELL__ < 710
30+import Control.Applicative (Applicative)
31+#endif
32+import Control.Monad.Supply.Class (MonadSupply, freshName)
33+import Language.PureScript.CodeGen.Cpp.Types
34+import Language.PureScript.CodeGen.Cpp.AST
35+import Language.PureScript.CodeGen.Cpp.Common
36+import Language.PureScript.CodeGen.Cpp.Optimizer.Common
37+import Language.PureScript.Names
38+import qualified Language.PureScript.Constants as C
39+
40+-- TODO: Potential bug:
41+-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
42+-- Needs to be: { 0..toFixed(10); }
43+-- Probably needs to be fixed in pretty-printer instead.
44+shouldInline :: Cpp -> Bool
45+shouldInline (CppVar _) = True
46+shouldInline (CppNumericLiteral _) = True
47+shouldInline (CppStringLiteral _) = True
48+shouldInline (CppBooleanLiteral _) = True
49+shouldInline (CppAccessor _ val) = shouldInline val
50+shouldInline (CppIndexer index val) = shouldInline index && shouldInline val
51+shouldInline _ = False
52+
53+etaConvert :: Cpp -> Cpp
54+etaConvert = everywhereOnCpp convert
55+ where
56+ convert :: Cpp -> Cpp
57+ convert (CppBlock [CppReturn (CppApp (CppLambda _ idents _ block@(CppBlock body)) args)])
58+ | all shouldInline args &&
59+ not (any (`isRebound` block) (map (CppVar . fst) idents)) &&
60+ not (any (`isRebound` block) args)
61+ = CppBlock (map (replaceIdents (zip (map fst idents) args)) body)
62+ convert (CppLambda _ [] _ (CppBlock [CppReturn (CppApp fn [])])) = fn
63+ convert cpp = cpp
64+
65+unThunk :: Cpp -> Cpp
66+unThunk = everywhereOnCpp convert
67+ where
68+ convert :: Cpp -> Cpp
69+ convert (CppBlock []) = CppBlock []
70+ convert (CppBlock cpps) =
71+ case last cpps of
72+ CppReturn (CppApp (CppLambda _ [] _ (CppBlock body)) []) -> CppBlock $ init cpps ++ body
73+ _ -> CppBlock cpps
74+ convert cpp = cpp
75+
76+evaluateIifes :: Cpp -> Cpp
77+evaluateIifes = everywhereOnCpp convert
78+ where
79+ convert :: Cpp -> Cpp
80+ convert (CppApp (CppLambda _ [] _ (CppBlock [CppReturn ret])) []) = ret
81+ convert cpp = cpp
82+
83+inlineVariables :: Cpp -> Cpp
84+inlineVariables = everywhereOnCpp $ removeFromBlock go
85+ where
86+ go :: [Cpp] -> [Cpp]
87+ go [] = []
88+ go (CppVariableIntroduction (var, _) _ (Just cpp) : sts)
89+ | shouldInline cpp && not (any (isReassigned var) sts) && not (any (isRebound cpp) sts) && not (any (isUpdated var) sts) =
90+ go (map (replaceIdent var cpp) sts)
91+ go (s:sts) = s : go sts
92+
93+inlineValues :: Cpp -> Cpp
94+inlineValues = everywhereOnCpp convert
95+ where
96+ convert :: Cpp -> Cpp
97+ convert (CppApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = CppNumericLiteral (Left 0)
98+ | isDict semiringNumber dict && isFn fnOne fn = CppNumericLiteral (Left 1)
99+ | isDict semiringInt dict && isFn fnZero fn = CppNumericLiteral (Left 0)
100+ | isDict semiringInt dict && isFn fnOne fn = CppNumericLiteral (Left 1)
101+ | isDict boundedBoolean dict && isFn fnBottom fn = CppBooleanLiteral False
102+ | isDict boundedBoolean dict && isFn fnTop fn = CppBooleanLiteral True
103+ convert (CppApp (CppApp (CppApp fn [dict]) [x]) [y])
104+ | isDict semiringInt dict && isFn fnAdd fn = CppBinary Add x y
105+ | isDict semiringInt dict && isFn fnMultiply fn = CppBinary Multiply x y
106+ | isDict moduloSemiringInt dict && isFn fnDivide fn = CppBinary Divide x y
107+ | isDict ringInt dict && isFn fnSubtract fn = CppBinary Subtract x y
108+ convert other = other
109+ fnZero = (C.prelude, C.zero)
110+ fnOne = (C.prelude, C.one)
111+ fnBottom = (C.prelude, C.bottom)
112+ fnTop = (C.prelude, C.top)
113+ fnAdd = (C.prelude, (C.+))
114+ fnDivide = (C.prelude, (C./))
115+ fnMultiply = (C.prelude, (C.*))
116+ fnSubtract = (C.prelude, (C.-))
117+
118+inlineOperator :: (String, String) -> (Cpp -> Cpp -> Cpp) -> Cpp -> Cpp
119+inlineOperator (m, op) f = everywhereOnCpp convert
120+ where
121+ convert :: Cpp -> Cpp
122+ convert (CppApp (CppApp op' [x]) [y]) | isOp op' = f x y
123+ convert other = other
124+ isOp (CppAccessor (CppVar longForm) (CppVar m')) = m == m' && longForm == identToCpp (Op op)
125+ isOp (CppIndexer (CppStringLiteral op') (CppVar m')) = m == m' && op == op'
126+ isOp _ = False
127+
128+inlineCommonOperators :: Cpp -> Cpp
129+inlineCommonOperators = applyAll $
130+ [ binary semiringNumber (C.+) Add
131+ , binary semiringNumber (C.*) Multiply
132+
133+ , binary ringNumber (C.-) Subtract
134+ , unary ringNumber C.negate CppNegate
135+ , binary ringInt (C.-) Subtract
136+ , unary ringInt C.negate CppNegate
137+
138+ , binary moduloSemiringNumber (C./) Divide
139+ , binary moduloSemiringInt C.mod Modulus
140+
141+ , binary eqNumber (C.==) Equal
142+ , binary eqNumber (C./=) NotEqual
143+ , binary eqInt (C.==) Equal
144+ , binary eqInt (C./=) NotEqual
145+ , binary eqString (C.==) Equal
146+ , binary eqString (C./=) NotEqual
147+ , binary eqBoolean (C.==) Equal
148+ , binary eqBoolean (C./=) NotEqual
149+
150+ , binary ordNumber (C.<) LessThan
151+ , binary ordNumber (C.>) GreaterThan
152+ , binary ordNumber (C.<=) LessThanOrEqual
153+ , binary ordNumber (C.>=) GreaterThanOrEqual
154+ , binary ordInt (C.<) LessThan
155+ , binary ordInt (C.>) GreaterThan
156+ , binary ordInt (C.<=) LessThanOrEqual
157+ , binary ordInt (C.>=) GreaterThanOrEqual
158+
159+ , binary semigroupString (C.<>) Add
160+ , binary semigroupString (C.++) Add
161+
162+ , binary booleanAlgebraBoolean (C.&&) And
163+ , binary booleanAlgebraBoolean (C.||) Or
164+ , binaryFunction booleanAlgebraBoolean C.conj And
165+ , binaryFunction booleanAlgebraBoolean C.disj Or
166+ , unary booleanAlgebraBoolean C.not CppNot
167+
168+ , binary' C.dataIntBits (C..|.) BitwiseOr
169+ , binary' C.dataIntBits (C..&.) BitwiseAnd
170+ , binary' C.dataIntBits (C..^.) BitwiseXor
171+ , binary' C.dataIntBits C.shl ShiftLeft
172+ , binary' C.dataIntBits C.shr ShiftRight
173+ -- , binary' C.dataIntBits C.zshr ZeroFillShiftRight
174+ , unary' C.dataIntBits C.complement CppBitwiseNot
175+ ] -- ++ -- DISABLE mkFn/runFn inlining
176+ -- [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
177+ where
178+ binary :: (String, String) -> String -> BinaryOp -> Cpp -> Cpp
179+ binary dict opString op = everywhereOnCpp convert
180+ where
181+ convert :: Cpp -> Cpp
182+ convert (CppApp (CppApp (CppApp fn [dict']) [CppStringLiteral x]) [CppStringLiteral y])
183+ | isDict dict dict' && isPreludeFn opString fn = CppStringLiteral (x ++ y)
184+ convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = CppBinary op x y
185+ convert other = other
186+ binary' :: String -> String -> BinaryOp -> Cpp -> Cpp
187+ binary' moduleName opString op = everywhereOnCpp convert
188+ where
189+ convert :: Cpp -> Cpp
190+ convert (CppApp (CppApp fn [x]) [y]) | isFn (moduleName, opString) fn = CppBinary op x y
191+ convert other = other
192+ binaryFunction :: (String, String) -> String -> BinaryOp -> Cpp -> Cpp
193+ binaryFunction dict fnName op = everywhereOnCpp convert
194+ where
195+ convert :: Cpp -> Cpp
196+ convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = CppBinary op x y
197+ convert other = other
198+ unary :: (String, String) -> String -> CppUnaryOp -> Cpp -> Cpp
199+ unary dict fnName op = everywhereOnCpp convert
200+ where
201+ convert :: Cpp -> Cpp
202+ convert (CppApp (CppApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = CppUnary op x
203+ convert other = other
204+ unary' :: String -> String -> CppUnaryOp -> Cpp -> Cpp
205+ unary' moduleName fnName op = everywhereOnCpp convert
206+ where
207+ convert :: Cpp -> Cpp
208+ convert (CppApp fn [x]) | isFn (moduleName, fnName) fn = CppUnary op x
209+ convert other = other
210+ -- mkFn :: Int -> Cpp -> Cpp
211+ -- mkFn 0 = everywhereOnCpp convert
212+ -- where
213+ -- convert :: Cpp -> Cpp
214+ -- convert (CppApp mkFnN [CppLambda caps [_] _ (CppBlock cpp)]) | isNFn C.mkFn 0 mkFnN =
215+ -- CppLambda caps [] Nothing (CppBlock cpp)
216+ -- convert other = other
217+ -- mkFn n = everywhereOnCpp convert
218+ -- where
219+ -- convert :: Cpp -> Cpp
220+ -- convert orig@(CppApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =
221+ -- case collectArgs n [] fn of
222+ -- Just (args, cpp) -> CppLambda [CppCaptureAll] args Nothing (CppBlock cpp)
223+ -- Nothing -> orig
224+ -- convert other = other
225+ -- collectArgs :: Int -> [(String, Maybe CppType)] -> Cpp -> Maybe ([(String, Maybe CppType)], [Cpp])
226+ -- collectArgs 1 acc (CppLambda _ [oneArg] _ (CppBlock cpp)) | length acc == n - 1 = Just (reverse (oneArg : acc), cpp)
227+ -- collectArgs m acc (CppLambda _ [oneArg] _ (CppBlock [CppReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret
228+ -- collectArgs _ _ _ = Nothing
229+ --
230+ -- isNFn :: String -> Int -> Cpp -> Bool
231+ -- isNFn prefix n (CppVar name) = name == (prefix ++ show n)
232+ -- isNFn prefix n (CppAccessor (CppVar name) (CppVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
233+ -- isNFn _ _ _ = False
234+ --
235+ -- runFn :: Int -> Cpp -> Cpp
236+ -- runFn n = everywhereOnCpp convert
237+ -- where
238+ -- convert :: Cpp -> Cpp
239+ -- convert cpp = fromMaybe cpp $ go n [] cpp
240+ --
241+ -- go :: Int -> [Cpp] -> Cpp -> Maybe Cpp
242+ -- go 0 acc (CppApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (CppApp fn acc)
243+ -- go m acc (CppApp lhs [arg]) = go (m - 1) (arg : acc) lhs
244+ -- go _ _ _ = Nothing
245+
246+-- (f <<< g $ x) = f (g x)
247+-- (f <<< g) = \x -> f (g x)
248+inlineFnComposition :: (Applicative m, MonadSupply m) => Cpp -> m Cpp
249+inlineFnComposition = everywhereOnCppTopDownM convert
250+ where
251+ convert :: (MonadSupply m) => Cpp -> m Cpp
252+ convert (CppApp (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn =
253+ return $ CppApp x [CppApp y [z]]
254+ convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do
255+ arg <- freshName
256+ return $ CppLambda [CppCaptureAll] [(arg, Just (CppAny [CppConst, CppRef]))] (Just $ CppAny []) (CppBlock [CppReturn $ CppApp x [CppApp y [CppVar arg]]])
257+ convert other = return other
258+ isFnCompose :: Cpp -> Cpp -> Bool
259+ isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn (C.compose) fn)
260+
261+isDict :: (String, String) -> Cpp -> Bool
262+isDict (moduleName, dictName) (CppAccessor (CppVar x) (CppVar y)) = x == dictName && y == moduleName
263+isDict _ _ = False
264+
265+isFn :: (String, String) -> Cpp -> Bool
266+isFn (moduleName, fnName) (CppAccessor (CppVar x) (CppVar y)) = x == (identToCpp (Ident fnName)) && y == moduleName
267+isFn (moduleName, fnName) (CppIndexer (CppStringLiteral x) (CppVar y)) = x == fnName && y == moduleName
268+isFn _ _ = False
269+
270+isPreludeFn :: String -> Cpp -> Bool
271+isPreludeFn fnName = isFn (C.prelude, fnName)
272+
273+semiringNumber :: (String, String)
274+semiringNumber = (C.prelude, C.semiringNumber)
275+
276+semiringInt :: (String, String)
277+semiringInt = (C.prelude, C.semiringInt)
278+
279+ringNumber :: (String, String)
280+ringNumber = (C.prelude, C.ringNumber)
281+
282+ringInt :: (String, String)
283+ringInt = (C.prelude, C.ringInt)
284+
285+moduloSemiringNumber :: (String, String)
286+moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)
287+
288+moduloSemiringInt :: (String, String)
289+moduloSemiringInt = (C.prelude, C.moduloSemiringInt)
290+
291+eqNumber :: (String, String)
292+eqNumber = (C.prelude, C.eqNumber)
293+
294+eqInt :: (String, String)
295+eqInt = (C.prelude, C.eqInt)
296+
297+eqString :: (String, String)
298+eqString = (C.prelude, C.eqNumber)
299+
300+eqBoolean :: (String, String)
301+eqBoolean = (C.prelude, C.eqNumber)
302+
303+ordNumber :: (String, String)
304+ordNumber = (C.prelude, C.ordNumber)
305+
306+ordInt :: (String, String)
307+ordInt = (C.prelude, C.ordInt)
308+
309+semigroupString :: (String, String)
310+semigroupString = (C.prelude, C.semigroupString)
311+
312+boundedBoolean :: (String, String)
313+boundedBoolean = (C.prelude, C.boundedBoolean)
314+
315+booleanAlgebraBoolean :: (String, String)
316+booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean)
317+
318+semigroupoidFn :: (String, String)
319+semigroupoidFn = (C.prelude, C.semigroupoidFn)
src/Language/PureScript/CodeGen/Cpp/Optimizer/MagicDo.hsnew file+117
@@ -0,0 +1,117 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the "Magic Do" optimization, which inlines calls to return
13+-- and bind for the Eff monad, as well as some of its actions.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo (
18+ magicDo
19+) where
20+
21+import Language.PureScript.CodeGen.Cpp.AST
22+import Language.PureScript.CodeGen.Cpp.Common
23+import Language.PureScript.CodeGen.Cpp.Types
24+import Language.PureScript.Names
25+import Language.PureScript.Options
26+import qualified Language.PureScript.Constants as C
27+
28+magicDo :: Options -> Cpp -> Cpp
29+magicDo opts | optionsNoMagicDo opts = id
30+ | otherwise = magicDo'
31+
32+-- |
33+-- Inline type class dictionaries for >>= and return for the Eff monad
34+--
35+-- E.g.
36+--
37+-- Prelude[">>="](dict)(m1)(function(x) {
38+-- return ...;
39+-- })
40+--
41+-- becomes
42+--
43+-- function __do {
44+-- var x = m1();
45+-- ...
46+-- }
47+--
48+magicDo' :: Cpp -> Cpp
49+magicDo' = everywhereOnCpp undo . everywhereOnCppTopDown convert
50+ where
51+ -- The name of the function block which is added to denote a do block
52+ fnName = "__do"
53+ -- Desugar monomorphic calls to >>= and return for the Eff monad
54+ convert :: Cpp -> Cpp
55+ -- Desugar return
56+ convert (CppApp (CppApp ret [val]) []) | isReturn ret = val
57+ -- Desugar pure
58+ convert (CppApp (CppApp pure' [val]) []) | isPure pure' = val
59+ -- Desugar >>
60+ convert (CppApp (CppApp bind [m]) [CppLambda _ [] rty (CppBlock cpp)]) | isBind bind =
61+ CppFunction fnName [] rty [] $ CppBlock (CppApp m [] : map applyReturns cpp )
62+ -- Desugar >>=
63+ convert (CppApp (CppApp bind [m]) [CppLambda _ [arg] rty (CppBlock cpp)]) | isBind bind =
64+ CppFunction fnName [] rty [] $ CppBlock (CppVariableIntroduction arg [] (Just (CppApp m [])) : map applyReturns cpp)
65+ -- Desugar untilE
66+ convert (CppApp (CppApp f [arg]) []) | isEffFunc C.untilE f =
67+ CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppUnary CppNot (CppApp arg [])) (CppBlock []), CppReturn $ CppObjectLiteral []])) []
68+ -- Desugar whileE
69+ convert (CppApp (CppApp (CppApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
70+ CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppApp arg1 []) (CppBlock [ CppApp arg2 [] ]), CppReturn $ CppObjectLiteral []])) []
71+ convert other = other
72+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
73+ isBind (CppApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True
74+ isBind _ = False
75+ -- Check if an expression represents a monomorphic call to return for the Eff monad
76+ isReturn (CppApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
77+ isReturn _ = False
78+ -- Check if an expression represents a monomorphic call to pure for the Eff applicative
79+ isPure (CppApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True
80+ isPure _ = False
81+ -- Check if an expression represents the polymorphic >>= function
82+ isBindPoly (CppAccessor (CppVar prop) (CppVar prelude)) = prelude == C.prelude && (prop `elem` map identToCpp [Ident C.bind, Op (C.>>=)])
83+ isBindPoly (CppIndexer (CppStringLiteral bind) (CppVar prelude)) = prelude == C.prelude && (bind `elem` [C.bind, (C.>>=)])
84+ isBindPoly _ = False
85+ -- Check if an expression represents the polymorphic return function
86+ isRetPoly (CppAccessor (CppVar returnEscaped) (CppVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
87+ isRetPoly (CppIndexer (CppStringLiteral return') (CppVar prelude)) = prelude == C.prelude && return' == C.return
88+ isRetPoly _ = False
89+ -- Check if an expression represents the polymorphic pure function
90+ isPurePoly (CppAccessor (CppVar pure') (CppVar prelude)) = prelude == C.prelude && pure' == C.pure'
91+ isPurePoly (CppIndexer (CppStringLiteral pure') (CppVar prelude)) = prelude == C.prelude && pure' == C.pure'
92+ isPurePoly _ = False
93+ -- Check if an expression represents a function in the Ef module
94+ isEffFunc name (CppAccessor (CppVar name') (CppVar eff)) = eff == C.eff && name == name'
95+ isEffFunc _ _ = False
96+ -- Check if an expression represents the Monad Eff dictionary
97+ isEffDict name (CppVar ident) | ident == name = True
98+ isEffDict name (CppAccessor (CppVar prop) (CppVar eff)) = eff == C.eff && prop == name
99+ isEffDict _ _ = False
100+ -- Remove __do function applications which remain after desugaring
101+ undo :: Cpp -> Cpp
102+ undo (CppReturn (CppApp (CppFunction ident [] _ _ body) [])) | ident == fnName = body
103+ undo (CppFunction ident [] rty _ body) | ident == fnName = CppLambda [CppCaptureAll] [] rty body
104+ undo other = other
105+
106+ applyReturns :: Cpp -> Cpp
107+ applyReturns (CppReturn ret) = CppReturn (CppApp ret [])
108+ applyReturns (CppBlock cpps) = CppBlock (map applyReturns cpps)
109+ applyReturns (CppWhile cond cpp) = CppWhile cond (applyReturns cpp)
110+ applyReturns (CppIfElse cond t f) = CppIfElse cond (applyReturns t) (applyReturns `fmap` f)
111+ applyReturns other = other
112+
113+-- |
114+-- Inline functions in the ST module
115+--
116+-- TODO: various issues in C++ backend -- revisit later
117+--
src/Language/PureScript/CodeGen/Cpp/Optimizer/TCO.hsnew file+149
@@ -0,0 +1,149 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp.Optimizer.TCO
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements tail call elimination.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.Cpp.Optimizer.TCO (tco) where
17+
18+import Data.List
19+import Data.Monoid
20+
21+import Language.PureScript.Options
22+import Language.PureScript.CodeGen.Cpp.Types
23+import Language.PureScript.CodeGen.Cpp.AST
24+
25+-- |
26+-- Eliminate tail calls
27+--
28+tco :: Options -> Cpp -> Cpp
29+tco opts | optionsNoTco opts = id
30+ | otherwise = tco'
31+
32+tco' :: Cpp -> Cpp
33+tco' = everywhereOnCpp convert
34+ where
35+ tcoVar :: String -> String
36+ tcoVar arg = "__tco_" ++ arg
37+
38+ copyVar :: String -> String
39+ copyVar arg = "__copy_" ++ arg
40+
41+ copyVar' :: (String, Maybe CppType) -> (String, Maybe CppType)
42+ copyVar' (arg, t) = (copyVar arg, t)
43+
44+ convert :: Cpp -> Cpp
45+
46+ convert cpp@(CppVariableIntroduction (name, ty) qs (Just fn@CppLambda {})) =
47+ let
48+ (argss, body', replace) = collectAllFunctionArgs [] id fn
49+ in case () of
50+ _ | isTailCall name body' ->
51+ let
52+ allArgs = fst <$> (concat $ reverse argss)
53+ in
54+ CppVariableIntroduction (name, ty) qs (Just (replace (toLoop name allArgs body')))
55+ | otherwise -> cpp
56+
57+ convert fn@(CppFunction name (_:_) _ _ _) =
58+ let
59+ (argss, body', replace) = collectAllFunctionArgs [] id fn
60+ in case () of
61+ _ | isTailCall name body' ->
62+ let
63+ allArgs = fst <$> (concat $ reverse argss)
64+ in
65+ replace (toLoop name allArgs body')
66+ | otherwise -> fn
67+
68+ convert cpp = cpp
69+
70+ collectAllFunctionArgs :: [[(String, Maybe CppType)]] -> (Cpp -> Cpp) -> Cpp -> ([[(String, Maybe CppType)]], Cpp, Cpp -> Cpp)
71+ collectAllFunctionArgs allArgs f (CppFunction ident args rty qs (CppBlock (body@(CppReturn _):_))) =
72+ collectAllFunctionArgs (args : allArgs) (\b -> f (CppFunction ident (map copyVar' args) rty qs (CppBlock [b]))) body
73+ collectAllFunctionArgs allArgs f (CppFunction ident args rty qs body@(CppBlock _)) =
74+ (args : allArgs, body, f . CppFunction ident (map copyVar' args) rty qs)
75+ collectAllFunctionArgs allArgs f (CppReturn (CppLambda cs args rty (CppBlock [body]))) =
76+ collectAllFunctionArgs (args : allArgs) (\b -> f (CppReturn (CppLambda cs (map copyVar' args) rty (CppBlock [b])))) body
77+ collectAllFunctionArgs allArgs f (CppReturn (CppLambda cs args rty body@(CppBlock _))) =
78+ (args : allArgs, body, f . CppReturn . CppLambda cs (map copyVar' args) rty)
79+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
80+
81+ isTailCall :: String -> Cpp -> Bool
82+ isTailCall ident cpp =
83+ let
84+ numSelfCalls = everythingOnCpp (+) countSelfCalls cpp
85+ numSelfCallsInTailPosition = everythingOnCpp (+) countSelfCallsInTailPosition cpp
86+ numSelfCallsUnderFunctions = everythingOnCpp (+) countSelfCallsUnderFunctions cpp
87+ numSelfCallWithFnArgs = everythingOnCpp (+) countSelfCallsWithFnArgs cpp
88+ in
89+ numSelfCalls > 0
90+ && numSelfCalls == numSelfCallsInTailPosition
91+ && numSelfCallsUnderFunctions == 0
92+ && numSelfCallWithFnArgs == 0
93+ where
94+ countSelfCalls :: Cpp -> Int
95+ countSelfCalls (CppApp (CppVar ident') _) | ident == ident' = 1
96+ countSelfCalls _ = 0
97+
98+ countSelfCallsInTailPosition :: Cpp -> Int
99+ countSelfCallsInTailPosition (CppReturn ret) | isSelfCall ident ret = 1
100+ countSelfCallsInTailPosition _ = 0
101+
102+ countSelfCallsUnderFunctions :: Cpp -> Int
103+ countSelfCallsUnderFunctions (CppFunction _ _ _ _ cpp') = everythingOnCpp (+) countSelfCalls cpp'
104+ countSelfCallsUnderFunctions (CppLambda _ (_:_) _ cpp') = everythingOnCpp (+) countSelfCalls cpp'
105+ countSelfCallsUnderFunctions _ = 0
106+
107+ countSelfCallsWithFnArgs :: Cpp -> Int
108+ countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0
109+
110+ toLoop :: String -> [String] -> Cpp -> Cpp
111+ toLoop ident allArgs cpp = CppBlock $
112+ map (\arg -> CppVariableIntroduction (arg, Just $ CppAny []) [] (Just (CppVar (copyVar arg)))) allArgs ++
113+ [ CppWhile (CppBooleanLiteral True) (CppBlock loop) ]
114+ where
115+ loop :: [Cpp]
116+ loop = case everywhereOnCpp loopify cpp of
117+ CppReturn (CppApp (CppLambda _ [] _ (CppBlock cpps')) []) -> nub cpps' -- elim dup var intros
118+ CppBlock cpps' -> nub cpps'
119+ cpp' -> [cpp']
120+ loopify :: Cpp -> Cpp
121+ loopify (CppReturn ret) | isSelfCall ident ret =
122+ let
123+ allArgumentValues = concat $ collectSelfCallArgs [] ret
124+ in
125+ CppBlock $ zipWith (\val arg ->
126+ CppVariableIntroduction (tcoVar arg, Just $ CppAny []) [] (Just val)) allArgumentValues allArgs
127+ ++ map (\arg ->
128+ CppAssignment (CppVar arg) (CppVar (tcoVar arg))) allArgs
129+ ++ [ CppContinue ]
130+ loopify other = other
131+ collectSelfCallArgs :: [[Cpp]] -> Cpp -> [[Cpp]]
132+ collectSelfCallArgs allArgumentValues (CppApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
133+ collectSelfCallArgs allArgumentValues _ = allArgumentValues
134+
135+ isSelfCall :: String -> Cpp -> Bool
136+ isSelfCall ident (CppApp (CppVar ident') _) = ident == ident'
137+ isSelfCall ident (CppApp fn _) = isSelfCall ident fn
138+ isSelfCall _ _ = False
139+
140+ isSelfCallWithFnArgs :: String -> Cpp -> [Cpp] -> Bool
141+ isSelfCallWithFnArgs ident (CppVar ident') args | ident == ident' && any hasFunction args = True
142+ isSelfCallWithFnArgs ident (CppApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)
143+ isSelfCallWithFnArgs _ _ _ = False
144+
145+ hasFunction :: Cpp -> Bool
146+ hasFunction = getAny . everythingOnCpp mappend (Any . isFunction)
147+ where
148+ isFunction (CppFunction {}) = True
149+ isFunction _ = False
src/Language/PureScript/CodeGen/Cpp/Optimizer/Unused.hsnew file+43
@@ -0,0 +1,43 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp.Optimizer.Unused
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Removes unused variables
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.Cpp.Optimizer.Unused where
17+
18+import Language.PureScript.CodeGen.Cpp.AST
19+import Language.PureScript.CodeGen.Cpp.Optimizer.Common
20+
21+import qualified Language.PureScript.Constants as C
22+
23+removeCodeAfterReturnStatements :: Cpp -> Cpp
24+removeCodeAfterReturnStatements = everywhereOnCpp (removeFromBlock go)
25+ where
26+ go :: [Cpp] -> [Cpp]
27+ go cpps | not (any isCppReturn cpps) = cpps
28+ | otherwise = let (body, ret : _) = span (not . isCppReturn) cpps in body ++ [ret]
29+ isCppReturn (CppReturn _) = True
30+ isCppReturn _ = False
31+
32+removeUnusedArg :: Cpp -> Cpp
33+removeUnusedArg = everywhereOnCpp convert
34+ where
35+ convert (CppFunction name [(arg,atyp)] rtyp qs body)
36+ | arg == C.__unused = CppFunction name [("",atyp)] rtyp qs body
37+ convert cpp = cpp
38+
39+removeUndefinedApp :: Cpp -> Cpp
40+removeUndefinedApp = everywhereOnCpp convert
41+ where
42+ convert (CppApp fn [CppVar arg]) | arg == C.undefined = CppApp fn []
43+ convert cpp = cpp
src/Language/PureScript/CodeGen/Cpp/Types.hsnew file+122
@@ -0,0 +1,122 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Cpp.Types
4+-- Copyright : (c) Andy Arvanitis 2015
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Types for native C++11 translation
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE PatternGuards #-}
17+{-# LANGUAGE DeriveDataTypeable #-}
18+
19+module Language.PureScript.CodeGen.Cpp.Types where
20+
21+import Data.List
22+import Data.Data
23+
24+import Language.PureScript.CodeGen.Cpp.Common
25+import Language.PureScript.Names
26+import qualified Language.PureScript.Constants as C
27+
28+-- import Debug.Trace
29+
30+data CppType = CppPrimitive String | CppAuto | CppAny [CppTypeQual]
31+ deriving (Eq, Show, Data, Typeable)
32+
33+data CppTypeQual = CppConst | CppRef
34+ deriving (Eq, Show, Data)
35+
36+-- |
37+-- Value C++11 qualifiers
38+--
39+data CppValueQual
40+ -- |
41+ -- C++ static qualifier
42+ --
43+ = CppStatic
44+ -- |
45+ -- Inline function
46+ --
47+ | CppInline
48+ -- |
49+ -- C++11+ constant expression "constexpr"
50+ --
51+ | CppConstExpr
52+ -- |
53+ -- Extern value
54+ --
55+ | CppExtern
56+ -- |
57+ -- Function or lambda is involved in recursion
58+ --
59+ | CppRecursive
60+
61+ deriving (Show, Eq, Data, Typeable)
62+
63+-- |
64+-- C++ lambda capture list
65+--
66+data CppCaptureType = CppCaptureAll
67+ deriving (Show, Eq, Data, Typeable)
68+
69+runType :: CppType -> String
70+runType (CppPrimitive t) = t
71+runType CppAuto = "auto"
72+runType (CppAny qs)
73+ | CppConst `elem` qs = "const " ++ (runType . CppAny $ delete CppConst qs)
74+ | CppRef `elem` qs = runType (CppAny $ delete CppRef qs) ++ "&"
75+ | otherwise = "any"
76+
77+runValueQual :: CppValueQual -> String
78+runValueQual CppStatic = "static"
79+runValueQual CppInline = "inline"
80+runValueQual CppConstExpr = "constexpr"
81+runValueQual CppExtern = "extern"
82+runValueQual CppRecursive = ""
83+
84+runCaptureType :: CppCaptureType -> String
85+runCaptureType CppCaptureAll = "="
86+
87+-- TODO: move or remove this
88+--
89+qualifiedToStr :: ModuleName -> (a -> Ident) -> Qualified a -> String
90+qualifiedToStr _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = runIdent $ f a
91+qualifiedToStr m f (Qualified (Just m') a) | m /= m' = moduleNameToCpp m' ++ "::" ++ identToCpp (f a)
92+qualifiedToStr _ f (Qualified _ a) = identToCpp (f a)
93+
94+boolType :: CppType
95+boolType = CppPrimitive "bool"
96+
97+intType :: CppType
98+intType = CppPrimitive "long"
99+
100+doubleType :: CppType
101+doubleType = CppPrimitive "double"
102+
103+stringType :: CppType
104+stringType = CppPrimitive "string"
105+
106+charType :: CppType
107+charType = CppPrimitive "char"
108+
109+mapType :: CppType
110+mapType = CppPrimitive "any::map"
111+
112+arrayType :: CppType
113+arrayType = CppPrimitive "any::vector"
114+
115+thunkMarkerType :: CppType
116+thunkMarkerType = CppPrimitive "any::as_thunk"
117+
118+unthunkMarkerValue :: String
119+unthunkMarkerValue = "any::unthunk"
120+
121+ctorKey :: String
122+ctorKey = "constructor"
src/Language/PureScript/Pretty/Cpp.hsnew file+426
@@ -0,0 +1,426 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Cpp
4+-- Copyright : (c) 2013-15 Phil Freeman, Andy Arvanitis, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Pretty printer for the C++11 AST
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE PatternGuards #-}
17+{-# LANGUAGE CPP #-}
18+
19+module Language.PureScript.Pretty.Cpp (
20+ dotsTo,
21+ linebreak,
22+ prettyPrintCpp,
23+) where
24+
25+import Data.Char
26+import Data.List
27+import Data.Maybe (fromMaybe)
28+
29+#if __GLASGOW_HASKELL__ < 710
30+import Control.Applicative
31+#endif
32+import Control.Arrow ((<+>))
33+import Control.Monad.State
34+import Control.PatternArrows
35+import qualified Control.Arrow as A
36+
37+import Language.PureScript.CodeGen.Cpp.AST
38+import Language.PureScript.CodeGen.Cpp.Types
39+import Language.PureScript.Comments
40+import Language.PureScript.Pretty.Common
41+import qualified Language.PureScript.Constants as C
42+
43+import Numeric
44+
45+-- import Debug.Trace
46+
47+literals :: Pattern PrinterState Cpp String
48+literals = mkPattern' match
49+ where
50+ match :: Cpp -> StateT PrinterState Maybe String
51+ match CppNoOp = return []
52+ match CppEndOfHeader = return []
53+ match (CppNumericLiteral (Left n)) = return $ show n ++ "L"
54+ match (CppNumericLiteral n) = return $ either show show n
55+ match (CppStringLiteral s) = return $ string s
56+ match (CppStringLiteralHash s) = return $ "HASH" ++ parens (string s)
57+ match (CppCharLiteral c) = return $ show c
58+ match (CppBooleanLiteral True) = return "true"
59+ match (CppBooleanLiteral False) = return "false"
60+ match (CppArrayLiteral [x@CppArrayLiteral {}]) = -- Works around what appears to be a recent clang bug
61+ fmap concat $ sequence
62+ [ return $ runType arrayType
63+ , return "{ { "
64+ , prettyPrintCpp' x
65+ , return " } }"
66+ ]
67+ match (CppArrayLiteral xs) = fmap concat $ sequence
68+ [ return $ runType arrayType
69+ , return "{ "
70+ , fmap (intercalate ", ") $ forM xs prettyPrintCpp'
71+ , return " }"
72+ ]
73+ match (CppObjectLiteral ps) = fmap concat $ sequence
74+ [ return $ runType mapType ++ "{\n"
75+ , withIndent $ do
76+ cpps <- forM ps $ \(key, value) -> do
77+ val <- prettyPrintCpp' value
78+ return $ "{ KEY" ++ parens(show key) ++ ", " ++ val ++ " }"
79+ indentString <- currentIndent
80+ return $ intercalate ", \n" $ map (indentString ++) cpps
81+ , return "\n"
82+ , currentIndent
83+ , return "}"
84+ ]
85+ match (CppFunction name args rty qs ret) =
86+ fmap concat $ sequence
87+ [ return . concatMap (++ " ") . filter (not . null) $ runValueQual <$> qs
88+ , return "auto "
89+ , return name
90+ , return $ parens (intercalate ", " $ argstr <$> args)
91+ , return (maybe "" ((" -> " ++) . runType) rty)
92+ , if ret /= CppNoOp
93+ then do
94+ cpps <- prettyPrintCpp' ret
95+ return $ ' ' : cpps
96+ else return ""
97+ ]
98+ match (CppBlock sts) = fmap concat $ sequence
99+ [ return "{\n"
100+ , withIndent $ prettyStatements sts
101+ , return $ if null sts then "" else "\n"
102+ , currentIndent
103+ , return "}"
104+ ]
105+ match (CppNamespace _ []) = return []
106+ match (CppNamespace (':':':':name) sts) = fmap concat $ sequence $
107+ [ return "\n"
108+ , currentIndent
109+ , return $ "namespace " ++ (dotsTo '_' name) ++ " {\n"
110+ , withIndent $ prettyStatements sts
111+ , return "\n"
112+ , currentIndent
113+ , return "}"
114+ ]
115+ match (CppNamespace name sts) = fmap concat $ sequence $
116+ [ return "\n"
117+ , currentIndent
118+ , return $ "namespace " ++ (dotsTo '_' name) ++ " {\n"
119+ , withIndent $ prettyStatements sts'
120+ , return "\n"
121+ , currentIndent
122+ , return "}"
123+ ]
124+ ++ let (cpp', cpps') = fromNested nested' in
125+ map match cpp'
126+ ++ if null cpps' then [] else [match (CppNamespace name (filter isUseNamespace sts ++ cpps'))]
127+ where
128+ (sts', nested') = break isNestedNamespace sts
129+ fromNested :: [Cpp] -> ([Cpp], [Cpp])
130+ fromNested [] = ([],[])
131+ fromNested cpps@((CppNamespace nm _):_) = ([foldl1 combineNamespaces namespaces], others)
132+ where
133+ (namespaces, others) = span inSameNamespace cpps
134+ inSameNamespace :: Cpp -> Bool
135+ inSameNamespace (CppNamespace nm' _) | nm' == nm = True
136+ inSameNamespace _ = False
137+ fromNested _ = error "Not a nested namespace"
138+ combineNamespaces :: Cpp -> Cpp -> Cpp
139+ combineNamespaces (CppNamespace nm ss) (CppNamespace nm' ss')
140+ | nm == nm' = CppNamespace nm (ss ++ filter (not . isUseNamespace) ss')
141+ combineNamespaces _ _ = error "Cannot fold cpps"
142+ isUseNamespace :: Cpp -> Bool
143+ isUseNamespace (CppUseNamespace{}) = True
144+ isUseNamespace _ = False
145+ match (CppInclude path name) =
146+ let fullpath
147+ | null path = last . words . dotsTo ' ' $ name
148+ | otherwise = (dotsTo '/' path) ++ '/' : (last . words . dotsTo ' ' $ name) in
149+ fmap concat $ sequence
150+ [ return $ "#include \"" ++ fullpath ++ ".hh\""
151+ ]
152+ match (CppUseNamespace name) = fmap concat $ sequence
153+ [ return $ "using namespace " ++ (dotsTo '_' name)
154+ ]
155+ match (CppTypeAlias (newName, newTyps) typ spec) =
156+ let typ' = runType typ
157+ (tmps, name') = if null newTyps
158+ then ([], typ')
159+ else ([return (templDecl newTyps), return "\n", currentIndent], typ')
160+ in fmap concat $ sequence $
161+ tmps ++
162+ [ return $ "using "
163+ , return newName
164+ , return " = "
165+ , return $ if null spec then name' else spec ++ angles name'
166+ ]
167+ match (CppCast typ val) = return $
168+ case val of
169+ CppNumericLiteral {} -> vstr
170+ CppStringLiteral {} -> vstr
171+ CppBooleanLiteral {} -> vstr
172+ _ -> val' ++ ".cast" ++ angles (runType typ) ++ parens []
173+ where
174+ vstr = prettyPrintCpp1 val
175+ val' | '(' `elem` vstr || '[' `elem` vstr = parens vstr
176+ | otherwise = vstr
177+
178+ match (CppVar ident) = return ident
179+ match (CppApp v [CppNoOp]) = return (prettyPrintCpp1 v)
180+ match (CppVariableIntroduction (ident, _) _ (Just value))
181+ | ident == C.__unused = fmap concat $ sequence
182+ [ prettyPrintCpp' value
183+ ]
184+ match (CppVariableIntroduction (ident, typ) qs value) =
185+ fmap concat $ sequence
186+ [ return . concatMap (++ " ") . filter (not . null) $ runValueQual <$> qs
187+ , return (maybe "any" runType typ ++ " ")
188+ , return ident
189+ , maybe (return "") (fmap (" = " ++) . prettyPrintCpp') value
190+ ]
191+ match (CppAssignment target value) = fmap concat $ sequence
192+ [ prettyPrintCpp' target
193+ , return " = "
194+ , prettyPrintCpp' value
195+ ]
196+ match (CppWhile cond sts) = fmap concat $ sequence
197+ [ return "while ("
198+ , prettyPrintCpp' cond
199+ , return ") "
200+ , prettyPrintCpp' sts
201+ ]
202+ match (CppIfElse cond thens elses) = fmap concat $ sequence
203+ [ return "if ("
204+ , prettyPrintCpp' cond
205+ , return ") "
206+ , prettyPrintCpp' thens
207+ , maybe (return "") (fmap (" else " ++) . prettyPrintCpp') elses
208+ ]
209+ match (CppReturn (CppBlock (cpp:cpps))) = fmap concat $ sequence
210+ [ do s <- prettyPrintCpp' cpp
211+ return $ dropWhile isSpace s
212+ , return $ if null cpps then "" else "\n"
213+ , prettyStatements cpps
214+ ]
215+ match (CppReturn value) = fmap concat $ sequence
216+ [ return "return "
217+ , prettyPrintCpp' value
218+ ]
219+ match (CppThrow value) = fmap concat $ sequence
220+ [ return "throw "
221+ , prettyPrintCpp' value
222+ ]
223+ match CppContinue = return "continue;"
224+ match (CppComment [] cpp) = match cpp
225+ match (CppComment com cpp) = fmap concat $ sequence $
226+ [ return "\n"
227+ , currentIndent
228+ , return "/**\n"
229+ ] ++
230+ map asLine (concatMap commentLines com) ++
231+ [ currentIndent
232+ , return " */\n"
233+ , currentIndent
234+ , prettyPrintCpp' cpp
235+ ]
236+ where
237+ commentLines :: Comment -> [String]
238+ commentLines (LineComment s) = [s]
239+ commentLines (BlockComment s) = lines s
240+
241+ asLine :: String -> StateT PrinterState Maybe String
242+ asLine s = do
243+ i <- currentIndent
244+ return $ i ++ " * " ++ removeComments s ++ "\n"
245+
246+ removeComments :: String -> String
247+ removeComments ('*' : '/' : s) = removeComments s
248+ removeComments (c : s) = c : removeComments s
249+
250+ removeComments [] = []
251+ match (CppRaw cpp) = return cpp
252+ match _ = mzero
253+
254+string :: String -> String
255+string s = '"' : concatMap encodeChar s ++ "\""
256+ where
257+ encodeChar :: Char -> String
258+ encodeChar '\b' = "\\b"
259+ encodeChar '\t' = "\\t"
260+ encodeChar '\n' = "\\n"
261+ encodeChar '\v' = "\\v"
262+ encodeChar '\f' = "\\f"
263+ encodeChar '\r' = "\\r"
264+ encodeChar '"' = "\\\""
265+ encodeChar '\\' = "\\\\"
266+ encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""
267+ encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""
268+ encodeChar c = [c]
269+
270+accessor :: Pattern PrinterState Cpp (String, Cpp)
271+accessor = mkPattern match
272+ where
273+ match (CppAccessor prop val) = Just (prettyPrintCpp1 prop, val)
274+ match _ = Nothing
275+
276+indexer :: Pattern PrinterState Cpp (String, Cpp)
277+indexer = mkPattern' match
278+ where
279+ match (CppIndexer index@(CppNumericLiteral {}) val) = (,) <$> prettyPrintCpp' index <*> pure val
280+ match (CppIndexer index@(CppStringLiteral {}) val) = (,) <$> (liftM (("KEY" ++) . parens) . prettyPrintCpp') index <*> pure val
281+ match _ = mzero
282+
283+lam :: Pattern PrinterState Cpp ((String, [(String, Maybe CppType)], Maybe CppType), Cpp)
284+lam = mkPattern match
285+ where
286+ match (CppLambda caps args rty ret) =
287+ Just ((concatMap runCaptureType caps, args, rty), ret)
288+ match _ = Nothing
289+
290+app :: Pattern PrinterState Cpp (String, Cpp)
291+app = mkPattern' match
292+ where
293+ match (CppApp _ [CppNoOp]) = mzero
294+ match (CppApp val args) = do
295+ cpps <- mapM prettyPrintCpp' args
296+ return (intercalate ", " cpps, val)
297+ match _ = mzero
298+
299+unary' :: CppUnaryOp -> (Cpp -> String) -> Operator PrinterState Cpp String
300+unary' op mkStr = Wrap match (++)
301+ where
302+ match :: Pattern PrinterState Cpp (String, Cpp)
303+ match = mkPattern match'
304+ where
305+ match' (CppUnary op' val) | op' == op = Just (mkStr val, val)
306+ match' _ = Nothing
307+
308+unary :: CppUnaryOp -> String -> Operator PrinterState Cpp String
309+unary op str = unary' op (const str)
310+
311+negateOperator :: Operator PrinterState Cpp String
312+negateOperator = unary' CppNegate (\v -> if isNegate v then "- " else "-")
313+ where
314+ isNegate (CppUnary CppNegate _) = True
315+ isNegate _ = False
316+
317+binary :: BinaryOp -> String -> Operator PrinterState Cpp String
318+binary op str = AssocL match (\v1 v2 -> v1 ++ str ++ v2)
319+ where
320+ match :: Pattern PrinterState Cpp (Cpp, Cpp)
321+ match = mkPattern match'
322+ where
323+ match' (CppBinary op' v1 v2) | op' == op = Just (v1, v2)
324+ match' _ = Nothing
325+
326+prettyStatements :: [Cpp] -> StateT PrinterState Maybe String
327+prettyStatements sts = do
328+ cpps <- forM (filter (not . isNoOp) sts) prettyPrintCpp'
329+ indentString <- currentIndent
330+ return $ intercalate "\n" $ map (addsemi . (indentString ++)) cpps
331+ where
332+ addsemi :: String -> String
333+ addsemi [] = []
334+ addsemi s | all isSpace s = []
335+ addsemi s@('#':_) = s
336+ addsemi s = s ++ ";"
337+
338+-- |
339+-- Generate a pretty-printed string representing a C++11 expression
340+--
341+prettyPrintCpp1 :: Cpp -> String
342+prettyPrintCpp1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintCpp'
343+
344+-- |
345+-- Generate a pretty-printed string representing a collection of C++11 expressions at the same indentation level
346+--
347+prettyPrintCpp :: [Cpp] -> String
348+prettyPrintCpp = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements
349+
350+-- |
351+-- Generate an indented, pretty-printed string representing a C++11 expression
352+--
353+prettyPrintCpp' :: Cpp -> StateT PrinterState Maybe String
354+prettyPrintCpp' = A.runKleisli $ runPattern matchValue
355+ where
356+ matchValue :: Pattern PrinterState Cpp String
357+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
358+ operators :: OperatorTable PrinterState Cpp String
359+ operators =
360+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "::" ++ prop ]
361+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
362+ , [ Wrap app $ \args val -> val ++ parens args ]
363+ , [ unary CppNew "new " ]
364+ , [ Wrap lam $ \(caps, args, rty) ret -> '[' : caps ++ "]"
365+ ++ let args' = argstr <$> args in
366+ parens (intercalate ", " args')
367+ ++ maybe "" ((" -> " ++) . runType) rty
368+ ++ " "
369+ ++ ret ]
370+ , [ unary CppNot "!"
371+ , unary CppBitwiseNot "~"
372+ , unary CppPositive "+"
373+ , negateOperator ]
374+ , [ binary Multiply " * "
375+ , binary Divide " / "
376+ , binary Modulus " % "
377+ , binary Dot "." ]
378+ , [ binary Add " + "
379+ , binary Subtract " - " ]
380+ , [ binary ShiftLeft " << "
381+ , binary ShiftRight " >> " ]
382+ , [ binary LessThan " < "
383+ , binary LessThanOrEqual " <= "
384+ , binary GreaterThan " > "
385+ , binary GreaterThanOrEqual " >= "
386+ , binary Equal " == "
387+ , binary NotEqual " != " ]
388+ , [ binary BitwiseAnd " & " ]
389+ , [ binary BitwiseXor " ^ " ]
390+ , [ binary BitwiseOr " | " ]
391+ , [ binary And " && " ]
392+ , [ binary Or " || " ]
393+ ]
394+
395+dotsTo :: Char -> String -> String
396+dotsTo chr' = map (\c -> if c == '.' then chr' else c)
397+
398+argstr :: (String, Maybe CppType) -> String
399+argstr (name, Nothing) = argStr name CppAuto
400+argstr (name, Just typ) | name == C.__unused = argStr [] typ
401+argstr (name, Just typ) = argStr name typ
402+
403+argStr :: String -> CppType -> String
404+argStr name typ = runType typ ++ if null name then [] else " " ++ name
405+
406+templDecl :: [(String, Int)] -> String
407+templDecl ps = "template " ++ angles (intercalate ", " (go <$> ps))
408+ where
409+ go :: (String, Int) -> String
410+ go (name, 0) = "typename " ++ name
411+ go (name, n) = "typename" ++ parens (intercalate "," $ replicate n "typename") ++ ' ' : name
412+
413+isNestedNamespace :: Cpp -> Bool
414+isNestedNamespace (CppNamespace (':':':':_) _) = True
415+isNestedNamespace _ = False
416+
417+angles :: String -> String
418+angles s = '<' : s ++ ">"
419+
420+linebreak :: [Cpp]
421+linebreak = [CppRaw ""]
422+
423+isNoOp :: Cpp -> Bool
424+isNoOp CppNoOp = True
425+isNoOp (CppComment [] CppNoOp) = True
426+isNoOp _ = False