git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge branch 'pure11' into pure11-0.9
d4c9de2Andy Arvanitis
pcc/Main.hsnew file+179
compare with golang
unifiedsplit
@@ -0,0 +1,179 @@
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+import System.IO.UTF8
35+
36+import qualified Language.PureScript as P
37+import qualified Paths_purescript as Paths
38+
39+import Make
40+import Makefile
41+
42+data PCCOptions = PCCOptions
43+ { pccmInput :: [FilePath]
44+ , pccmForeignInput :: [FilePath]
45+ , pccmOutputDir :: FilePath
46+ , pccmOpts :: P.Options
47+ , pccmUsePrefix :: Bool
48+ }
49+
50+data InputOptions = InputOptions
51+ { ioInputFiles :: [FilePath]
52+ }
53+
54+compile :: PCCOptions -> IO ()
55+compile (PCCOptions input _ outputDir opts usePrefix) = do
56+ when (null input) generateMakefile
57+ moduleFiles <- readInput (InputOptions input)
58+ case runWriterT (parseInputs moduleFiles []) of
59+ Left errs -> do
60+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
61+ exitFailure
62+ Right ((ms, _), warnings) -> do
63+ when (P.nonEmpty warnings) $
64+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
65+ let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms
66+ makeActions = buildMakeActions outputDir filePathMap usePrefix
67+ (e, warnings') <- runMake opts $ P.make makeActions (map snd ms)
68+ case e of
69+ Left errs -> do
70+ putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
71+ exitFailure
72+ Right _ -> exitSuccess
73+
74+readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
75+readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File 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+sourceMaps :: Parser Bool
149+sourceMaps = switch $
150+ long "source-maps"
151+ <> help "Generate source maps"
152+
153+options :: Parser P.Options
154+options = P.Options <$> noTco
155+ <*> noMagicDo
156+ <*> pure Nothing
157+ <*> noOpts
158+ <*> verboseErrors
159+ <*> (not <$> comments)
160+ <*> requirePath
161+ <*> sourceMaps
162+
163+pccOptions :: Parser PCCOptions
164+pccOptions = PCCOptions <$> many inputFile
165+ <*> many inputForeignFile
166+ <*> outputDirectory
167+ <*> options
168+ <*> (not <$> noPrefix)
169+
170+main :: IO ()
171+main = execParser opts >>= compile
172+ where
173+ opts = info (version <*> helper <*> pccOptions) infoModList
174+ infoModList = fullDesc <> headerInfo <> footerInfo
175+ headerInfo = header "pcc - Compiles PureScript to C++11"
176+ footerInfo = footer $ "pcc " ++ showVersion Paths.version
177+
178+ version :: Parser (a -> a)
179+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
pcc/Make.hsnew file+175
@@ -0,0 +1,175 @@
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.Reader
30+
31+import Data.FileEmbed (embedFile)
32+import Data.List (intercalate)
33+import Data.Maybe (fromMaybe)
34+import Data.String (fromString)
35+import Data.Time.Clock
36+import Data.Version (showVersion)
37+import qualified Data.Map as M
38+import qualified Data.ByteString.Char8 as B
39+
40+import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime, createDirectoryIfMissing)
41+import System.FilePath ((</>), takeDirectory, addExtension, dropExtension)
42+import System.IO.Error (tryIOError)
43+import System.IO.UTF8
44+
45+import Language.PureScript.Errors
46+import Language.PureScript (Make, runMake)
47+
48+import qualified Language.PureScript as P
49+import qualified Language.PureScript.CodeGen.Cpp as CPP
50+import qualified Language.PureScript.CoreFn as CF
51+import qualified Paths_purescript as Paths
52+
53+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
54+makeIO f io = do
55+ e <- liftIO $ tryIOError io
56+ either (throwError . P.singleError . f) return e
57+
58+-- Traverse (Either e) instance (base 4.7)
59+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
60+traverseEither _ (Left x) = pure (Left x)
61+traverseEither f (Right y) = Right <$> f y
62+
63+buildMakeActions :: FilePath
64+ -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
65+ -> Bool
66+ -> P.MakeActions Make
67+buildMakeActions outputDir filePathMap usePrefix =
68+ P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
69+ where
70+
71+ getInputFile :: P.ModuleName -> FilePath
72+ getInputFile mn =
73+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap in
74+ case path of
75+ Right path' -> path'
76+ Left _ -> error "Module has no filename in 'make'"
77+
78+ getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
79+ getInputTimestamp mn = do
80+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
81+ traverseEither getTimestamp path
82+
83+ getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
84+ getOutputTimestamp mn = do
85+
86+ let filePath = dotsTo '/' $ P.runModuleName mn
87+ fileBase = outputDir </> filePath </> (last . words . dotsTo ' ' $ P.runModuleName mn)
88+ srcFile = addExtension fileBase "cc"
89+-- headerFile = addExtension fileBase "hh"
90+ externsFile = outputDir </> filePath </> "externs.purs"
91+ min <$> getTimestamp srcFile <*> getTimestamp externsFile
92+
93+ readExterns :: P.ModuleName -> Make (FilePath, P.Externs)
94+ readExterns mn = do
95+ let path = outputDir </> (dotsTo '/' $ P.runModuleName mn) </> "externs.purs"
96+ (path, ) <$> readTextFile path
97+
98+ codegen :: CF.Module CF.Ann -> P.Environment -> P.Externs -> P.SupplyT Make ()
99+ codegen m env exts = do
100+ let mn = CF.moduleName m
101+ let filePath = dotsTo '/' $ P.runModuleName mn
102+ fileBase = outputDir </> filePath </> (last . words . dotsTo ' ' $ P.runModuleName mn)
103+ srcFile = addExtension fileBase "cc"
104+ headerFile = addExtension fileBase "hh"
105+ externsFile = outputDir </> filePath </> "externs.purs"
106+ prefix = ["Generated by pcc version " ++ showVersion Paths.version | usePrefix]
107+ cpps <- CPP.moduleToCpp env m
108+ let (hdrs,srcs) = span (/= CPP.CppEndOfHeader) cpps
109+ psrcs <- CPP.prettyPrintCpp <$> pure srcs
110+ phdrs <- CPP.prettyPrintCpp <$> pure hdrs
111+ let src = unlines $ map ("// " ++) prefix ++ [psrcs]
112+ hdr = unlines $ map ("// " ++) prefix ++ [phdrs]
113+
114+ lift $ do
115+ writeTextFile srcFile src
116+ writeTextFile headerFile hdr
117+ writeTextFile externsFile exts
118+
119+ let supportDir = outputDir </> "PureScript"
120+ supportFilesExist <- dirExists supportDir
121+ when (not supportFilesExist) $ do
122+ writeTextFile (supportDir </> "PureScript.hh") $ B.unpack $(embedFile "pcc/include/purescript.hh")
123+ writeTextFile (supportDir </> "PureScript.cc") $ B.unpack $(embedFile "pcc/include/purescript.cc")
124+ writeTextFile (supportDir </> "purescript_memory.hh") $ B.unpack $(embedFile "pcc/include/purescript_memory.hh")
125+
126+ let inputPath = dropExtension $ getInputFile mn
127+ hfile = addExtension inputPath "hh"
128+ sfile = addExtension inputPath "cc"
129+ hfileExists <- textFileExists hfile
130+ when (hfileExists || requiresForeign m) $ do
131+ text <- if hfileExists
132+ then readTextFile hfile
133+ else pure []
134+ writeTextFile (addExtension (fileBase ++ "_ffi") "hh") text
135+ sfileExists <- textFileExists sfile
136+ when (sfileExists) $ do
137+ text' <- readTextFile sfile
138+ writeTextFile (addExtension (fileBase ++ "_ffi") "cc") text'
139+
140+ requiresForeign :: CF.Module a -> Bool
141+ requiresForeign = not . null . CF.moduleForeign
142+
143+ dirExists :: FilePath -> Make Bool
144+ dirExists path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ do
145+ doesDirectoryExist path
146+
147+ textFileExists :: FilePath -> Make Bool
148+ textFileExists path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ do
149+ doesFileExist path
150+
151+ getTimestamp :: FilePath -> Make (Maybe UTCTime)
152+ getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
153+ exists <- doesFileExist path
154+ traverse (const $ getModificationTime path) $ guard exists
155+
156+ readTextFile :: FilePath -> Make String
157+ readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
158+
159+ writeTextFile :: FilePath -> String -> Make ()
160+ writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
161+ mkdirp path
162+ writeFile path text
163+ where
164+ mkdirp :: FilePath -> IO ()
165+ mkdirp = createDirectoryIfMissing True . takeDirectory
166+
167+ -- | Render a progress message
168+ renderProgressMessage :: P.ProgressMessage -> String
169+ renderProgressMessage (P.CompilingModule mn) = "Compiling " ++ P.runModuleName mn
170+
171+ progress :: P.ProgressMessage -> Make ()
172+ progress = liftIO . putStrLn . renderProgressMessage
173+
174+dotsTo :: Char -> String -> String
175+dotsTo chr = map (\c -> if c == '.' then chr else c)
pcc/Makefilenew file+68
@@ -0,0 +1,68 @@
1+# PureScript to native binary (via C++) Makefile
2+#
3+# Run 'make' or 'make release' to build an optimized release build
4+# Run 'make debug' to build a non-optimized build suitable for debugging
5+#
6+# You can also perform a parallel build with 'make -jN', where N is the
7+# number of cores to use.
8+#
9+# PCC, PURESCRIPT_PKGS, OUTPUT, and BIN can all be overridden with the
10+# command itself. For example: 'make PURESCRIPT_PKGS=../gitpackages BIN=myexe'
11+#
12+# Flags can be added to either the codegen or native build phases.
13+# For example: 'make PCCFLAGS=--no-tco CXXFLAGS=-DDEBUG LDFLAGS=lobjc'
14+#
15+# You can also edit the generated version of this file directly.
16+#
17+PCC := {bin/pcc} # example: /usr/local/bin/pcc
18+PURESCRIPT_PKGS := packages # example: bower_components
19+PURESCRIPT_SRC := src
20+OUTPUT := output
21+BIN := main
22+
23+override PCCFLAGS += --comments
24+override CXXFLAGS += -std=c++11
25+override LDFLAGS +=
26+
27+ifneq ($(GC),no)
28+ override CXXFLAGS += -DUSE_GC
29+ override LDFLAGS += -lgc
30+endif
31+
32+DEBUG := "-DDEBUG -g"
33+RELEASE := "-O3 -flto"
34+
35+PURESCRIPT_PKG_SRCS := $(shell find $(PURESCRIPT_PKGS) -name '*.purs' | grep -v \/test\/ | grep -v \/example\/ | grep -v \/examples\/)
36+PURESCRIPT_SRCS := $(shell find $(PURESCRIPT_SRC) -name '*.purs')
37+
38+INCLUDES := -I $(OUTPUT)
39+BIN_DIR := $(OUTPUT)/bin
40+
41+release: codegen
42+ @$(MAKE) $(BIN) CXXFLAGS+=$(RELEASE)
43+
44+debug: codegen
45+ @$(MAKE) $(BIN) CXXFLAGS+=$(DEBUG)
46+
47+codegen:
48+ @$(PCC) $(PCCFLAGS) --output $(OUTPUT) $(PURESCRIPT_PKG_SRCS) $(PURESCRIPT_SRCS)
49+
50+SRCS := $(shell find $(OUTPUT) 2>/dev/null -name '*.cc')
51+
52+OBJS = $(SRCS:.cc=.o)
53+DEPS = $(SRCS:.cc=.d)
54+
55+$(BIN): $(OBJS)
56+ @echo "Linking" $(BIN_DIR)/$(BIN)
57+ @mkdir -p $(BIN_DIR)
58+ @$(CXX) $(LDFLAGS) $^ -o $(BIN_DIR)/$@
59+
60+-include $(DEPS)
61+
62+%.o: %.cc
63+ @echo "Creating" $@
64+ @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@
65+
66+.PHONY: clean
67+clean:
68+ @-rm -rf $(OUTPUT)
pcc/Makefile.hsnew file+50
@@ -0,0 +1,50 @@
1+-------------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) 2016 Andy Arvanitis and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Andy Arvanitis
8+-- Stability : experimental
9+-- Portability :
10+--
11+-------------------------------------------------------------------------------
12+{-# LANGUAGE OverloadedStrings #-}
13+{-# LANGUAGE TemplateHaskell #-}
14+
15+module Makefile where
16+
17+import Control.Monad (when)
18+import Data.FileEmbed (embedFile)
19+import Data.List
20+import System.Environment (getExecutablePath)
21+import System.Directory (doesFileExist)
22+
23+import qualified Data.ByteString.Char8 as B
24+
25+generateMakefile :: IO ()
26+generateMakefile = do
27+ makefileExists <- doesFileExist "Makefile"
28+ when (not makefileExists) $ do
29+ let makefile = $(embedFile "pcc/Makefile")
30+ exePath <- getExecutablePath
31+ putStrLn ""
32+ putStrLn "Generating Makefile..."
33+ putStrLn $ "pcc executable location: " ++ exePath
34+ writeFile "Makefile" $ replace makefile pccPath exePath
35+ putStrLn "Done"
36+ putStrLn "Run 'make' or 'make release' to build an optimized release build."
37+ putStrLn "The resulting binary executable will be located in output/bin (by default)."
38+ putStrLn ""
39+
40+replace :: B.ByteString -> B.ByteString -> String -> String
41+replace s orig repl = replace'
42+ where
43+ replace'
44+ | (p1, p2) <- B.breakSubstring orig s,
45+ not (B.null p2) = B.unpack p1 ++ repl ++ trim (B.unpack p2)
46+ | otherwise = B.unpack s
47+ trim = drop (B.length orig)
48+
49+pccPath :: B.ByteString
50+pccPath = "{bin/pcc}"
pcc/TestMain.hsnew file+120
@@ -0,0 +1,120 @@
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 passingDir = baseDir </> "examples" </> "passing"
48+ passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir
49+
50+ -- Auto-generate Makefile
51+ setCurrentDirectory outputDir
52+ callProcess "../.cabal-sandbox/bin/pcc" []
53+
54+ let tests = filter (`notElem` skipped) passingTestCases
55+
56+ -- Run the tests
57+ --
58+ forM_ tests $ \inputFile -> do
59+ --
60+ -- Compile/build
61+ --
62+ putStrLn $ "Compiling test " ++ inputFile ++ " ..."
63+ setCurrentDirectory outputDir
64+ copyFile (passingDir </> inputFile) (srcDir </> inputFile)
65+ callProcess "make" ["clean"]
66+ callProcess "make" ["debug"]
67+ --
68+ -- Run C++ files
69+ --
70+ callProcess ("output" </> "bin" </> "main") []
71+
72+ removeFile (srcDir </> inputFile)
73+
74+ -- TODO: support failing test cases
75+ --
76+ -- let failing = baseDir </> "examples" </> "failing"
77+ -- failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
78+ --
79+
80+ setCurrentDirectory baseDir
81+ putStrLn "pcc-tests finished"
82+ putStrLn $ "Total tests available: " ++ show (length passingTestCases)
83+ putStrLn $ "Tests run: " ++ show (length tests)
84+ putStrLn $ "Tests skipped: " ++ show (length skipped)
85+
86+-------------------------------------------------------------------------------
87+repo :: String
88+-------------------------------------------------------------------------------
89+repo = "git://github.com/pure11/"
90+
91+-------------------------------------------------------------------------------
92+packages :: [(String, String)]
93+-------------------------------------------------------------------------------
94+packages =
95+ [ ("purescript-eff", "")
96+ , ("purescript-prelude", "")
97+ , ("purescript-assert", "")
98+ , ("purescript-st", "")
99+ , ("purescript-console", "")
100+ , ("purescript-functions", "")
101+ ]
102+
103+-------------------------------------------------------------------------------
104+fetchPackages :: IO ()
105+-------------------------------------------------------------------------------
106+fetchPackages = do
107+ (outputDir, baseDir) <- testsDir
108+ let packageDir = outputDir </> "packages"
109+ createDirectory packageDir
110+ setCurrentDirectory packageDir
111+ forM_ packages $ \package -> let branch = snd package in
112+ callProcess "git" $ ["clone"] ++ (if null branch then [] else ["--branch", branch]) ++ [repo ++ (fst package) ++ ".git"]
113+ setCurrentDirectory baseDir
114+
115+-------------------------------------------------------------------------------
116+skipped :: [String]
117+-------------------------------------------------------------------------------
118+skipped =
119+ [ "ExplicitImportReExport.purs" -- OK, test has no main (would pass otherwise)
120+ ]
pcc/include/purescript.ccnew file+310
@@ -0,0 +1,310 @@
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 <cstring>
16+#include "PureScript.hh"
17+
18+namespace PureScript {
19+
20+#define RETURN_VALUE(TYPE, ACCESSOR, INDIRECTION) \
21+ const any& variant = unthunkVariant(*this); \
22+ assert(variant.type == TYPE); \
23+ return INDIRECTION(variant.ACCESSOR); \
24+
25+auto any::operator()(const any& arg) const -> any {
26+ const any& variant = unthunkVariant(*this);
27+ if (variant.type == Type::Closure) {
28+ return (*variant.l)(arg);
29+ }
30+ assert(variant.type == Type::Function);
31+ return (*variant.f)(arg);
32+}
33+
34+auto any::operator()(const as_thunk) const -> const any& {
35+ assert(type == Type::Thunk);
36+ return (*t)(unthunk);
37+}
38+
39+auto any::operator()() const -> any {
40+ const any& variant = unthunkVariant(*this);
41+ if (variant.type == Type::EffClosure) {
42+ return (*variant.k)();
43+ }
44+ assert(variant.type == Type::EffFunction);
45+ return (*variant.e)();
46+}
47+
48+any::operator integer() const {
49+ RETURN_VALUE(Type::Integer, i,)
50+}
51+
52+any::operator double() const {
53+ RETURN_VALUE(Type::Double, d,)
54+}
55+
56+any::operator bool() const {
57+ RETURN_VALUE(Type::Boolean, b,)
58+}
59+
60+any::operator char() const {
61+ RETURN_VALUE(Type::Character, c,)
62+}
63+
64+any::operator cstring() const {
65+ const any& variant = unthunkVariant(*this);
66+ if (variant.type == Type::StringLiteral) {
67+ return variant.r;
68+ }
69+ assert(variant.type == Type::String);
70+ return variant.s->c_str();
71+}
72+
73+any::operator const map&() const {
74+ RETURN_VALUE(Type::Map, m, *)
75+}
76+
77+any::operator const data&() const {
78+ RETURN_VALUE(Type::Data, v, *)
79+}
80+
81+any::operator const array&() const {
82+ RETURN_VALUE(Type::Array, a, *)
83+}
84+
85+auto any::extractPointer() const -> void* {
86+ RETURN_VALUE(Type::Pointer, POINTER_FROM_MEMBER(p),)
87+}
88+
89+auto any::unthunkVariant(const any& a) -> const any& {
90+ const any * variant = &a;
91+ while (variant->type == Type::Thunk) {
92+ variant = &((*variant->t)(unthunk));
93+ }
94+ return *variant;
95+}
96+
97+auto any::operator[](const char rhs[]) const -> const any& {
98+ const any& variant = unthunkVariant(*this);
99+ assert(variant.type == Type::Map);
100+ const auto begin = variant.m->cbegin();
101+ const auto end = variant.m->cend();
102+ for (auto it = begin; it != end; ++it) {
103+ if (it->first == rhs) {
104+ return it->second;
105+ }
106+ }
107+ for (auto it = begin; it != end; ++it) {
108+ if (strcmp(it->first, rhs) == 0) {
109+ return it->second;
110+ }
111+ }
112+ throw runtime_error("map key not found");
113+}
114+
115+auto any::operator[](const size_t rhs) const -> const any& {
116+ const any& variant = unthunkVariant(*this);
117+ assert(variant.type == Type::Array);
118+ return (*variant.a)[rhs];
119+}
120+
121+auto any::operator[](const any& rhs) const -> const any& {
122+ const any& variant = unthunkVariant(*this);
123+ assert(variant.type == Type::Array);
124+ return (*variant.a)[cast<integer>(rhs)];
125+}
126+
127+auto any::contains(const char key[]) const -> bool {
128+ const any& variant = unthunkVariant(*this);
129+ assert(variant.type == Type::Map);
130+ const auto begin = variant.m->cbegin();
131+ const auto end = variant.m->cend();
132+ for (auto it = begin; it != end; ++it) {
133+ if (it->first == key) {
134+ return true;
135+ }
136+ }
137+ for (auto it = begin; it != end; ++it) {
138+ if (strcmp(it->first, key) == 0) {
139+ return true;
140+ }
141+ }
142+ return false;
143+}
144+
145+//-----------------------------------------------------------------------------
146+// Operator helper macros
147+//-----------------------------------------------------------------------------
148+
149+#define DEFINE_CSTR_EQUALS_OPERATOR() \
150+ auto operator==(const any& lhs_, const char * rhs) -> bool { \
151+ const any& lhs = any::unthunkVariant(lhs_); \
152+ assert(lhs.type == any::Type::StringLiteral || lhs.type == any::Type::String); \
153+ if (lhs.type == any::Type::StringLiteral) { \
154+ return (lhs.r == rhs) || (strcmp(lhs.r, rhs) == 0); \
155+ } \
156+ return strcmp(lhs.s->c_str(), rhs) == 0; \
157+ } \
158+ auto operator==(const char * lhs, const any& rhs_) -> bool { \
159+ const any& rhs = any::unthunkVariant(rhs_); \
160+ assert(rhs.type == any::Type::StringLiteral || rhs.type == any::Type::String); \
161+ if (rhs.type == any::Type::StringLiteral) { \
162+ return (lhs == rhs.r) || (strcmp(lhs, rhs) == 0); \
163+ } \
164+ return strcmp(lhs, rhs.s->c_str()) == 0; \
165+ }
166+
167+#define DEFINE_CSTR_COMPARISON_OPERATOR(op) \
168+ auto operator op (const any& lhs, const char * rhs) -> bool { \
169+ return strcmp(cast<cstring>(lhs), rhs) op 0; \
170+ } \
171+ auto operator op (const char * lhs, const any& rhs) -> bool { \
172+ return strcmp(lhs, cast<cstring>(rhs)) op 0; \
173+ }
174+
175+#define DEFINE_COMPARISON_OPERATOR(op) \
176+ auto operator op (const any& lhs_, const any& rhs_) -> bool { \
177+ const any& lhs = any::unthunkVariant(lhs_); \
178+ const any& rhs = any::unthunkVariant(rhs_); \
179+ switch (lhs.type) { \
180+ case any::Type::Integer: assert(lhs.type == any::Type::Integer); return lhs.i op rhs.i; \
181+ case any::Type::Double: assert(lhs.type == any::Type::Double); return lhs.d op rhs.d; \
182+ case any::Type::Character: assert(lhs.type == any::Type::Character); return lhs.c op rhs.c; \
183+ case any::Type::Boolean: assert(lhs.type == any::Type::Boolean); return lhs.b op rhs.b; \
184+ case any::Type::StringLiteral: \
185+ assert(lhs.type == any::Type::StringLiteral || lhs.type == any::Type::String); \
186+ assert(rhs.type == any::Type::StringLiteral || rhs.type == any::Type::String); \
187+ return strcmp(lhs.r, rhs.type == any::Type::StringLiteral ? rhs.r : rhs.s->c_str()) op 0; \
188+ case any::Type::String: \
189+ assert(lhs.type == any::Type::StringLiteral || lhs.type == any::Type::String); \
190+ assert(rhs.type == any::Type::StringLiteral || rhs.type == any::Type::String); \
191+ return strcmp(lhs.s->c_str(), rhs.type == any::Type::StringLiteral ? rhs.r : rhs.s->c_str()) op 0; \
192+ case any::Type::Pointer: return lhs.p op rhs.p; \
193+ default: assert(false && "Unsupported type for operator " #op); \
194+ } \
195+ return false; \
196+ }
197+
198+//-----------------------------------------------------------------------------
199+// Operator definitions
200+//-----------------------------------------------------------------------------
201+
202+DEFINE_COMPARISON_OPERATOR(==)
203+DEFINE_COMPARISON_OPERATOR(!=)
204+DEFINE_COMPARISON_OPERATOR(<)
205+DEFINE_COMPARISON_OPERATOR(<=)
206+DEFINE_COMPARISON_OPERATOR(>)
207+DEFINE_COMPARISON_OPERATOR(>=)
208+
209+DEFINE_CSTR_EQUALS_OPERATOR()
210+DEFINE_CSTR_COMPARISON_OPERATOR(!=)
211+DEFINE_CSTR_COMPARISON_OPERATOR(<)
212+DEFINE_CSTR_COMPARISON_OPERATOR(<=)
213+DEFINE_CSTR_COMPARISON_OPERATOR(>)
214+DEFINE_CSTR_COMPARISON_OPERATOR(>=)
215+
216+auto operator+(const any& lhs_, const any& rhs_) -> any {
217+ const any& lhs = any::unthunkVariant(lhs_);
218+ const any& rhs = any::unthunkVariant(rhs_);
219+ switch (lhs.type) {
220+ case any::Type::Integer: assert(lhs.type == any::Type::Integer); return lhs.i + rhs.i;
221+ case any::Type::Double: assert(lhs.type == any::Type::Double); return lhs.d + rhs.d;
222+ case any::Type::Character: assert(lhs.type == any::Type::Character); return any(char(lhs.c + rhs.c));
223+ case any::Type::StringLiteral:
224+ assert(lhs.type == any::Type::StringLiteral || lhs.type == any::Type::String);
225+ assert(rhs.type == any::Type::StringLiteral || rhs.type == any::Type::String);
226+ return rhs.type == any::Type::StringLiteral ? std::string(lhs.r) + rhs.r : lhs.r + *rhs.s;
227+ case any::Type::String:
228+ assert(lhs.type == any::Type::StringLiteral || lhs.type == any::Type::String);
229+ assert(rhs.type == any::Type::StringLiteral || rhs.type == any::Type::String);
230+ return rhs.type == any::Type::StringLiteral ? *lhs.s + rhs.r : *lhs.s + *rhs.s;
231+ default: assert(false && "Unsupported type for '+' operator");
232+ }
233+ return nullptr;
234+}
235+
236+auto operator+(const any& lhs_, const char * rhs) -> std::string {
237+ const any& lhs = any::unthunkVariant(lhs_);
238+ assert(lhs.type == any::Type::StringLiteral || lhs.type == any::Type::String);
239+ return lhs.type == any::Type::StringLiteral ? std::string(lhs.r) + rhs : *lhs.s + rhs;
240+}
241+
242+auto operator+(const char * lhs, const any& rhs_) -> std::string {
243+ const any& rhs = any::unthunkVariant(rhs_);
244+ assert(rhs.type == any::Type::StringLiteral || rhs.type == any::Type::String);
245+ return rhs.type == any::Type::StringLiteral ? lhs + std::string(rhs.r) : lhs + *rhs.s;
246+}
247+
248+auto operator-(const any& lhs_, const any& rhs_) -> any {
249+ const any& lhs = any::unthunkVariant(lhs_);
250+ const any& rhs = any::unthunkVariant(rhs_);
251+ assert(lhs.type == rhs.type);
252+ switch (lhs.type) {
253+ case any::Type::Integer: return lhs.i - rhs.i;
254+ case any::Type::Double: return lhs.d - rhs.d;
255+ case any::Type::Character: return any(char(lhs.c - rhs.c));
256+ default: assert(false && "Unsupported type for '-' operator");
257+ }
258+ return nullptr;
259+}
260+
261+auto operator*(const any& lhs_, const any& rhs_) -> any {
262+ const any& lhs = any::unthunkVariant(lhs_);
263+ const any& rhs = any::unthunkVariant(rhs_);
264+ assert(lhs.type == rhs.type);
265+ switch (lhs.type) {
266+ case any::Type::Integer: return lhs.i * rhs.i;
267+ case any::Type::Double: return lhs.d * rhs.d;
268+ case any::Type::Character: return any(char(lhs.c * rhs.c));
269+ default: assert(false && "Unsupported type for '*' operator");
270+ }
271+ return nullptr;
272+}
273+
274+auto operator/(const any& lhs_, const any& rhs_) -> any {
275+ const any& lhs = any::unthunkVariant(lhs_);
276+ const any& rhs = any::unthunkVariant(rhs_);
277+ assert(lhs.type == rhs.type);
278+ switch (lhs.type) {
279+ case any::Type::Integer: return lhs.i / rhs.i;
280+ case any::Type::Double: return lhs.d / rhs.d;
281+ case any::Type::Character: return any(char(lhs.c / rhs.c));
282+ default: assert(false && "Unsupported type for '/' operator");
283+ }
284+ return nullptr;
285+}
286+
287+auto operator%(const any& lhs_, const any& rhs_) -> any {
288+ const any& lhs = any::unthunkVariant(lhs_);
289+ const any& rhs = any::unthunkVariant(rhs_);
290+ assert(lhs.type == rhs.type);
291+ switch (lhs.type) {
292+ case any::Type::Integer: return lhs.i % rhs.i;
293+ case any::Type::Character: return any(char(lhs.c % rhs.c));
294+ default: assert(false && "Unsupported type for '%' operator");
295+ }
296+ return nullptr;
297+}
298+
299+// unary negate
300+auto operator-(const any& rhs_) -> any {
301+ const any& rhs = any::unthunkVariant(rhs_);
302+ switch (rhs.type) {
303+ case any::Type::Integer: return (- rhs.i);
304+ case any::Type::Double: return (- rhs.d);
305+ default: assert(false && "Unsupported type for unary '-' operator");
306+ }
307+ return nullptr;
308+}
309+
310+} // namespace PureScript
pcc/include/purescript.hhnew file+441
@@ -0,0 +1,441 @@
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 <functional>
29+#include <string>
30+#include <vector>
31+#include <deque>
32+#include <utility>
33+#include <stdexcept>
34+#include <iso646.h> // mostly for MS Visual Studio compiler
35+#include "purescript_memory.hh"
36+
37+namespace PureScript {
38+
39+using integer = std::intptr_t;
40+using cstring = const char *;
41+using nullptr_t = std::nullptr_t;
42+
43+// Workaround for missing C++11 version in gcc
44+class runtime_error : public std::runtime_error {
45+public:
46+ runtime_error(const char message[]) : std::runtime_error(std::string(message)) {}
47+};
48+
49+const integer INTEGER_MIN = INTPTR_MIN;
50+const integer INTEGER_MAX = INTPTR_MAX;
51+
52+const bool undefined = false;
53+const size_t constructor = 0;
54+
55+// A variant data class designed to provide some features of dynamic typing.
56+//
57+class any {
58+
59+ public:
60+ enum class Type {
61+ Thunk = 0x10,
62+ Integer,
63+ Double,
64+ Character,
65+ Boolean,
66+ StringLiteral,
67+ Function,
68+ EffFunction,
69+ RawPointer,
70+ String,
71+ Map,
72+ Data,
73+ Array,
74+ Closure,
75+ EffClosure,
76+ Pointer
77+ };
78+
79+ private:
80+ mutable Type type;
81+
82+ public:
83+ struct as_thunk {
84+ };
85+ static constexpr as_thunk unthunk = as_thunk{};
86+
87+ using map_pair = std::pair<const char * const, const any>;
88+ using map = std::vector<map_pair WITH_ALLOCATOR(map_pair)>;
89+ using data = std::vector<any WITH_ALLOCATOR(any)>;
90+ using array = std::deque<any WITH_ALLOCATOR(any)>;
91+ using fn = auto (*)(const any&) -> any;
92+ using eff_fn = auto (*)() -> any;
93+ using thunk = auto (*)(const as_thunk) -> const any&;
94+
95+ private:
96+ class closure {
97+ public:
98+ virtual auto operator()(const any&) const -> any = 0;
99+ virtual ~closure() {}
100+ };
101+
102+ template <typename T>
103+ class _closure : public closure {
104+ const T lambda;
105+ public:
106+ _closure(const T& l) noexcept : lambda(l) {}
107+ auto operator()(const any& arg) const -> any override {
108+ return lambda(arg);
109+ }
110+ };
111+
112+ class eff_closure {
113+ public:
114+ virtual auto operator()() const -> any = 0;
115+ virtual ~eff_closure() {}
116+ };
117+
118+ template <typename T>
119+ class _eff_closure : public eff_closure {
120+ const T lambda;
121+ public:
122+ _eff_closure(const T& l) noexcept : lambda(l) {}
123+ auto operator()() const -> any override {
124+ return lambda();
125+ }
126+ };
127+
128+ private:
129+ union {
130+ mutable thunk t;
131+ mutable integer i;
132+ mutable double d;
133+ mutable char c;
134+ mutable bool b;
135+ mutable cstring r;
136+ mutable fn f;
137+ mutable eff_fn e;
138+ mutable void * u;
139+ mutable managed<std::string> s;
140+ mutable managed<map> m;
141+ mutable managed<data> v;
142+ mutable managed<array> a;
143+ mutable managed<closure> l;
144+ mutable managed<eff_closure> k;
145+ mutable managed<void> p;
146+ };
147+
148+ public:
149+
150+ any(const integer val) noexcept : type(Type::Integer), i(val) {}
151+ any(const int val) noexcept : type(Type::Integer), i(val) {}
152+ any(const unsigned int val) noexcept : type(Type::Integer), i(val) {}
153+ any(const double val) noexcept : type(Type::Double), d(val) {}
154+ any(const char val) noexcept : type(Type::Character), c(val) {}
155+
156+ template <typename T, typename = typename std::enable_if<std::is_same<bool,T>::value>::type>
157+ any(const T val) noexcept : type(Type::Boolean), b(val) {}
158+
159+ template <size_t N>
160+ any(const char (&val)[N]) noexcept : type(Type::StringLiteral), r(val) {}
161+ any(char * val) : type(Type::String), s(make_managed<std::string>(val)) {}
162+
163+ any(const std::string& val) : type(Type::String), s(make_managed<std::string>(val)) {}
164+ any(std::string&& val) noexcept : type(Type::String), s(make_managed<std::string>(std::move(val))) {}
165+
166+ any(const managed<std::string>& val) noexcept : type(Type::String), s(val) {}
167+ any(managed<std::string>&& val) noexcept : type(Type::String), s(std::move(val)) {}
168+
169+ any(const map& val) : type(Type::Map), m(make_managed<map>(val)) {}
170+ any(map&& val) noexcept : type(Type::Map), m(make_managed<map>(std::move(val))) {}
171+
172+ any(const data& val) : type(Type::Data), v(make_managed<data>(val)) {}
173+ any(data&& val) noexcept : type(Type::Data), v(make_managed<data>(std::move(val))) {}
174+
175+ any(const array& val) : type(Type::Array), a(make_managed<array>(val)) {}
176+ any(array&& val) noexcept : type(Type::Array), a(make_managed<array>(std::move(val))) {}
177+
178+ template <typename T>
179+ any(const T& val, typename std::enable_if<std::is_convertible<T,fn>::value>::type* = 0) noexcept
180+ : type(Type::Function), f(val) {}
181+
182+ template <typename T, typename = typename std::enable_if<!std::is_same<any,T>::value &&
183+ !std::is_convertible<T,fn>::value>::type>
184+ any(const T& val, typename std::enable_if<std::is_assignable<std::function<any(const any&)>,T>::value>::type* = 0)
185+ : type(Type::Closure), l(make_managed<_closure<T>>(val)) {}
186+
187+ template <typename T>
188+ any(const T& val, typename std::enable_if<std::is_convertible<T,eff_fn>::value>::type* = 0) noexcept
189+ : type(Type::EffFunction), e(val) {}
190+
191+ template <typename T,
192+ typename = typename std::enable_if<!std::is_same<any,T>::value &&
193+ !std::is_convertible<T,eff_fn>::value>::type>
194+ any(const T& val, typename std::enable_if<std::is_assignable<std::function<any()>,T>::value>::type* = 0)
195+ : type(Type::EffClosure), k(make_managed<_eff_closure<T>>(val)) {}
196+
197+ template <typename T>
198+ any(const T& val, typename std::enable_if<std::is_convertible<T,thunk>::value>::type* = 0) noexcept
199+ : type(Type::Thunk), t(val) {}
200+
201+ template <typename T,
202+ typename = typename std::enable_if<std::is_class<typename std::remove_pointer<T>::type>::value>::type>
203+ any(const T& val, typename std::enable_if<IS_POINTER_TYPE(T)::value>::type* = 0) noexcept
204+ : type(Type::Pointer), p(val) {}
205+
206+ template <typename T>
207+ any(T&& val, typename std::enable_if<std::is_assignable<managed<void>,T>::value>::type* = 0) noexcept
208+ : type(Type::Pointer), p(std::move(val)) {}
209+
210+ // Explicit void* to raw pointer value
211+ template <typename T>
212+ any(const T& val, typename std::enable_if<std::is_same<T,void*>::value>::type* = 0) noexcept
213+ : type(Type::RawPointer), u(val) {}
214+
215+ any(std::nullptr_t) noexcept : type(Type::Pointer), p(nullptr) {}
216+
217+
218+#if !defined(USE_GC)
219+ private:
220+ template <typename T,
221+ typename U,
222+ typename = typename std::enable_if<!std::is_reference<T>::value>::type>
223+ static constexpr auto move_if_rvalue(U&& u) noexcept -> U&& {
224+ return static_cast<U&&>(u);
225+ }
226+
227+ template <typename T,
228+ typename U,
229+ typename = typename std::enable_if<std::is_reference<T>::value>::type>
230+ static constexpr auto move_if_rvalue(U& u) noexcept -> U& {
231+ return static_cast<U&>(u);
232+ }
233+
234+ template <typename T>
235+ auto assign(T&& other) const noexcept -> void {
236+ switch (other.type) {
237+ case Type::Thunk: t = other.t; break;
238+ case Type::Integer: i = other.i; break;
239+ case Type::Double: d = other.d; break;
240+ case Type::Character: c = other.c; break;
241+ case Type::Boolean: b = other.b; break;
242+ case Type::StringLiteral: r = other.r; break;
243+ case Type::Function: f = other.f; break;
244+ case Type::EffFunction: e = other.e; break;
245+ case Type::RawPointer: u = other.u; break;
246+
247+ case Type::String: new (&s) managed<std::string>(move_if_rvalue<T>(other.s)); break;
248+ case Type::Map: new (&m) managed<map>(move_if_rvalue<T>(other.m)); break;
249+ case Type::Data: new (&v) managed<data>(move_if_rvalue<T>(other.v)); break;
250+ case Type::Array: new (&a) managed<array>(move_if_rvalue<T>(other.a)); break;
251+ case Type::Closure: new (&l) managed<closure>(move_if_rvalue<T>(other.l)); break;
252+ case Type::EffClosure: new (&k) managed<eff_closure>(move_if_rvalue<T>(other.k)); break;
253+ case Type::Pointer: new (&p) managed<void>(move_if_rvalue<T>(other.p)); break;
254+
255+ default: assert(false && "Bad 'any' type"); break;
256+ }
257+ }
258+
259+ auto destruct() -> void {
260+ switch (type) {
261+ case Type::String: s.~managed<std::string>(); break;
262+ case Type::Map: m.~managed<map>(); break;
263+ case Type::Data: v.~managed<data>(); break;
264+ case Type::Array: a.~managed<array>(); break;
265+ case Type::Closure: l.~managed<closure>(); break;
266+ case Type::EffClosure: k.~managed<eff_closure>(); break;
267+ case Type::Pointer: p.~managed<void>(); break;
268+
269+ default: break;
270+ }
271+ }
272+
273+ public:
274+ any(const any& other) noexcept : type(other.type) {
275+ assign(other);
276+ }
277+
278+ any(any&& other) noexcept : type(other.type) {
279+ assign(std::move(other));
280+ }
281+
282+ auto operator=(const any& rhs) noexcept -> any& {
283+ destruct();
284+ type = rhs.type;
285+ assign(rhs);
286+ return *this;
287+ }
288+
289+ auto operator=(any&& rhs) noexcept -> any& {
290+ destruct();
291+ type = rhs.type;
292+ assign(std::move(rhs));
293+ return *this;
294+ }
295+
296+ ~any() {
297+ destruct();
298+ }
299+#endif // !defined(USE_GC)
300+
301+ public:
302+ any() = delete;
303+
304+ auto operator()(const any&) const -> any;
305+ auto operator()(const as_thunk) const -> const any&;
306+ auto operator()() const -> any;
307+
308+ operator integer() const;
309+ operator double() const;
310+ operator bool() const;
311+ operator char() const;
312+ operator cstring() const;
313+ operator const map&() const;
314+ operator const data&() const;
315+ operator const array&() const;
316+
317+ auto operator[](const char[]) const -> const any&;
318+ auto operator[](const size_t) const -> const any&;
319+ auto operator[](const any&) const -> const any&;
320+
321+ auto contains(const char[]) const -> bool;
322+
323+ auto extractPointer() const -> void*;
324+
325+ auto rawPointer() const -> void* {
326+ const any& variant = unthunkVariant(*this);
327+ assert(type == Type::RawPointer);
328+ return variant.u;
329+ }
330+
331+ static auto unthunkVariant(const any&) -> const any&;
332+
333+ #define DEFINE_OPERATOR(op, ty, rty) \
334+ inline friend auto operator op (const any& lhs, ty rhs) -> rty { \
335+ return (ty)lhs op rhs; \
336+ } \
337+ inline friend auto operator op (ty lhs, const any& rhs) -> rty { \
338+ return lhs op (ty)rhs; \
339+ } \
340+
341+ #define DEFINE_INT_OPERATOR(op, rty) \
342+ inline friend auto operator op (const any& lhs, int rhs) -> rty { \
343+ return (integer)lhs op (integer)rhs; \
344+ } \
345+ inline friend auto operator op (int lhs, const any& rhs) -> rty { \
346+ return (integer)lhs op (integer)rhs; \
347+ }
348+
349+ #define DECLARE_COMPARISON_OPERATOR(op) \
350+ friend auto operator op (const any&, const any&) -> bool; \
351+ DEFINE_OPERATOR(op, integer, bool) \
352+ DEFINE_OPERATOR(op, double, bool) \
353+ DEFINE_OPERATOR(op, char, bool) \
354+ DEFINE_INT_OPERATOR(op, bool) \
355+ friend auto operator op (const any&, const char * const) -> bool; \
356+ friend auto operator op (const char * const, const any&) -> bool;
357+
358+ DECLARE_COMPARISON_OPERATOR(==)
359+ DECLARE_COMPARISON_OPERATOR(!=)
360+ DECLARE_COMPARISON_OPERATOR(<)
361+ DECLARE_COMPARISON_OPERATOR(<=)
362+ DECLARE_COMPARISON_OPERATOR(>)
363+ DECLARE_COMPARISON_OPERATOR(>=)
364+
365+ friend auto operator+(const any&, const any&) -> any;
366+
367+ DEFINE_OPERATOR(+, integer, integer)
368+ DEFINE_OPERATOR(+, double, double)
369+ DEFINE_OPERATOR(+, char, char)
370+ DEFINE_INT_OPERATOR(+, integer)
371+ friend auto operator+(const any& lhs, const char * const rhs) -> std::string;
372+ friend auto operator+(const char * const lhs, const any& rhs) -> std::string;
373+
374+ friend auto operator-(const any&, const any&) -> any;
375+
376+ DEFINE_OPERATOR(-, integer, integer)
377+ DEFINE_OPERATOR(-, double, double)
378+ DEFINE_OPERATOR(-, char, char)
379+ DEFINE_INT_OPERATOR(-, integer)
380+
381+ friend auto operator*(const any&, const any&) -> any;
382+
383+ DEFINE_OPERATOR(*, integer, integer)
384+ DEFINE_OPERATOR(*, double, double)
385+ DEFINE_OPERATOR(*, char, char)
386+ DEFINE_INT_OPERATOR(*, integer)
387+
388+ friend auto operator/(const any&, const any&) -> any;
389+
390+ DEFINE_OPERATOR(/, integer, integer)
391+ DEFINE_OPERATOR(/, double, double)
392+ DEFINE_OPERATOR(/, char, char)
393+ DEFINE_INT_OPERATOR(/, integer)
394+
395+ friend auto operator%(const any&, const any&) -> any;
396+
397+ DEFINE_OPERATOR(%, integer, integer)
398+ DEFINE_OPERATOR(%, char, char)
399+ DEFINE_INT_OPERATOR(%, integer)
400+
401+ friend auto operator-(const any&) -> any; // unary negate
402+};
403+
404+template <typename T>
405+inline auto cast(const any& a) ->
406+ typename std::enable_if<std::is_arithmetic<T>::value ||
407+ std::is_same<T,cstring>::value, T>::type {
408+ return a;
409+}
410+
411+template <typename T>
412+inline auto cast(const any& a) ->
413+ typename std::enable_if<std::is_same<T, any::map>::value ||
414+ std::is_same<T, any::data>::value ||
415+ std::is_same<T, any::array>::value, const T&>::type {
416+ return a;
417+}
418+
419+template <typename T, typename = typename std::enable_if<std::is_class<T>::value>::type>
420+inline auto cast(const any& a) ->
421+ typename std::enable_if<!std::is_same<T, any::map>::value &&
422+ !std::is_same<T, any::data>::value &&
423+ !std::is_same<T, any::array>::value, T&>::type {
424+ return *static_cast<T*>(a.extractPointer());
425+}
426+
427+template <typename T>
428+inline auto cast(const any& a) ->
429+ typename std::enable_if<std::is_same<void*, T>::value, T>::type {
430+ return a.rawPointer();
431+}
432+
433+} // namespace PureScript
434+
435+#undef WITH_ALLOCATOR
436+#undef IS_POINTER_TYPE
437+#undef DEFINE_OPERATOR
438+#undef DEFINE_INT_OPERATOR
439+#undef DECLARE_COMPARISON_OPERATOR
440+
441+#endif // PureScript_HH
pcc/include/purescript_memory.hhnew file+59
@@ -0,0 +1,59 @@
1+///////////////////////////////////////////////////////////////////////////////
2+//
3+// Module : purescript_memory.hh
4+// Copyright : (c) Andy Arvanitis 2016
5+// License : MIT
6+//
7+// Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>
8+// Stability : experimental
9+// Portability :
10+//
11+// Includes and macros for garbage collection options
12+//
13+///////////////////////////////////////////////////////////////////////////////
14+//
15+#ifndef PureScript_MEMORY_HH
16+#define PureScript_MEMORY_HH
17+
18+#if defined(USE_GC)
19+ #define GC_THREADS
20+ #include <gc/gc_cpp.h>
21+ #include <gc/gc_allocator.h>
22+ #define WITH_ALLOCATOR(T) , traceable_allocator<T>
23+ #define MANAGED_TYPE(T) T*
24+ #define MAKE_MANAGED(T) new (GC) T
25+ #define MAKE_MANAGED_FINALIZED(T) new (GC, [](void* p, void*){ static_cast<T*>(p)->~T(); }) T
26+ #define IS_POINTER_TYPE(T) std::is_pointer<T>
27+ #define POINTER_FROM_MEMBER(P) P
28+ #define INITIALIZE_GC(_) GC_INIT()
29+#else
30+ #include <memory>
31+ #define WITH_ALLOCATOR(_)
32+ #define MANAGED_TYPE(T) std::shared_ptr<T>
33+ #define MAKE_MANAGED(T) std::make_shared<T>
34+ #define MAKE_MANAGED_FINALIZED(T) MAKE_MANAGED(T)
35+ #define IS_POINTER_TYPE(T) std::is_assignable<managed<void>,T>
36+ #define POINTER_FROM_MEMBER(P) P.get()
37+ #define INITIALIZE_GC(_)
38+#endif
39+
40+namespace PureScript {
41+ template <typename T>
42+ using managed = MANAGED_TYPE(T);
43+
44+ template <typename T, typename... Args>
45+ inline static auto make_managed(Args&&... args) -> MANAGED_TYPE(T) {
46+ return MAKE_MANAGED(T)(std::forward<Args>(args)...);
47+ }
48+
49+ template <typename T, typename... Args>
50+ inline static auto make_managed_and_finalized(Args&&... args) -> MANAGED_TYPE(T) {
51+ return MAKE_MANAGED_FINALIZED(T)(std::forward<Args>(args)...);
52+ }
53+}
54+
55+#undef MANAGED_TYPE
56+#undef MAKE_MANAGED
57+#undef MAKE_MANAGED_FINALIZED
58+
59+#endif // PureScript_MEMORY_HH
purescript.cabal+35
@@ -81,6 +81,7 @@ extra-source-files: examples/passing/*.purs
81 , INSTALL.md
81 , INSTALL.md
82 , CONTRIBUTORS.md
82 , CONTRIBUTORS.md
83 , CONTRIBUTING.md
83 , CONTRIBUTING.md
84+ , pcc/include/*.hh
84
85
85source-repository head
86source-repository head
86 type: git
87 type: git
@@ -153,6 +154,21 @@ library
153 Language.PureScript.CodeGen.JS.Optimizer.MagicDo
154 Language.PureScript.CodeGen.JS.Optimizer.MagicDo
154 Language.PureScript.CodeGen.JS.Optimizer.TCO
155 Language.PureScript.CodeGen.JS.Optimizer.TCO
155 Language.PureScript.CodeGen.JS.Optimizer.Unused
156 Language.PureScript.CodeGen.JS.Optimizer.Unused
157+
158+ Language.PureScript.CodeGen.Cpp
159+ Language.PureScript.CodeGen.Cpp.AST
160+ Language.PureScript.CodeGen.Cpp.Common
161+ Language.PureScript.CodeGen.Cpp.File
162+ Language.PureScript.CodeGen.Cpp.Optimizer
163+ Language.PureScript.CodeGen.Cpp.Optimizer.Blocks
164+ Language.PureScript.CodeGen.Cpp.Optimizer.Common
165+ Language.PureScript.CodeGen.Cpp.Optimizer.Inliner
166+ Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo
167+ Language.PureScript.CodeGen.Cpp.Optimizer.TCO
168+ Language.PureScript.CodeGen.Cpp.Optimizer.Unused
169+ Language.PureScript.CodeGen.Cpp.Types
170+ Language.PureScript.Pretty.Cpp
171+
156 Language.PureScript.Constants
172 Language.PureScript.Constants
157 Language.PureScript.CoreFn
173 Language.PureScript.CoreFn
158 Language.PureScript.CoreFn.Ann
174 Language.PureScript.CoreFn.Ann
@@ -402,6 +418,18 @@ executable psc-ide-client
402 ghc-options: -Wall -O2
418 ghc-options: -Wall -O2
403 hs-source-dirs: psc-ide-client
419 hs-source-dirs: psc-ide-client
404
420
421+executable pcc
422+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
423+ file-embed -any,
424+ bytestring -any,
425+ mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
426+ time -any, transformers -any, transformers-compat -any
427+ main-is: Main.hs
428+ buildable: True
429+ hs-source-dirs: pcc
430+ other-modules:
431+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind
432+
405test-suite tests
433test-suite tests
406 build-depends: base >=4 && <5, containers -any, directory -any,
434 build-depends: base >=4 && <5, containers -any, directory -any,
407 filepath -any, mtl -any, parsec -any, purescript -any,
435 filepath -any, mtl -any, parsec -any, purescript -any,
@@ -434,3 +462,10 @@ test-suite tests
434 PSCi.Types
462 PSCi.Types
435 buildable: True
463 buildable: True
436 hs-source-dirs: tests psci
464 hs-source-dirs: tests psci
465+
466+test-suite pcc-tests
467+ build-depends: base >=4 && <5, directory -any, filepath -any, process -any
468+ type: exitcode-stdio-1.0
469+ main-is: TestMain.hs
470+ buildable: True
471+ hs-source-dirs: pcc
src/Language/PureScript/CodeGen/Cpp.hsnew file+892
@@ -0,0 +1,892 @@
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
13+-- Purescript code.
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.Char (isLetter)
30+import Data.List
31+import Data.Function (on)
32+import Data.Maybe (catMaybes, fromJust)
33+import qualified Data.Map as M
34+
35+import Control.Monad (forM, replicateM)
36+import Control.Monad.Reader (MonadReader, ask)
37+import Control.Monad.Supply.Class
38+import Language.PureScript.AST.SourcePos
39+import Language.PureScript.CodeGen.Cpp.AST as AST
40+import Language.PureScript.CodeGen.Cpp.Common as Common
41+import Language.PureScript.CodeGen.Cpp.File
42+import Language.PureScript.CodeGen.Cpp.Optimizer
43+import Language.PureScript.CodeGen.Cpp.Optimizer.TCO
44+import Language.PureScript.CodeGen.Cpp.Types
45+import Language.PureScript.Comments
46+import Language.PureScript.CoreFn
47+import Language.PureScript.Names
48+import Language.PureScript.Options
49+import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames)
50+import Language.PureScript.Traversals (sndM)
51+
52+import qualified Language.PureScript.Constants as C
53+import qualified Language.PureScript.Environment as E
54+import qualified Language.PureScript.Pretty.Cpp as P
55+import qualified Language.PureScript.Types as T
56+
57+-- |
58+-- Generate code in the simplified C++1x intermediate representation for all declarations in a
59+-- module.
60+--
61+---------------------------------------------------------------------------------------------------
62+moduleToCpp :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m)
63+ => E.Environment -> Module Ann -> m [Cpp]
64+---------------------------------------------------------------------------------------------------
65+moduleToCpp env (Module _ mn imps _ foreigns decls) = do
66+ cppImports <-
67+ traverse (pure . runModuleName) .
68+ delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $
69+ (snd <$> imps)
70+ let cppImports' = "PureScript" : cppImports
71+ cppDecls <- concat <$> mapM (bindToCpp [CppTopLevel]) decls
72+ cppDecls' <- traverse optimize cppDecls
73+ foreignWrappers <- curriedForeigns
74+ let optimized = cppDecls' ++ foreignWrappers
75+ let moduleHeader =
76+ fileBegin mn "HH" ++
77+ P.linebreak ++
78+ ((\i -> CppInclude i i) <$> cppImports') ++
79+ (if not (null foreigns)
80+ then [CppInclude [] (runModuleName mn ++ "_ffi")]
81+ else []) ++
82+ P.linebreak ++
83+ [ CppNamespace (runModuleName mn) $
84+ (CppUseNamespace <$> cppImports') ++
85+ P.linebreak ++
86+ dataCtors ++
87+ toHeader optimized ++
88+ toHeaderFns optimized
89+ ] ++
90+ P.linebreak ++
91+ fileEnd mn "HH"
92+ let bodyCpps = toBodyDecl optimized ++ toBody optimized
93+ moduleBody =
94+ CppInclude (runModuleName mn) (runModuleName mn) :
95+ P.linebreak ++
96+ (if null bodyCpps
97+ then []
98+ else [ CppNamespace (runModuleName mn) $
99+ (CppUseNamespace <$> cppImports') ++
100+ P.linebreak ++ bodyCpps ]) ++
101+ P.linebreak ++
102+ (if isMain mn
103+ then [nativeMain] ++ P.linebreak
104+ else [])
105+ return $ moduleHeader ++ CppEndOfHeader : moduleBody
106+ where
107+ -- |
108+ -- Generate code in the simplified C++1x intermediate representation for a declaration
109+ --
110+ -------------------------------------------------------------------------------------------------
111+ bindToCpp :: [CppValueQual] -> Bind Ann -> m [Cpp]
112+ -------------------------------------------------------------------------------------------------
113+ bindToCpp qs (NonRec ann ident val) = return <$> declToCpp qs (ann, ident) val
114+ bindToCpp qs (Rec vals) = forM vals (uncurry $ declToCpp (CppRecursive:qs))
115+
116+ -- |
117+ -- Desugar a declaration into a variable introduction or named function
118+ -- declaration.
119+ -------------------------------------------------------------------------------------------------
120+ declToCpp :: [CppValueQual] -> (Ann, Ident) -> Expr Ann -> m Cpp
121+ -------------------------------------------------------------------------------------------------
122+ declToCpp _ (_, ident) e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
123+ let className = identToCpp ident
124+ (supers, members) = span (C.__superclass_ `isPrefixOf`) (identToCpp <$> (fst $ unAbs e []))
125+ in return $ CppStruct className [CppEnum Nothing Nothing (sort supers ++ members)]
126+
127+ declToCpp _ (_, Op _) (Var (_, _, Nothing, _) _) =
128+ return CppNoOp -- skip operator aliases
129+
130+ declToCpp vqs (_, ident) (Abs (_, com, ty, _) arg body) = do
131+ fn <- if argcnt > 1 && CppTopLevel `elem` vqs
132+ then do
133+ argNames <- replicateM (argcnt - length args' - 1) freshName
134+ let args'' = zip argNames (repeat aty)
135+ block <- asReturnBlock <$> valueToCpp
136+ (if null argNames
137+ then snd abs'
138+ else curriedApp
139+ (tail argNames)
140+ (App
141+ nullAnn
142+ (snd abs')
143+ (Var nullAnn . Qualified Nothing . Ident $ head argNames)))
144+ return $ CppNamespace ""
145+ [ CppFunction
146+ name
147+ (arg' : args' ++ args'')
148+ rty
149+ (vqs ++ if isAccessor (snd abs') then [CppInline] else [])
150+ (convertNestedLambdas $ convertDictIndexers block)
151+ , CppFunction
152+ (curriedName name)
153+ [arg']
154+ rty
155+ []
156+ (asReturnBlock $
157+ curriedLambda
158+ (fst <$> args' ++ args'')
159+ (CppApp (CppVar name)
160+ (CppVar . fst <$> (arg' : args' ++ args''))))
161+ ]
162+ else do
163+ block <- valueToCpp body
164+ return $ CppFunction
165+ name
166+ [arg']
167+ rty
168+ (vqs ++ if isIndexer block then [CppInline] else [])
169+ (convertNestedLambdas . asReturnBlock $ convertDictIndexers block)
170+ return (CppComment com fn)
171+ where
172+ ty' | Just t <- ty = Just t
173+ | Just (t, _, _) <- M.lookup (mn, ident) (E.names env) = Just t
174+ | otherwise = Nothing
175+ argcnt = maybe 0 countArgs ty'
176+ name = identToCpp ident
177+ aty = Just $ CppAny [CppConst, CppRef]
178+ rty = Just $ CppAny []
179+ arg' = (identToCpp arg, aty)
180+ args' = (\i -> (identToCpp i, aty)) <$> fst abs'
181+ abs' = unAbs body []
182+ isAccessor :: Expr Ann -> Bool
183+ isAccessor Accessor{} = True
184+ isAccessor _ = False
185+ isIndexer :: Cpp -> Bool
186+ isIndexer (CppIndexer (CppStringLiteral _) (CppVar _)) = True
187+ isIndexer _ = False
188+ classes = qualifiedToCpp (Ident . runProperName) . fst <$>
189+ maybe [] extractConstraints ty'
190+ dictClasses = zip (CppVar . fst <$> arg' : args') classes
191+ convertDictIndexers = everywhereOnCpp (dictIndexerToEnum dictClasses)
192+
193+ declToCpp _ (_, ident) (Constructor _ _ (ProperName _) []) =
194+ return $
195+ CppFunction
196+ (identToCpp ident)
197+ []
198+ (Just $ CppAny [])
199+ [CppInline]
200+ (asReturnBlock $
201+ CppDataLiteral [CppAccessor (CppVar $ identToCpp ident) (CppVar "data")])
202+
203+ declToCpp _ (_, ident) (Constructor _ _ (ProperName _) fields) =
204+ return . CppNamespace "" $
205+ [ CppFunction
206+ name
207+ (farg <$> fields')
208+ (Just $ CppAny [])
209+ [CppInline]
210+ (asReturnBlock $
211+ CppDataLiteral $
212+ CppAccessor (CppVar name) (CppVar "data") : (CppVar <$> fields'))
213+ ] ++
214+ if length fields > 1
215+ then
216+ [ CppFunction
217+ (curriedName name)
218+ (farg <$> f)
219+ (Just $ CppAny [])
220+ []
221+ (CppBlock (fieldLambdas fs))
222+ ]
223+ else
224+ []
225+ where
226+ name = identToCpp ident
227+ fields' = identToCpp <$> fields
228+ (f, fs) | (f' : fs') <- fields' = ([f'], fs')
229+ | otherwise = ([], [])
230+ farg = \x -> (x, Just $ CppAny [CppConst, CppRef])
231+ fieldLambdas flds
232+ | (f' : fs') <- flds = [ CppReturn . maybeRemCaps $
233+ CppLambda
234+ [CppCaptureAll]
235+ (farg <$> [f'])
236+ (Just $ CppAny [])
237+ (CppBlock $ fieldLambdas fs') ]
238+ | otherwise = [CppReturn $ CppApp (CppVar name) (CppVar <$> fields')]
239+
240+ declToCpp qs (_, ident) e
241+ | Just ty <- exprType e,
242+ CppTopLevel `elem` qs,
243+ argcnt <- countArgs ty,
244+ argcnt > 0 = do
245+ argNames <- replicateM argcnt freshName
246+ block <- valueToCpp $
247+ curriedApp
248+ (tail argNames)
249+ (App nullAnn e (Var nullAnn . Qualified Nothing . Ident $ head argNames))
250+ let fn' = CppFunction
251+ (curriedName name)
252+ [(head argNames, Just $ CppAny [CppConst, CppRef])]
253+ rty
254+ []
255+ (asReturnBlock $
256+ curriedLambda
257+ (tail argNames)
258+ (CppApp (CppVar name)
259+ (CppVar <$> argNames)))
260+ return $ CppNamespace "" $
261+ [ CppFunction
262+ name
263+ (zip argNames $ repeat aty)
264+ rty
265+ []
266+ (asReturnBlock block)
267+ ] ++ if argcnt > 1
268+ then [fn']
269+ else []
270+ where
271+ name = identToCpp ident
272+ aty = Just $ CppAny [CppConst, CppRef]
273+ rty = Just $ CppAny []
274+
275+ declToCpp _ (_, ident) val = do
276+ val' <- valueToCpp val
277+ return $
278+ CppVariableIntroduction
279+ (identToCpp ident, Just $ CppAny [CppConst])
280+ []
281+ (Just val')
282+
283+ -------------------------------------------------------------------------------------------------
284+ exprType :: Expr Ann -> Maybe T.Type
285+ -------------------------------------------------------------------------------------------------
286+ exprType (Var (_, _, Just ty, _) _) = Just ty
287+ exprType (App (_, _, Just ty, _) _ _) = Just ty
288+ exprType (Case (_, _, Just ty, _) _ _) = Just ty
289+ exprType (Let (_, _, Just ty, _) _ _) = Just ty
290+ exprType _ = Nothing
291+
292+ -------------------------------------------------------------------------------------------------
293+ fnToLambda :: Cpp -> Cpp
294+ -------------------------------------------------------------------------------------------------
295+ fnToLambda (CppFunction name args _ qs body) =
296+ CppVariableIntroduction
297+ (name, Just $ CppAny [CppConst])
298+ (filter (==CppStatic) qs)
299+ (Just $ CppLambda cs args (Just $ CppAny []) body)
300+ where
301+ cs | (not . null) (qs `intersect` [CppInline, CppStatic]) = []
302+ | otherwise = [CppCaptureAll]
303+ fnToLambda (CppComment com cpp) = CppComment com (fnToLambda cpp)
304+ fnToLambda _ = error "Not a function!"
305+
306+ -------------------------------------------------------------------------------------------------
307+ convertNestedLambdas :: Cpp -> Cpp
308+ -------------------------------------------------------------------------------------------------
309+ convertNestedLambdas = everywhereOnCpp go
310+ where
311+ go :: Cpp -> Cpp
312+ go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f
313+ go (CppLambda _ args rtyp body) = maybeRemCaps $ CppLambda [CppCaptureAll] args rtyp body
314+ go cpp = cpp
315+
316+ -------------------------------------------------------------------------------------------------
317+ convertRecursiveFns :: [Cpp] -> Cpp -> [Cpp]
318+ -------------------------------------------------------------------------------------------------
319+ convertRecursiveFns cpps otherCpp
320+ | not $ null fns = dict : (accessor topdict <$> filteredFns allCpps) ++ cpps'
321+ where
322+ cpps' = everywhereOnCpp removeRec <$> cpps
323+ allCpps = CppBlock $ otherCpp : cpps'
324+
325+ fns :: [(String, Cpp)]
326+ fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps
327+
328+ filteredFns :: Cpp -> [(String, Cpp)]
329+ filteredFns cpp = filter (\(f,_) -> everythingOnCpp (||) (== CppVar f) cpp) fns
330+
331+ recursive :: Cpp -> [Cpp]
332+ recursive cpp'@(CppFunction _ _ _ qs _) | CppRecursive `elem` qs = [cpp']
333+ recursive _ = []
334+
335+ removeRec :: Cpp -> Cpp
336+ removeRec(CppFunction _ _ _ qs _) | CppRecursive `elem` qs = CppNoOp
337+ removeRec cpp' = cpp'
338+
339+ dict :: Cpp
340+ dict = CppVariableIntroduction
341+ (topdict, Just $ CppAny [CppConst])
342+ []
343+ (Just $ CppDataLiteral ((\(f,cpp) -> CppComment [LineComment f] cpp) <$> fns))
344+
345+ accessor :: String -> (String, Cpp) -> Cpp
346+ accessor dictname (name, _) =
347+ CppVariableIntroduction
348+ (name, Just $ CppAny [CppConst])
349+ []
350+ (Just accessed)
351+ where
352+ dict' = CppVar dictname
353+ dict'' = CppCast dataType dict'
354+ accessed = CppApp
355+ (CppIndexer
356+ (CppNumericLiteral .
357+ Left .
358+ fromIntegral .
359+ fromJust $ findIndex ((== name) . fst) fns)
360+ dict'')
361+ [dict']
362+
363+ toelem :: Cpp -> (String, Cpp)
364+ toelem (CppFunction name args rtyp _ body'@(CppBlock body)) =
365+ (name, withdict . maybeRemCaps $ CppLambda
366+ [CppCaptureAll]
367+ args
368+ rtyp
369+ (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))
370+ toelem _ = error "not a function"
371+
372+ withdict :: Cpp -> Cpp
373+ withdict cpp' = maybeRemCaps $ CppLambda
374+ [CppCaptureAll]
375+ [(localdict, Just $ CppAny [CppConst, CppRef])]
376+ (Just $ CppAny [])
377+ (asReturnBlock cpp')
378+ topdict :: String
379+ topdict = "_$dict$_"
380+ localdict :: String
381+ localdict = "$dict$"
382+
383+ convertRecursiveFns cpps _ = cpps
384+
385+ -- |
386+ -- Generate code in the simplified C++1x intermediate representation for a value or expression.
387+ --
388+ -------------------------------------------------------------------------------------------------
389+ valueToCpp :: Expr Ann -> m Cpp
390+ -------------------------------------------------------------------------------------------------
391+ valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) =
392+ return $ CppApp (varToCpp ident) []
393+
394+ valueToCpp (Var (_, _, _, Just (IsConstructor _ [_])) ident) =
395+ return $ varToCpp ident
396+
397+ valueToCpp (Var (_, _, _, Just (IsConstructor _ _)) ident) =
398+ return . curriedName' $ varToCpp ident
399+
400+ valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))
401+ | countArgs ty > 1 =
402+ return . curriedName' $ varToCpp ident
403+
404+ valueToCpp (Var _ ident) =
405+ return $ varToCpp ident
406+
407+ valueToCpp (Literal _ (NumericLiteral n)) =
408+ return (CppNumericLiteral n)
409+
410+ valueToCpp (Literal _ (StringLiteral s)) =
411+ return (CppStringLiteral s)
412+
413+ valueToCpp (Literal _ (CharLiteral c)) =
414+ return (CppCharLiteral c)
415+
416+ valueToCpp (Literal _ (BooleanLiteral b)) =
417+ return (CppBooleanLiteral b)
418+
419+ valueToCpp (Literal _ (ArrayLiteral xs)) =
420+ CppArrayLiteral <$> mapM valueToCpp xs
421+
422+ valueToCpp (Literal _ (ObjectLiteral ps)) =
423+ CppObjectLiteral <$> sortBy (compare `on` fst) <$> mapM (sndM valueToCpp) ps
424+
425+ valueToCpp (Accessor _ prop val) =
426+ CppIndexer <$> pure (CppStringLiteral prop) <*> valueToCpp val
427+
428+ -- TODO: use a more efficient way of copying/updating the map?
429+ valueToCpp (ObjectUpdate (_, _, Just ty, _) obj ps) = do
430+ obj' <- valueToCpp obj
431+ updatedFields <- mapM (sndM valueToCpp) ps
432+ let origKeys = (allKeys ty) \\ (fst <$> updatedFields)
433+ origFields = (\key -> (key, CppIndexer (CppStringLiteral key) obj')) <$> origKeys
434+ return $ CppObjectLiteral . sortBy (compare `on` fst) $ origFields ++ updatedFields
435+ where
436+ allKeys :: T.Type -> [String]
437+ allKeys (T.TypeApp (T.TypeConstructor _) r@(T.RCons {})) = fst <$> (fst $ T.rowToList r)
438+ allKeys (T.ForAll _ t _) = allKeys t
439+ allKeys _ = error $ show "Not a recognized row type"
440+
441+ valueToCpp (ObjectUpdate _ _ _) = error $ "Bad Type in object update!"
442+
443+ valueToCpp (Abs (_, _, ty, _) arg body) = do
444+ cpp <- valueToCpp body
445+ let cpp' = convertNestedLambdas cpp
446+ return $
447+ CppLambda
448+ []
449+ [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]
450+ (Just $ CppAny [])
451+ (asReturnBlock $ convertDictIndexers cpp')
452+ where
453+ arg' = identToCpp arg
454+ args' = identToCpp <$> (fst $ unAbs body [])
455+ classes = qualifiedToCpp (Ident . runProperName) . fst <$>
456+ maybe [] extractConstraints ty
457+ dictClasses = zip (CppVar <$> arg' : args') classes
458+ convertDictIndexers = everywhereOnCpp (dictIndexerToEnum dictClasses)
459+ valueToCpp e@App{} = do
460+ let (f, args) = unApp e []
461+ args' <- mapM valueToCpp args
462+ case f of
463+ Var (_, _, _, Just IsNewtype) _ -> return (head args')
464+ Var (_, _, _, Just (IsConstructor _ fields)) ident
465+ | length args == length fields ->
466+ return $ CppApp (uncurried' $ qualifiedToCpp id ident) args'
467+ Var (_, _, _, Just IsTypeClassConstructor) (Qualified mn' (Ident classname)) ->
468+ let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname)) in
469+ return . CppObjectLiteral $
470+ zip
471+ ((sort $ superClassDictionaryNames constraints) ++ (fst <$> fns))
472+ args'
473+ Var ann (Qualified (Just mn') ident)
474+ | argcnt <- maybe 0 countArgs ty,
475+ argcnt > 1 -> do
476+ f' <- valueToCpp f
477+ let (uncurriedArgs, curriedArgs) =
478+ if length args' >= argcnt
479+ then splitAt argcnt args'
480+ else ([], args')
481+ fn' =
482+ if null uncurriedArgs
483+ then curriedName' f'
484+ else CppApp (uncurried' f') uncurriedArgs
485+ return $ foldl (\fn a -> CppApp fn [a]) fn' curriedArgs
486+ where
487+ ty | (_, _, Just t, _) <- ann = Just t
488+ | Just (t, _, _) <- M.lookup (mn', ident) (E.names env) = Just t
489+ | otherwise = Nothing
490+ _ ->
491+ flip (foldl (\fn a -> CppApp fn [a])) args' <$> valueToCpp f
492+
493+ valueToCpp (Case (maybeSpan, _, ty, _) values binders) = do
494+ vals <- mapM valueToCpp values
495+ bindersToCpp maybeSpan ty binders vals
496+
497+ valueToCpp (Let _ ds val) = do
498+ ds' <- concat <$> mapM (bindToCpp []) ds
499+ ret <- valueToCpp val
500+ opts <- ask
501+ let ds'' = tco opts <$> ds'
502+ let rs = if hasRecursion ds''
503+ then convertRecursiveFns ds'' ret
504+ else ds''
505+ let cpps = convertNestedLambdas <$> rs
506+ return $ CppApp
507+ (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret])))
508+ []
509+ where
510+ hasRecursion :: [Cpp] -> Bool
511+ hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'
512+ where
513+ fnames :: [String]
514+ fnames = concatMap (everythingOnCpp (++) fname) cpps'
515+
516+ fname :: Cpp -> [String]
517+ fname (CppFunction name _ _ _ _) = [name]
518+ fname _ = []
519+
520+ hasRecursiveRef :: Cpp -> Bool
521+ hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body
522+ hasRecursiveRef _ = False
523+
524+ ref :: Cpp -> Bool
525+ ref (CppVar name) | name `elem` fnames = True
526+ ref _ = False
527+
528+ valueToCpp Constructor{} = return CppNoOp
529+
530+ -- |
531+ -- Generate code in the simplified C++1x intermediate representation for a reference to a
532+ -- variable.
533+ --
534+ -------------------------------------------------------------------------------------------------
535+ varToCpp :: Qualified Ident -> Cpp
536+ -------------------------------------------------------------------------------------------------
537+ varToCpp (Qualified Nothing ident) = CppVar (identToCpp ident)
538+ varToCpp qual = qualifiedToCpp id qual
539+
540+ -- |
541+ -- Generate code in the simplified C++1x intermediate representation for pattern match binders
542+ -- and guards.
543+ --
544+ -------------------------------------------------------------------------------------------------
545+ bindersToCpp :: Maybe SourceSpan -> Maybe T.Type -> [CaseAlternative Ann] -> [Cpp] -> m Cpp
546+ -------------------------------------------------------------------------------------------------
547+ bindersToCpp maybeSpan _ binders vals = do
548+ valNames <- replicateM (length vals) freshName
549+ let assignments = zipWith mkVarDecl valNames (map Just vals)
550+ cpps <- forM binders $ \(CaseAlternative bs result) -> do
551+ ret <- guardsToCpp result
552+ go valNames ret bs
553+ return $
554+ CppApp
555+ (CppLambda
556+ []
557+ []
558+ (Just $ CppAny [])
559+ (CppBlock (assignments ++ concat cpps ++ [failedPatternError valNames])))
560+ []
561+ where
562+ mkVarDecl :: String -> Maybe Cpp -> Cpp
563+ mkVarDecl name = CppVariableIntroduction (name, Nothing) []
564+ go :: [String] -> [Cpp] -> [Binder Ann] -> m [Cpp]
565+ go _ done [] = return done
566+ go (v:vs) done' (b:bs) = do
567+ done'' <- go vs done' bs
568+ binderToCpp v done'' b
569+ go _ _ _ = error "Invalid arguments to bindersToCpp"
570+
571+ failedPatternError :: [String] -> Cpp
572+ failedPatternError _ =
573+ CppThrow $ CppApp (CppVar "runtime_error") [CppStringLiteral errorMessage]
574+
575+ errorMessage :: String
576+ errorMessage = "Failed pattern match" ++
577+ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++
578+ ": "
579+
580+ guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [Cpp]
581+ guardsToCpp (Left gs) = forM gs $ \(cond, val) -> do
582+ cond' <- valueToCpp cond
583+ done <- valueToCpp val
584+ return $ CppIfElse cond' (asReturnBlock done) Nothing
585+ guardsToCpp (Right v) = return . CppReturn <$> valueToCpp v
586+
587+ -- |
588+ -- Generate code in the simplified C++1x intermediate representation for a pattern match
589+ -- binder.
590+ --
591+ -------------------------------------------------------------------------------------------------
592+ binderToCpp :: String -> [Cpp] -> Binder Ann -> m [Cpp]
593+ -------------------------------------------------------------------------------------------------
594+ binderToCpp _ done (NullBinder{}) = return done
595+
596+ binderToCpp varName done (LiteralBinder _ l) =
597+ literalToBinderCpp varName done l
598+
599+ binderToCpp varName done (VarBinder _ ident) =
600+ return $
601+ CppVariableIntroduction
602+ (identToCpp ident, Just $ CppAny [CppConst])
603+ []
604+ (Just $ CppVar varName)
605+ : done
606+
607+ binderToCpp varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
608+ binderToCpp varName done b
609+
610+ binderToCpp varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields))
611+ _
612+ (Qualified mn' (ProperName ctor))
613+ bs) = do
614+ cpps <- go (zip fields bs) done
615+ return $
616+ case ctorType of
617+ ProductType -> cpps
618+ SumType ->
619+ [ CppIfElse
620+ (CppBinary
621+ Equal
622+ (CppIndexer
623+ (CppVar ctorKey)
624+ (CppCast dataType $ CppVar varName))
625+ ctorCpp)
626+ (CppBlock cpps)
627+ Nothing]
628+ where
629+ go :: [(Ident, Binder Ann)] -> [Cpp] -> m [Cpp]
630+ go [] done' = return done'
631+ go ((field, binder) : remain) done' = do
632+ argVar <- freshName
633+ done'' <- go remain done'
634+ cpps <- binderToCpp argVar done'' binder
635+ return $
636+ CppVariableIntroduction
637+ (argVar, Nothing)
638+ []
639+ (Just $ CppIndexer
640+ (fieldToIndex field)
641+ (CppCast dataType $ CppVar varName))
642+ : cpps
643+ fieldToIndex :: Ident -> Cpp
644+ fieldToIndex = CppNumericLiteral . Left . (+1) . read . dropWhile isLetter . runIdent
645+ ctor' :: Cpp
646+ ctor' = CppAccessor (CppVar . identToCpp $ Ident ctor) (CppVar "data")
647+ ctorCpp :: Cpp
648+ ctorCpp | Just mn'' <- mn', mn'' /= mn = CppAccessor ctor' (CppVar $ moduleNameToCpp mn'')
649+ | otherwise = ctor'
650+
651+ binderToCpp _ _ b@(ConstructorBinder{}) =
652+ error $ "Invalid ConstructorBinder in binderToCpp: " ++ show b
653+
654+ binderToCpp varName done (NamedBinder _ ident binder) = do
655+ cpp <- binderToCpp varName done binder
656+ return $
657+ CppVariableIntroduction
658+ (identToCpp ident, Just $ CppAny [CppConst])
659+ []
660+ (Just $ CppVar varName)
661+ : cpp
662+
663+ -------------------------------------------------------------------------------------------------
664+ literalToBinderCpp :: String -> [Cpp] -> Literal (Binder Ann) -> m [Cpp]
665+ -------------------------------------------------------------------------------------------------
666+ literalToBinderCpp varName done (NumericLiteral num) =
667+ return [ CppIfElse
668+ (CppBinary Equal (CppVar varName) (CppNumericLiteral num))
669+ (CppBlock done)
670+ Nothing ]
671+
672+ literalToBinderCpp varName done (CharLiteral c) =
673+ return [ CppIfElse
674+ (CppBinary Equal (CppVar varName) (CppCharLiteral c))
675+ (CppBlock done)
676+ Nothing ]
677+
678+ literalToBinderCpp varName done (StringLiteral str) =
679+ return [ CppIfElse
680+ (CppBinary Equal (CppVar varName) (CppStringLiteral str))
681+ (CppBlock done)
682+ Nothing ]
683+
684+ literalToBinderCpp varName done (BooleanLiteral True) =
685+ return [ CppIfElse
686+ (CppVar varName)
687+ (CppBlock done)
688+ Nothing ]
689+
690+ literalToBinderCpp varName done (BooleanLiteral False) =
691+ return [ CppIfElse
692+ (CppUnary
693+ CppNot
694+ (CppVar varName))
695+ (CppBlock done)
696+ Nothing ]
697+
698+ literalToBinderCpp varName done (ObjectLiteral bs) = go done bs
699+ where
700+ go :: [Cpp] -> [(String, Binder Ann)] -> m [Cpp]
701+ go done' [] = return done'
702+ go done' ((prop, binder):bs') = do
703+ propVar <- freshName
704+ done'' <- go done' bs'
705+ cpp <- binderToCpp propVar done'' binder
706+ return $
707+ CppVariableIntroduction
708+ (propVar, Nothing)
709+ []
710+ (Just $ CppIndexer
711+ (CppStringLiteral prop)
712+ (CppVar varName))
713+ : cpp
714+
715+ literalToBinderCpp varName done (ArrayLiteral bs) = do
716+ cpp <- go done 0 bs
717+ let cond =
718+ case length bs of
719+ 0 -> CppBinary
720+ Dot
721+ (CppCast arrayType $ CppVar varName)
722+ (CppApp (CppVar "empty") [])
723+ n -> let var = CppCast arrayType $ CppVar varName
724+ in CppBinary
725+ Equal
726+ (CppBinary Dot var (CppApp (CppVar "size") []))
727+ (CppNumericLiteral (Left (fromIntegral n)))
728+ return [ CppIfElse cond (CppBlock cpp) Nothing ]
729+ where
730+ go :: [Cpp] -> Integer -> [Binder Ann] -> m [Cpp]
731+ go done' _ [] = return done'
732+ go done' index (binder:bs') = do
733+ elVar <- freshName
734+ done'' <- go done' (index + 1) bs'
735+ cpp <- binderToCpp elVar done'' binder
736+ return $
737+ CppVariableIntroduction
738+ (elVar, Nothing)
739+ []
740+ (Just $ CppIndexer
741+ (CppNumericLiteral (Left index))
742+ (CppVar varName))
743+ : cpp
744+
745+ -------------------------------------------------------------------------------------------------
746+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
747+ -------------------------------------------------------------------------------------------------
748+ unApp (App _ val arg) args = unApp val (arg : args)
749+ unApp other args = (other, args)
750+
751+ -------------------------------------------------------------------------------------------------
752+ unAbs :: Expr Ann -> [Ident] -> ([Ident], Expr Ann)
753+ -------------------------------------------------------------------------------------------------
754+ unAbs (Abs _ arg val) args = unAbs val (args ++ [arg])
755+ unAbs other args = (args, other)
756+
757+ -------------------------------------------------------------------------------------------------
758+ qualifiedToCpp :: (a -> Ident) -> Qualified a -> Cpp
759+ -------------------------------------------------------------------------------------------------
760+ qualifiedToCpp f (Qualified (Just (ModuleName [ProperName mn'])) a)
761+ | mn' == C.prim = CppVar . runIdent $ f a
762+ qualifiedToCpp f (Qualified (Just mn') a)
763+ | mn /= mn' = CppAccessor (CppVar . identToCpp $ f a) (CppVar (moduleNameToCpp mn'))
764+ qualifiedToCpp f (Qualified _ a) = CppVar $ identToCpp (f a)
765+
766+ -- |
767+ -- Find a class in scope by name, retrieving its list of constraints, function names and types.
768+ --
769+ -------------------------------------------------------------------------------------------------
770+ findClass :: Qualified (ProperName 'ClassName) -> Maybe ([String], [T.Constraint], [(String, T.Type)])
771+ -------------------------------------------------------------------------------------------------
772+ findClass name
773+ | Just (params, fns, constraints) <- M.lookup name (E.typeClasses env),
774+ fns' <- (\(i,t) -> (runIdent i, t)) <$> fns
775+ = Just (fst <$> params, constraints, (sortBy (compare `on` normalizedName . fst) fns'))
776+ findClass _ = Nothing
777+
778+ -------------------------------------------------------------------------------------------------
779+ dataCtors :: [Cpp]
780+ -------------------------------------------------------------------------------------------------
781+ dataCtors = [CppNamespace "data"
782+ [CppEnum Nothing (Just intType) . ("_" :) .
783+ catMaybes . map modCtor . M.keys $ E.dataConstructors env]]
784+ where
785+ modCtor :: Qualified (ProperName a) -> Maybe String
786+ modCtor (Qualified (Just mn') (ProperName name)) | mn' == mn = Just name
787+ modCtor _ = Nothing
788+
789+ -------------------------------------------------------------------------------------------------
790+ curriedForeigns :: m [Cpp]
791+ -------------------------------------------------------------------------------------------------
792+ curriedForeigns = concat <$> mapM go allForeigns
793+ where
794+ go (ident, ty)
795+ | argcnt <- countArgs ty,
796+ argcnt > 1 = do
797+ let name = identToCpp ident
798+ argNames <- replicateM argcnt freshName
799+ return $
800+ [ CppFunction
801+ (curriedName name)
802+ [(head argNames, Just $ CppAny [CppConst, CppRef])]
803+ (Just $ CppAny [])
804+ []
805+ (asReturnBlock $
806+ curriedLambda
807+ (tail argNames)
808+ (CppApp (CppVar name)
809+ (CppVar <$> argNames)))
810+ ]
811+ go _ = return []
812+
813+ allForeigns :: [(Ident, T.Type)]
814+ allForeigns = map (\((_, ident), (ty, _, _)) -> (ident, ty)) .
815+ filter (\((mn', _), (_, kind, _)) -> mn' == mn && kind == E.External) .
816+ M.toList $ E.names env
817+
818+---------------------------------------------------------------------------------------------------
819+asReturnBlock :: Cpp -> Cpp
820+---------------------------------------------------------------------------------------------------
821+asReturnBlock cpp = CppBlock [CppReturn cpp]
822+
823+---------------------------------------------------------------------------------------------------
824+curriedLambda :: [String] -> Cpp -> Cpp
825+---------------------------------------------------------------------------------------------------
826+curriedLambda args ret = foldr (\arg ret' -> CppLambda
827+ [CppCaptureAll]
828+ [(arg, Just $ CppAny [CppConst, CppRef])]
829+ (Just $ CppAny [])
830+ (asReturnBlock ret')
831+ ) ret args
832+
833+---------------------------------------------------------------------------------------------------
834+curriedApp :: [String] -> Expr Ann -> Expr Ann
835+---------------------------------------------------------------------------------------------------
836+curriedApp args vals = foldl (\val arg -> App
837+ nullAnn
838+ val
839+ (Var nullAnn . Qualified Nothing $ Ident arg))
840+ vals args
841+
842+---------------------------------------------------------------------------------------------------
843+countArgs :: T.Type -> Int
844+---------------------------------------------------------------------------------------------------
845+countArgs = go 0
846+ where
847+ go argcnt (T.ForAll _ t _) = go argcnt t
848+ go argcnt (T.TypeApp (T.TypeApp fn _) t) | fn == E.tyFunction = go (argcnt + 1) t
849+ go argcnt (T.ConstrainedType ts t) = go (argcnt + length ts) t
850+ go argcnt _ = argcnt
851+
852+---------------------------------------------------------------------------------------------------
853+extractConstraints :: T.Type -> [T.Constraint]
854+---------------------------------------------------------------------------------------------------
855+extractConstraints = go []
856+ where
857+ go cs (T.ForAll _ t _) = go cs t
858+ go cs (T.TypeApp (T.TypeApp fn _) t) | fn == E.tyFunction = go cs t
859+ go cs (T.ConstrainedType ts t) = go (cs ++ ts) t
860+ go cs _ = cs
861+
862+---------------------------------------------------------------------------------------------------
863+dictIndexerToEnum :: [(Cpp,Cpp)] -> Cpp -> Cpp
864+---------------------------------------------------------------------------------------------------
865+dictIndexerToEnum repls (CppIndexer (CppStringLiteral prop) dict)
866+ | Just cls <- lookup dict repls =
867+ CppBinary Dot
868+ (CppIndexer
869+ (CppAccessor (CppVar . identToCpp $ Ident prop) cls)
870+ (CppCast mapType dict))
871+ (CppVar "second")
872+dictIndexerToEnum _ cpp = cpp
873+
874+---------------------------------------------------------------------------------------------------
875+curriedName :: String -> String
876+---------------------------------------------------------------------------------------------------
877+curriedName name@('$' : _) = name
878+curriedName name = '$' : name
879+
880+---------------------------------------------------------------------------------------------------
881+uncurried' :: Cpp -> Cpp
882+---------------------------------------------------------------------------------------------------
883+uncurried' (CppVar ('$':name)) = CppVar name
884+uncurried' (CppAccessor a b) = CppAccessor (uncurried' a) b
885+uncurried' cpp = cpp
886+
887+---------------------------------------------------------------------------------------------------
888+curriedName' :: Cpp -> Cpp
889+---------------------------------------------------------------------------------------------------
890+curriedName' (CppVar name) = CppVar (curriedName name)
891+curriedName' (CppAccessor a b) = CppAccessor (curriedName' a) b
892+curriedName' cpp = cpp
src/Language/PureScript/CodeGen/Cpp/AST.hsnew file+375
@@ -0,0 +1,375 @@
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
55+ deriving (Show, Read, Eq)
56+
57+-- |
58+-- Built-in binary operators
59+--
60+data BinaryOp
61+ -- |
62+ -- Numeric addition
63+ --
64+ = Add
65+ -- |
66+ -- Numeric subtraction
67+ --
68+ | Subtract
69+ -- |
70+ -- Numeric multiplication
71+ --
72+ | Multiply
73+ -- |
74+ -- Numeric division
75+ --
76+ | Divide
77+ -- |
78+ -- Remainder
79+ --
80+ | Modulus
81+ -- |
82+ -- TODO: revisit this
83+ --
84+ | Dot
85+ -- |
86+ -- Generic equality test
87+ --
88+ | Equal
89+ -- |
90+ -- Generic inequality test
91+ --
92+ | NotEqual
93+ -- |
94+ -- Numeric less-than
95+ --
96+ | LessThan
97+ -- |
98+ -- Numeric less-than-or-equal
99+ --
100+ | LessThanOrEqual
101+ -- |
102+ -- Numeric greater-than
103+ --
104+ | GreaterThan
105+ -- |
106+ -- Numeric greater-than-or-equal
107+ --
108+ | GreaterThanOrEqual
109+ -- |
110+ -- Boolean and
111+ --
112+ | And
113+ -- |
114+ -- Boolean or
115+ --
116+ | Or
117+ -- |
118+ -- Bitwise and
119+ --
120+ | BitwiseAnd
121+ -- |
122+ -- Bitwise or
123+ --
124+ | BitwiseOr
125+ -- |
126+ -- Bitwise xor
127+ --
128+ | BitwiseXor
129+ -- |
130+ -- Bitwise left shift
131+ --
132+ | ShiftLeft
133+ -- |
134+ -- Bitwise right shift
135+ --
136+ | ShiftRight
137+ --
138+ deriving (Show, Read, Eq)
139+
140+-- |
141+-- Data type for simplified C++11 expressions
142+--
143+data Cpp
144+ -- |
145+ -- A numeric literal
146+ --
147+ = CppNumericLiteral (Either Integer Double)
148+ -- |
149+ -- A string literal
150+ --
151+ | CppStringLiteral String
152+ -- |
153+ -- A character literal
154+ --
155+ | CppCharLiteral Char
156+ -- |
157+ -- A boolean literal
158+ --
159+ | CppBooleanLiteral Bool
160+ -- |
161+ -- A unary operator application
162+ --
163+ | CppUnary CppUnaryOp Cpp
164+ -- |
165+ -- A binary operator application
166+ --
167+ | CppBinary BinaryOp Cpp Cpp
168+ -- |
169+ -- An array literal
170+ --
171+ | CppArrayLiteral [Cpp]
172+ -- |
173+ -- A data literal
174+ --
175+ | CppDataLiteral [Cpp]
176+ -- |
177+ -- An enum definition (optional name, optional type)
178+ --
179+ | CppEnum (Maybe String) (Maybe CppType) [String]
180+ -- |
181+ -- An array indexer expression
182+ --
183+ | CppIndexer Cpp Cpp
184+ -- |
185+ -- An object literal
186+ --
187+ | CppObjectLiteral [(String, Cpp)]
188+ -- |
189+ -- An general property accessor expression (property, expr)
190+ --
191+ | CppAccessor Cpp Cpp
192+ -- |
193+ -- A function introduction (name, arguments, return type, qualifiers, body)
194+ --
195+ | CppFunction String [(String, Maybe CppType)] (Maybe CppType) [CppValueQual] Cpp
196+ -- |
197+ -- A lambda introduction (arguments, return type, body)
198+ --
199+ | CppLambda [CppCaptureType] [(String, Maybe CppType)] (Maybe CppType) Cpp
200+ -- |
201+ -- Value type cast
202+ --
203+ | CppCast CppType Cpp
204+ -- |
205+ -- Function application
206+ --
207+ | CppApp Cpp [Cpp]
208+ -- |
209+ -- Variable
210+ --
211+ | CppVar String
212+ -- |
213+ -- A block of expressions in braces
214+ --
215+ | CppBlock [Cpp]
216+ -- |
217+ -- A C++ namespace
218+ --
219+ | CppNamespace String [Cpp]
220+ -- |
221+ -- An C++ struct declaration (name, members)
222+ --
223+ | CppStruct String [Cpp]
224+ -- |
225+ -- A C++ #include
226+ --
227+ | CppInclude String String
228+ -- |
229+ -- A C++ using namespace declaration
230+ --
231+ | CppUseNamespace String
232+ -- |
233+ -- Type alias, e.g. "using T = U" (new name and template types, original type)
234+ --
235+ | CppTypeAlias (String,[(String, Int)]) CppType String
236+ -- |
237+ -- A variable introduction and optional initialization
238+ --
239+ | CppVariableIntroduction (String, Maybe CppType) [CppValueQual] (Maybe Cpp)
240+ -- |
241+ -- A variable assignment
242+ --
243+ | CppAssignment Cpp Cpp
244+ -- |
245+ -- While loop
246+ --
247+ | CppWhile Cpp Cpp
248+ -- |
249+ -- If-then-else statement
250+ --
251+ | CppIfElse Cpp Cpp (Maybe Cpp)
252+ -- |
253+ -- Switch statement
254+ --
255+ | CppSwitch Cpp [(Cpp, Cpp)]
256+ -- |
257+ -- Return statement
258+ --
259+ | CppReturn Cpp
260+ -- |
261+ -- Throw statement
262+ --
263+ | CppThrow Cpp
264+ -- |
265+ -- Continue statement
266+ --
267+ | CppContinue
268+ -- |
269+ -- Empty statement/expression
270+ --
271+ | CppNoOp
272+ -- |
273+ -- Marker for header/source split
274+ --
275+ | CppEndOfHeader
276+ -- |
277+ -- Raw C++11 (generated when parsing fails for an inline foreign import declaration)
278+ --
279+ | CppRaw String
280+ -- |
281+ -- Commented C++11
282+ --
283+ | CppComment [Comment] Cpp
284+ deriving (Show, Read, Eq)
285+
286+--
287+-- Traversals
288+--
289+
290+everywhereOnCpp :: (Cpp -> Cpp) -> Cpp -> Cpp
291+everywhereOnCpp f = go
292+ where
293+ go :: Cpp -> Cpp
294+ go (CppUnary op j) = f (CppUnary op (go j))
295+ go (CppBinary op j1 j2) = f (CppBinary op (go j1) (go j2))
296+ go (CppArrayLiteral cpp) = f (CppArrayLiteral (map go cpp))
297+ go (CppDataLiteral cpp) = f (CppDataLiteral (map go cpp))
298+ go (CppIndexer j1 j2) = f (CppIndexer (go j1) (go j2))
299+ go (CppObjectLiteral cpp) = f (CppObjectLiteral (map (fmap go) cpp))
300+ go (CppAccessor prop j) = f (CppAccessor (go prop) (go j))
301+ go (CppFunction name args rty qs j) = f (CppFunction name args rty qs (go j))
302+ go (CppLambda cps args rty j) = f (CppLambda cps args rty (go j))
303+ go (CppCast t cpp) = f (CppCast t (go cpp))
304+ go (CppApp j cpp) = f (CppApp (go j) (map go cpp))
305+ go (CppBlock cpp) = f (CppBlock (map go cpp))
306+ go (CppNamespace name cpp) = f (CppNamespace name (map go cpp))
307+ go (CppStruct name cpp) = f (CppStruct name (map go cpp))
308+ go (CppVariableIntroduction name qs j) = f (CppVariableIntroduction name qs (fmap go j))
309+ go (CppAssignment j1 j2) = f (CppAssignment (go j1) (go j2))
310+ go (CppWhile j1 j2) = f (CppWhile (go j1) (go j2))
311+ go (CppIfElse j1 j2 j3) = f (CppIfElse (go j1) (go j2) (fmap go j3))
312+ go (CppSwitch cpp cpps) = f (CppSwitch (go cpp) (map (fmap go) cpps))
313+ go (CppReturn cpp) = f (CppReturn (go cpp))
314+ go (CppThrow cpp) = f (CppThrow (go cpp))
315+ go (CppComment com j) = f (CppComment com (go j))
316+ go other = f other
317+
318+everywhereOnCppTopDown :: (Cpp -> Cpp) -> Cpp -> Cpp
319+everywhereOnCppTopDown f = runIdentity . everywhereOnCppTopDownM (Identity . f)
320+
321+everywhereOnCppTopDownM :: (Applicative m, Monad m) => (Cpp -> m Cpp) -> Cpp -> m Cpp
322+everywhereOnCppTopDownM f = f >=> go
323+ where
324+ f' = f >=> go
325+ go (CppUnary op j) = CppUnary op <$> f' j
326+ go (CppBinary op j1 j2) = CppBinary op <$> f' j1 <*> f' j2
327+ go (CppArrayLiteral cpp) = CppArrayLiteral <$> traverse f' cpp
328+ go (CppDataLiteral cpp) = CppDataLiteral <$> traverse f' cpp
329+ go (CppIndexer j1 j2) = CppIndexer <$> f' j1 <*> f' j2
330+ go (CppObjectLiteral cpp) = CppObjectLiteral <$> traverse (sndM f') cpp
331+ go (CppAccessor prop j) = CppAccessor prop <$> f' j
332+ go (CppFunction name args rty qs j) = CppFunction name args rty qs <$> f' j
333+ go (CppLambda cps args rty j) = CppLambda cps args rty <$> f' j
334+ go (CppCast t cpp) = CppCast t <$> f' cpp
335+ go (CppApp j cpp) = CppApp <$> f' j <*> traverse f' cpp
336+ go (CppBlock cpp) = CppBlock <$> traverse f' cpp
337+ go (CppNamespace name cpp) = CppNamespace name <$> traverse f' cpp
338+ go (CppStruct name cpp) = CppStruct name <$> traverse f' cpp
339+ go (CppVariableIntroduction name qs j) = CppVariableIntroduction name qs <$> traverse f' j
340+ go (CppAssignment j1 j2) = CppAssignment <$> f' j1 <*> f' j2
341+ go (CppWhile j1 j2) = CppWhile <$> f' j1 <*> f' j2
342+ go (CppIfElse j1 j2 j3) = CppIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3
343+ go (CppSwitch cpp cpps) = CppSwitch <$> f' cpp <*> traverse (sndM f') cpps
344+ go (CppReturn j) = CppReturn <$> f' j
345+ go (CppThrow j) = CppThrow <$> f' j
346+ go (CppComment com j) = CppComment com <$> f' j
347+ go other = f other
348+
349+everythingOnCpp :: (r -> r -> r) -> (Cpp -> r) -> Cpp -> r
350+everythingOnCpp (<>) f = go
351+ where
352+ go j@(CppUnary _ j1) = f j <> go j1
353+ go j@(CppBinary _ j1 j2) = f j <> go j1 <> go j2
354+ go j@(CppArrayLiteral cpp) = foldl (<>) (f j) (map go cpp)
355+ go j@(CppDataLiteral cpp) = foldl (<>) (f j) (map go cpp)
356+ go j@(CppIndexer j1 j2) = f j <> go j1 <> go j2
357+ go j@(CppObjectLiteral cpp) = foldl (<>) (f j) (map (go . snd) cpp)
358+ go j@(CppAccessor j1 j2) = f j <> go j1 <> go j2
359+ go j@(CppFunction _ _ _ _ j1) = f j <> go j1
360+ go j@(CppLambda _ _ _ j1) = f j <> go j1
361+ go j@(CppCast _ cpp) = f j <> go cpp
362+ go j@(CppApp j1 cpp) = foldl (<>) (f j <> go j1) (map go cpp)
363+ go j@(CppBlock cpp) = foldl (<>) (f j) (map go cpp)
364+ go j@(CppNamespace _ cpp) = foldl (<>) (f j) (map go cpp)
365+ go j@(CppStruct _ cpp) = foldl (<>) (f j) (map go cpp)
366+ go j@(CppVariableIntroduction _ _ (Just j1)) = f j <> go j1
367+ go j@(CppAssignment j1 j2) = f j <> go j1 <> go j2
368+ go j@(CppWhile j1 j2) = f j <> go j1 <> go j2
369+ go j@(CppIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
370+ go j@(CppIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
371+ go j@(CppSwitch cpp cpps) = foldl (<>) (f j <> go cpp) (map (go . snd) cpps)
372+ go j@(CppReturn j1) = f j <> go j1
373+ go j@(CppThrow j1) = f j <> go j1
374+ go j@(CppComment _ j1) = f j <> go j1
375+ go other = f other
src/Language/PureScript/CodeGen/Cpp/Common.hsnew file+204
@@ -0,0 +1,204 @@
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@('$' : s)) | all isDigit s = name
37+identToCpp (Ident name) = concatMap identCharToString name
38+identToCpp (Op op) = concatMap identCharToString op
39+
40+-- |
41+-- Test if a string is a valid Cpp identifier without escaping.
42+--
43+identNeedsEscaping :: String -> Bool
44+identNeedsEscaping s = s /= identToCpp (Ident s)
45+
46+-- |
47+-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
48+-- ordinal value.
49+--
50+identCharToString :: Char -> String
51+identCharToString c | isAlphaNum c = [c]
52+identCharToString '_' = "_"
53+identCharToString '.' = "_dot_"
54+identCharToString '$' = "_dollar_"
55+identCharToString '~' = "_tilde_"
56+identCharToString '=' = "_eq_"
57+identCharToString '<' = "_less_"
58+identCharToString '>' = "_greater_"
59+identCharToString '!' = "_bang_"
60+identCharToString '#' = "_hash_"
61+identCharToString '%' = "_percent_"
62+identCharToString '^' = "_up_"
63+identCharToString '&' = "_amp_"
64+identCharToString '|' = "_bar_"
65+identCharToString '*' = "_times_"
66+identCharToString '/' = "_div_"
67+identCharToString '+' = "_plus_"
68+identCharToString '-' = "_minus_"
69+identCharToString ':' = "_colon_"
70+identCharToString '\\' = "_bslash_"
71+identCharToString '?' = "_qmark_"
72+identCharToString '@' = "_at_"
73+identCharToString '\'' = "_prime_"
74+identCharToString c = '_' : show (ord c) ++ "_"
75+
76+-- |
77+-- Checks whether an identifier name is reserved in C++11.
78+--
79+nameIsCppReserved :: String -> Bool
80+nameIsCppReserved name =
81+ name `elem` [ "alignas"
82+ , "alignof"
83+ , "and"
84+ , "and_eq"
85+ , "any"
86+ , "asm"
87+ , "assert"
88+ , "auto"
89+ , "bitand"
90+ , "bitor"
91+ , "bool"
92+ , "boost"
93+ , "break"
94+ , "case"
95+ , "cast"
96+ , "catch"
97+ , "char"
98+ , "char16_t"
99+ , "char32_t"
100+ , "class"
101+ , "compl"
102+ , "concept"
103+ , "const"
104+ , "constexpr"
105+ , "const_cast"
106+ , "continue"
107+ , "constructor"
108+ , "decltype"
109+ , "default"
110+ , "delete"
111+ , "do"
112+ , "double"
113+ , "dynamic_cast"
114+ , "else"
115+ , "enum"
116+ , "explicit"
117+ , "export"
118+ , "extern"
119+ , "false"
120+ , "final"
121+ , "float"
122+ , "for"
123+ , "friend"
124+ , "goto"
125+ , "if"
126+ , "import"
127+ , "inline"
128+ , "int"
129+ , "integer"
130+ , "list"
131+ , "long"
132+ , "mutable"
133+ , "namespace"
134+ , "new"
135+ , "nil"
136+ , "noexcept"
137+ , "not"
138+ , "not_eq"
139+ , "NULL"
140+ , "null"
141+ , "nullptr"
142+ , "nullptr_t"
143+ , "operator"
144+ , "or"
145+ , "or_eq"
146+ , "override"
147+ , "param"
148+ , "private"
149+ , "protected"
150+ , "public"
151+ , "PureScript"
152+ , "register"
153+ , "reinterpret_cast"
154+ , "requires"
155+ , "return"
156+ , "runtime_error"
157+ , "shared_list"
158+ , "short"
159+ , "signed"
160+ , "sizeof"
161+ , "static"
162+ , "static_assert"
163+ , "static_cast"
164+ , "std"
165+ , "string"
166+ , "struct"
167+ , "switch"
168+ , "template"
169+ , "this"
170+ , "thread_local"
171+ , "throw"
172+ , "true"
173+ , "try"
174+ , "typedef"
175+ , "typeid"
176+ , "typename"
177+ , "typeof"
178+ , "union"
179+ , "unsigned"
180+ , "using"
181+ , "virtual"
182+ , "void"
183+ , "volatile"
184+ , "wchar_t"
185+ , "while"
186+ , "xor"
187+ , "xor_eq" ] || properNameIsCppReserved name
188+
189+normalizedName :: String -> String
190+normalizedName ('_' : s) | last s == '_', s' <- init s, nameIsCppReserved s' = s'
191+normalizedName s = s
192+
193+moduleNameToCpp :: ModuleName -> String
194+moduleNameToCpp (ModuleName pns) =
195+ let name = intercalate "_" (runProperName `map` pns)
196+ in if properNameIsCppReserved name then '_' : name ++ "_" else name
197+
198+-- |
199+-- Checks whether a proper name is reserved in C++11.
200+--
201+properNameIsCppReserved :: String -> Bool
202+properNameIsCppReserved name =
203+ name `elem` [ "Private"
204+ , "PureScript" ]
src/Language/PureScript/CodeGen/Cpp/File.hsnew file+182
@@ -0,0 +1,182 @@
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.Types
24+import Language.PureScript.Names
25+
26+import qualified Language.PureScript.Pretty.Cpp as P
27+
28+---------------------------------------------------------------------------------------------------
29+toHeader :: [Cpp] -> [Cpp]
30+---------------------------------------------------------------------------------------------------
31+toHeader = catMaybes . map go
32+ where
33+ go :: Cpp -> Maybe Cpp
34+ go (CppNamespace name cpps)
35+ | cpps'@(_:_) <- toHeader cpps = Just (CppNamespace name cpps')
36+ | otherwise = Nothing
37+ go cpp@(CppUseNamespace{}) = Just cpp
38+ go (CppFunction _ _ _ qs _)
39+ | CppInline `elem` qs = Nothing
40+ go (CppFunction _ [(_, atyp)] _ _ (CppBlock [CppReturn (CppApp _ [_])])) | atyp == Just CppAuto
41+ = Nothing
42+ go (CppFunction name args rtyp qs _) =
43+ let args' = (\(_,t) -> ("", t)) <$> args in
44+ Just (CppFunction name args' rtyp qs CppNoOp)
45+ go (CppVariableIntroduction _ _ (Just CppNumericLiteral {})) =
46+ Nothing
47+ go (CppVariableIntroduction _ _ (Just CppStringLiteral {})) =
48+ Nothing
49+ go (CppVariableIntroduction _ _ (Just CppBooleanLiteral {})) =
50+ Nothing
51+ go (CppVariableIntroduction (name, _) _ (Just (CppLambda _ [] rty _))) =
52+ Just $ CppFunction name [] rty [] CppNoOp
53+ -- Generate thunks for top-level values
54+ go (CppVariableIntroduction (name, _) _ (Just _)) =
55+ Just $ CppVariableIntroduction (name, Just $ CppAny [CppConst]) [CppExtern] Nothing
56+ go cpp@(CppStruct {}) =
57+ Just cpp
58+ go (CppComment comms cpp')
59+ | Just cpp <- go cpp' = Just $ case cpp of CppFunction {} -> cpp
60+ _ -> CppComment comms cpp
61+ go _ = Nothing
62+
63+---------------------------------------------------------------------------------------------------
64+toHeaderFns :: [Cpp] -> [Cpp]
65+---------------------------------------------------------------------------------------------------
66+toHeaderFns = catMaybes . map go
67+ where
68+ go :: Cpp -> Maybe Cpp
69+ go (CppNamespace name cpps)
70+ | cpps'@(_:_) <- toHeaderFns cpps = Just (CppNamespace name cpps')
71+ | otherwise = Nothing
72+ go cpp@(CppFunction _ _ _ qs _)
73+ | CppInline `elem` qs = Just cpp
74+ go (CppFunction name [(_, atyp)] _ _ (CppBlock [CppReturn (CppApp cpp [_])]))
75+ | atyp == Just CppAuto
76+ = Just (CppVariableIntroduction (name, Nothing) [] (Just cpp))
77+ go cpp@(CppVariableIntroduction _ _ (Just CppNumericLiteral {})) =
78+ Just cpp
79+ go cpp@(CppVariableIntroduction _ _ (Just CppStringLiteral {})) =
80+ Just cpp
81+ go cpp@(CppVariableIntroduction _ _ (Just CppBooleanLiteral {})) =
82+ Just cpp
83+ go (CppComment comms cpp') | Just cpp <- go cpp' = Just (CppComment comms cpp)
84+ go _ = Nothing
85+
86+---------------------------------------------------------------------------------------------------
87+toBodyDecl :: [Cpp] -> [Cpp]
88+---------------------------------------------------------------------------------------------------
89+toBodyDecl = catMaybes . map go
90+ where
91+ go :: Cpp -> Maybe Cpp
92+ go (CppComment comms cpp') | Just commented <- go cpp' = Just (CppComment comms commented)
93+ go _ = Nothing
94+
95+---------------------------------------------------------------------------------------------------
96+toBody :: [Cpp] -> [Cpp]
97+---------------------------------------------------------------------------------------------------
98+toBody = catMaybes . map go
99+ where
100+ go :: Cpp -> Maybe Cpp
101+ go (CppNamespace name cpps)
102+ | cpps'@(_:_) <- toBody cpps = Just (CppNamespace name cpps')
103+ | otherwise = Nothing
104+ go cpp@(CppUseNamespace{}) = Just cpp
105+ go (CppFunction _ _ _ qs _)
106+ | CppInline `elem` qs = Nothing
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+ go (CppVariableIntroduction (name, _) _ (Just (CppLambda _ [] rty body))) =
115+ Just $ CppFunction name [] rty [] body
116+ -- Generate thunks for top-level values
117+ go (CppVariableIntroduction (name, _) _ (Just cpp)) =
118+ Just $ CppVariableIntroduction (name, Just $ CppAny [CppConst]) [] (Just lambda)
119+ where
120+ val = CppVariableIntroduction ("$value$", Just $ CppAny [CppConst]) [CppStatic] (Just $ addCaptures cpp)
121+ block = CppBlock [val, CppReturn (CppVar "$value$")]
122+ lambda = CppLambda [] [("", Just $ thunkMarkerType)] (Just $ CppAny [CppConst, CppRef]) block
123+ addCaptures :: Cpp -> Cpp
124+ addCaptures (CppObjectLiteral objs) = CppObjectLiteral (objlam <$> objs)
125+ where
126+ objlam :: (String, Cpp) -> (String, Cpp)
127+ objlam (name', (CppLambda _ args rty body)) = (name' , CppLambda [] args rty $ addCaptures body)
128+ objlam obj = obj
129+ addCaptures (CppApp (CppLambda _ [] rty body) []) = CppApp (CppLambda [] [] rty (addCaptures body)) []
130+ addCaptures cpps' = everywhereOnCpp addCapture cpps'
131+ where
132+ addCapture :: Cpp -> Cpp
133+ addCapture (CppLambda _ args rty body) = maybeRemCaps $ CppLambda [CppCaptureAll] args rty body
134+ addCapture cpp' = cpp'
135+ go (CppComment comms cpp') | Just commented <- go cpp' = Just (CppComment comms commented)
136+ go _ = Nothing
137+
138+-------------------------------------------------------------------------------------------------
139+maybeRemCaps :: Cpp -> Cpp
140+-------------------------------------------------------------------------------------------------
141+maybeRemCaps (CppLambda [CppCaptureAll] args rtyp body@(CppBlock [CppReturn CppNumericLiteral{}]))
142+ = CppLambda [] args rtyp body
143+maybeRemCaps (CppLambda [CppCaptureAll] args rtyp body@(CppBlock [CppReturn CppStringLiteral{}]))
144+ = CppLambda [] args rtyp body
145+maybeRemCaps (CppLambda [CppCaptureAll] args rtyp body@(CppBlock [CppReturn CppCharLiteral{}]))
146+ = CppLambda [] args rtyp body
147+maybeRemCaps (CppLambda [CppCaptureAll] args rtyp body@(CppBlock [CppReturn CppBooleanLiteral{}]))
148+ = CppLambda [] args rtyp body
149+maybeRemCaps (CppLambda [CppCaptureAll] args rtyp body@(CppBlock [CppReturn CppAccessor{}]))
150+ = CppLambda [] args rtyp body
151+maybeRemCaps (CppLambda [CppCaptureAll] args rtyp body@(CppBlock [CppReturn (CppVar "unit")])) -- TODO: not really safe
152+ = CppLambda [] args rtyp body
153+maybeRemCaps cpp = cpp
154+
155+---------------------------------------------------------------------------------------------------
156+
157+fileBegin :: ModuleName -> String -> [Cpp]
158+fileBegin mn suffix = [CppRaw ("#ifndef " ++ fileModName mn suffix),
159+ CppRaw ("#define " ++ fileModName mn suffix)]
160+
161+fileEnd :: ModuleName -> String -> [Cpp]
162+fileEnd mn suffix = [CppRaw ("#endif // " ++ fileModName mn suffix)]
163+
164+fileModName :: ModuleName -> String -> String
165+fileModName mn suffix = P.dotsTo '_' (runModuleName mn ++ '_' : suffix)
166+
167+isMain :: ModuleName -> Bool
168+isMain (ModuleName [ProperName "Main"]) = True
169+isMain _ = False
170+
171+nativeMain :: Cpp
172+nativeMain = CppFunction "main"
173+ [ ([], Just $ CppPrimitive "int")
174+ , ([], Just $ CppPrimitive "char *[]")
175+ ]
176+ (Just $ CppPrimitive "int")
177+ []
178+ (CppBlock [ CppUseNamespace "Main"
179+ , CppApp (CppVar "INITIALIZE_GC") []
180+ , CppApp (CppAccessor (CppVar "main") (CppVar "Main")) []
181+ , CppReturn (CppNumericLiteral (Left 0))
182+ ])
src/Language/PureScript/CodeGen/Cpp/Optimizer.hsnew file+93
@@ -0,0 +1,93 @@
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+ , collapseIfElses
73+ , tco opts
74+ , magicDo opts
75+ , removeCodeAfterReturnStatements
76+ , removeCodeAfterContinueStatements
77+ , removeUnusedArg
78+ , unThunk
79+ , etaConvert
80+ , evaluateIifes
81+ , inlineVariables
82+ , inlineValues
83+ , inlineOperator (C.prelude, (C.$)) $ \f x -> CppApp f [x]
84+ , inlineOperator (C.prelude, (C.#)) $ \x f -> CppApp f [x]
85+ , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip CppIndexer
86+ , inlineCommonOperators ]) cpp
87+
88+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
89+untilFixedPoint f = go
90+ where
91+ go a = do
92+ a' <- f a
93+ if a' == a then return a' else go a'
src/Language/PureScript/CodeGen/Cpp/Optimizer/Blocks.hsnew file+83
@@ -0,0 +1,83 @@
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+ , collapseIfElses
20+ ) where
21+
22+import Language.PureScript.CodeGen.Cpp.AST
23+import qualified Language.PureScript.Constants as C
24+
25+-- |
26+-- Collapse blocks which appear nested directly below another block
27+--
28+collapseNestedBlocks :: Cpp -> Cpp
29+collapseNestedBlocks = everywhereOnCpp collapse
30+ where
31+ collapse :: Cpp -> Cpp
32+ collapse (CppBlock sts) = CppBlock (concatMap go sts)
33+ collapse cpp = cpp
34+ go :: Cpp -> [Cpp]
35+ go (CppBlock sts) = sts
36+ go s = [s]
37+
38+collapseNestedIfs :: Cpp -> Cpp
39+collapseNestedIfs = everywhereOnCpp collapse
40+ where
41+ collapse :: Cpp -> Cpp
42+ collapse (CppIfElse cond1 (CppBlock [CppIfElse cond2 body Nothing]) Nothing) =
43+ CppIfElse (CppBinary And cond1 cond2) body Nothing
44+ collapse cpp = cpp
45+
46+collapseIfElses :: Cpp -> Cpp
47+collapseIfElses = everywhereOnCpp collapse
48+ where
49+ collapse :: Cpp -> Cpp
50+ collapse (CppBlock cpps) = CppBlock (go cpps)
51+ where
52+ go (st'@(CppIfElse (CppBinary Equal a _) _ Nothing) : sts') =
53+ if length (fst cpps') > 1
54+ then CppSwitch a (mkCases <$> fst cpps') : snd cpps'
55+ else st' : sts'
56+ where
57+ cpps' = span (isIntEq a) (st' : sts')
58+ isIntEq :: Cpp -> Cpp -> Bool
59+ isIntEq a (CppIfElse (CppBinary Equal a' (CppNumericLiteral (Left _))) (CppBlock [CppReturn _]) Nothing)
60+ | a == a' = True
61+ isIntEq a (CppIfElse (CppBinary Equal a' (CppCharLiteral _)) (CppBlock [CppReturn _]) Nothing)
62+ | a == a' = True
63+ isIntEq a (CppIfElse (CppBinary Equal a' (CppBooleanLiteral _)) (CppBlock [CppReturn _]) Nothing)
64+ | a == a' = True
65+ isIntEq _ _ = False
66+ mkCases :: Cpp -> (Cpp, Cpp)
67+ mkCases (CppIfElse (CppBinary Equal _ b') (CppBlock [body]) Nothing) = (b', body)
68+ mkCases (CppIfElse (CppUnary CppNot _) (CppBlock [body]) Nothing) = (CppBooleanLiteral False, body)
69+ mkCases (CppIfElse _ (CppBlock [body]) Nothing) = (CppBooleanLiteral True, body)
70+ mkCases _ = error ""
71+ go ((CppIfElse cond1 body1 Nothing) : (CppIfElse cond2 body2 Nothing) : _)
72+ | returns body1 && returns body2 &&
73+ (CppUnary CppNot cond1 == cond2 ||
74+ CppUnary CppNot cond2 == cond1) = [CppIfElse cond1 body1 (Just body2)]
75+ where
76+ returns :: Cpp -> Bool
77+ returns (CppBlock rets@(_:_)) | CppReturn{} <- last rets = True
78+ returns CppReturn{} = True
79+ returns _ = False
80+ go (cpp' : cpps') = cpp' : go cpps'
81+ go cpp' = cpp'
82+ collapse (CppIfElse (CppAccessor (CppVar "otherwise") (CppVar mn')) body _) | mn' == C.prelude = body
83+ 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+344
@@ -0,0 +1,344 @@
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 (CppCast _ val) = shouldInline val
52+shouldInline _ = False
53+
54+etaConvert :: Cpp -> Cpp
55+etaConvert = everywhereOnCpp convert
56+ where
57+ convert :: Cpp -> Cpp
58+ convert (CppBlock [CppReturn (CppApp (CppLambda _ idents _ block@(CppBlock body)) args)])
59+ | all shouldInline args &&
60+ not (any (`isRebound` block) (map (CppVar . fst) idents)) &&
61+ not (any (`isRebound` block) args)
62+ = CppBlock (map (replaceIdents (zip (map fst idents) args)) body)
63+ convert (CppLambda _ [] _ (CppBlock [CppReturn (CppApp fn [])])) = fn
64+ convert cpp = cpp
65+
66+unThunk :: Cpp -> Cpp
67+unThunk = everywhereOnCpp convert
68+ where
69+ convert :: Cpp -> Cpp
70+ convert (CppBlock []) = CppBlock []
71+ convert (CppBlock cpps) =
72+ case last cpps of
73+ CppReturn (CppApp (CppLambda _ [] _ (CppBlock body)) []) -> CppBlock $ init cpps ++ body
74+ _ -> CppBlock cpps
75+ convert cpp = cpp
76+
77+evaluateIifes :: Cpp -> Cpp
78+evaluateIifes = everywhereOnCpp convert
79+ where
80+ convert :: Cpp -> Cpp
81+ convert (CppApp (CppLambda _ [] _ (CppBlock [CppReturn ret])) []) = ret
82+ convert (CppReturn cpp@(CppApp _ _))
83+ | (f, args@(_:_)) <- unApp cpp [],
84+ CppApp (CppLambda _ [] _ (CppBlock cpps)) [] <- f,
85+ CppReturn ret <- last cpps = CppBlock $ init cpps ++ [CppReturn $foldl (\fn a -> CppApp fn [a]) ret args]
86+ where
87+ unApp :: Cpp -> [Cpp] -> (Cpp, [Cpp])
88+ unApp (CppApp f [arg]) args = unApp f (arg : args)
89+ unApp other args = (other, args)
90+ convert cpp = cpp
91+
92+inlineVariables :: Cpp -> Cpp
93+inlineVariables = everywhereOnCpp $ removeFromBlock go
94+ where
95+ go :: [Cpp] -> [Cpp]
96+ go [] = []
97+ go (CppVariableIntroduction (var, _) _ (Just cpp) : sts)
98+ | shouldInline cpp && not (any (isReassigned var) sts) && not (any (isRebound cpp) sts) && not (any (isUpdated var) sts) =
99+ go (map (replaceIdent var cpp) sts)
100+ go (s:sts) = s : go sts
101+
102+inlineValues :: Cpp -> Cpp
103+inlineValues = everywhereOnCpp convert
104+ where
105+ convert :: Cpp -> Cpp
106+ convert (CppApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = CppNumericLiteral (Left 0)
107+ | isDict semiringNumber dict && isFn fnOne fn = CppNumericLiteral (Left 1)
108+ | isDict semiringInt dict && isFn fnZero fn = CppNumericLiteral (Left 0)
109+ | isDict semiringInt dict && isFn fnOne fn = CppNumericLiteral (Left 1)
110+ | isDict boundedBoolean dict && isFn fnBottom fn = CppBooleanLiteral False
111+ | isDict boundedBoolean dict && isFn fnTop fn = CppBooleanLiteral True
112+ convert (CppApp fn [dict, x, y])
113+ | isDict semiringInt dict && isFn fnAdd fn = CppBinary Add x y
114+ | isDict semiringInt dict && isFn fnMultiply fn = CppBinary Multiply x y
115+ | isDict moduloSemiringInt dict && isFn fnDivide fn = CppBinary Divide x y
116+ | isDict ringInt dict && isFn fnSubtract fn = CppBinary Subtract x y
117+ convert (CppApp (CppApp (CppApp fn [dict]) [x]) [y])
118+ | isDict semiringInt dict && isFn fnAdd fn = CppBinary Add x y
119+ | isDict semiringInt dict && isFn fnMultiply fn = CppBinary Multiply x y
120+ | isDict moduloSemiringInt dict && isFn fnDivide fn = CppBinary Divide x y
121+ | isDict ringInt dict && isFn fnSubtract fn = CppBinary Subtract x y
122+
123+ convert other = other
124+ fnZero = (C.prelude, C.zero)
125+ fnOne = (C.prelude, C.one)
126+ fnBottom = (C.prelude, C.bottom)
127+ fnTop = (C.prelude, C.top)
128+ fnAdd = (C.prelude, (C.+))
129+ fnDivide = (C.prelude, (C./))
130+ fnMultiply = (C.prelude, (C.*))
131+ fnSubtract = (C.prelude, (C.-))
132+
133+inlineOperator :: (String, String) -> (Cpp -> Cpp -> Cpp) -> Cpp -> Cpp
134+inlineOperator (m, op) f = everywhereOnCpp convert
135+ where
136+ convert :: Cpp -> Cpp
137+ convert (CppApp op' [x, y]) | isOp op' = f x y
138+ convert (CppApp (CppApp op' [x]) [y]) | isOp op' = f x y
139+ convert other = other
140+ isOp (CppAccessor (CppVar longForm) (CppVar m')) = m == m' && longForm == identToCpp (Op op)
141+ isOp (CppIndexer (CppStringLiteral op') (CppVar m')) = m == m' && op == op'
142+ isOp _ = False
143+
144+inlineCommonOperators :: Cpp -> Cpp
145+inlineCommonOperators = applyAll $
146+ [ binary semiringNumber (C.+) Add
147+ , binary semiringNumber (C.*) Multiply
148+
149+ , binary ringNumber (C.-) Subtract
150+ , unary ringNumber C.negate CppNegate
151+ , binary ringInt (C.-) Subtract
152+ , unary ringInt C.negate CppNegate
153+
154+ , binary moduloSemiringNumber (C./) Divide
155+ , binary moduloSemiringInt C.mod Modulus
156+
157+ , binary eqNumber (C.==) Equal
158+ , binary eqNumber (C./=) NotEqual
159+ , binary eqInt (C.==) Equal
160+ , binary eqInt (C./=) NotEqual
161+ , binary eqString (C.==) Equal
162+ , binary eqString (C./=) NotEqual
163+ , binary eqBoolean (C.==) Equal
164+ , binary eqBoolean (C./=) NotEqual
165+
166+ , binary ordNumber (C.<) LessThan
167+ , binary ordNumber (C.>) GreaterThan
168+ , binary ordNumber (C.<=) LessThanOrEqual
169+ , binary ordNumber (C.>=) GreaterThanOrEqual
170+ , binary ordInt (C.<) LessThan
171+ , binary ordInt (C.>) GreaterThan
172+ , binary ordInt (C.<=) LessThanOrEqual
173+ , binary ordInt (C.>=) GreaterThanOrEqual
174+
175+ , binary semigroupString (C.<>) Add
176+ , binary semigroupString (C.++) Add
177+
178+ , binary booleanAlgebraBoolean (C.&&) And
179+ , binary booleanAlgebraBoolean (C.||) Or
180+ , binaryFunction booleanAlgebraBoolean C.conj And
181+ , binaryFunction booleanAlgebraBoolean C.disj Or
182+ , unary booleanAlgebraBoolean C.not CppNot
183+
184+ , binary' C.dataIntBits (C..|.) BitwiseOr
185+ , binary' C.dataIntBits (C..&.) BitwiseAnd
186+ , binary' C.dataIntBits (C..^.) BitwiseXor
187+ , binary' C.dataIntBits C.shl ShiftLeft
188+ , binary' C.dataIntBits C.shr ShiftRight
189+ -- , binary' C.dataIntBits C.zshr ZeroFillShiftRight
190+ , unary' C.dataIntBits C.complement CppBitwiseNot
191+ ] -- ++ -- DISABLE mkFn/runFn inlining
192+ -- [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
193+ where
194+ binary :: (String, String) -> String -> BinaryOp -> Cpp -> Cpp
195+ binary dict opString op = everywhereOnCpp convert
196+ where
197+ convert :: Cpp -> Cpp
198+ convert (CppApp fn [dict', CppStringLiteral x, CppStringLiteral y])
199+ | isDict dict dict' && isPreludeFn opString fn = CppStringLiteral (x ++ y)
200+ convert (CppApp fn [dict', x, y]) | isDict dict dict' && isPreludeFn opString fn = CppBinary op x y
201+ convert (CppApp (CppApp (CppApp fn [dict']) [CppStringLiteral x]) [CppStringLiteral y])
202+ | isDict dict dict' && isPreludeFn opString fn = CppStringLiteral (x ++ y)
203+ convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = CppBinary op x y
204+ convert other = other
205+ binary' :: String -> String -> BinaryOp -> Cpp -> Cpp
206+ binary' moduleName opString op = everywhereOnCpp convert
207+ where
208+ convert :: Cpp -> Cpp
209+ convert (CppApp fn [x, y]) | isFn (moduleName, opString) fn = CppBinary op x y
210+ convert (CppApp (CppApp fn [x]) [y]) | isFn (moduleName, opString) fn = CppBinary op x y
211+ convert other = other
212+ binaryFunction :: (String, String) -> String -> BinaryOp -> Cpp -> Cpp
213+ binaryFunction dict fnName op = everywhereOnCpp convert
214+ where
215+ convert :: Cpp -> Cpp
216+ convert (CppApp fn [dict', x, y]) | isPreludeFn fnName fn && isDict dict dict' = CppBinary op x y
217+ convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = CppBinary op x y
218+ convert other = other
219+ unary :: (String, String) -> String -> CppUnaryOp -> Cpp -> Cpp
220+ unary dict fnName op = everywhereOnCpp convert
221+ where
222+ convert :: Cpp -> Cpp
223+ convert (CppApp fn [dict', x]) | isPreludeFn fnName fn && isDict dict dict' = CppUnary op x
224+ convert (CppApp (CppApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = CppUnary op x
225+ convert other = other
226+ unary' :: String -> String -> CppUnaryOp -> Cpp -> Cpp
227+ unary' moduleName fnName op = everywhereOnCpp convert
228+ where
229+ convert :: Cpp -> Cpp
230+ convert (CppApp fn [x]) | isFn (moduleName, fnName) fn = CppUnary op x
231+ convert other = other
232+ -- mkFn :: Int -> Cpp -> Cpp
233+ -- mkFn 0 = everywhereOnCpp convert
234+ -- where
235+ -- convert :: Cpp -> Cpp
236+ -- convert (CppApp mkFnN [CppLambda caps [_] _ (CppBlock cpp)]) | isNFn C.mkFn 0 mkFnN =
237+ -- CppLambda caps [] Nothing (CppBlock cpp)
238+ -- convert other = other
239+ -- mkFn n = everywhereOnCpp convert
240+ -- where
241+ -- convert :: Cpp -> Cpp
242+ -- convert orig@(CppApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =
243+ -- case collectArgs n [] fn of
244+ -- Just (args, cpp) -> CppLambda [CppCaptureAll] args Nothing (CppBlock cpp)
245+ -- Nothing -> orig
246+ -- convert other = other
247+ -- collectArgs :: Int -> [(String, Maybe CppType)] -> Cpp -> Maybe ([(String, Maybe CppType)], [Cpp])
248+ -- collectArgs 1 acc (CppLambda _ [oneArg] _ (CppBlock cpp)) | length acc == n - 1 = Just (reverse (oneArg : acc), cpp)
249+ -- collectArgs m acc (CppLambda _ [oneArg] _ (CppBlock [CppReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret
250+ -- collectArgs _ _ _ = Nothing
251+ --
252+ -- isNFn :: String -> Int -> Cpp -> Bool
253+ -- isNFn prefix n (CppVar name) = name == (prefix ++ show n)
254+ -- isNFn prefix n (CppAccessor (CppVar name) (CppVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
255+ -- isNFn _ _ _ = False
256+ --
257+ -- runFn :: Int -> Cpp -> Cpp
258+ -- runFn n = everywhereOnCpp convert
259+ -- where
260+ -- convert :: Cpp -> Cpp
261+ -- convert cpp = fromMaybe cpp $ go n [] cpp
262+ --
263+ -- go :: Int -> [Cpp] -> Cpp -> Maybe Cpp
264+ -- go 0 acc (CppApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (CppApp fn acc)
265+ -- go m acc (CppApp lhs [arg]) = go (m - 1) (arg : acc) lhs
266+ -- go _ _ _ = Nothing
267+
268+-- (f <<< g $ x) = f (g x)
269+-- (f <<< g) = \x -> f (g x)
270+inlineFnComposition :: (Applicative m, MonadSupply m) => Cpp -> m Cpp
271+inlineFnComposition = everywhereOnCppTopDownM convert
272+ where
273+ convert :: (MonadSupply m) => Cpp -> m Cpp
274+ convert (CppApp fn [dict', x, y]) | isFnCompose dict' fn = do
275+ arg <- freshName
276+ return $ CppLambda [CppCaptureAll] [(arg, Just (CppAny [CppConst, CppRef]))] (Just $ CppAny []) (CppBlock [CppReturn $ CppApp x [CppApp y [CppVar arg]]])
277+ convert (CppApp (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn =
278+ return $ CppApp x [CppApp y [z]]
279+ convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do
280+ arg <- freshName
281+ return $ CppLambda [CppCaptureAll] [(arg, Just (CppAny [CppConst, CppRef]))] (Just $ CppAny []) (CppBlock [CppReturn $ CppApp x [CppApp y [CppVar arg]]])
282+ convert other = return other
283+ isFnCompose :: Cpp -> Cpp -> Bool
284+ isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn (C.compose) fn)
285+
286+isDict :: (String, String) -> Cpp -> Bool
287+isDict (moduleName, dictName) (CppAccessor (CppVar x) (CppVar y)) = x == dictName && y == moduleName
288+isDict _ _ = False
289+
290+isFn :: (String, String) -> Cpp -> Bool
291+isFn (moduleName, fnName) (CppAccessor (CppVar x) (CppVar y)) = x == (identToCpp (Ident fnName)) && y == moduleName
292+isFn (moduleName, fnName) (CppIndexer (CppStringLiteral x) (CppVar y)) = x == fnName && y == moduleName
293+isFn _ _ = False
294+
295+isPreludeFn :: String -> Cpp -> Bool
296+isPreludeFn fnName = isFn (C.prelude, fnName)
297+
298+semiringNumber :: (String, String)
299+semiringNumber = (C.prelude, C.semiringNumber)
300+
301+semiringInt :: (String, String)
302+semiringInt = (C.prelude, C.semiringInt)
303+
304+ringNumber :: (String, String)
305+ringNumber = (C.prelude, C.ringNumber)
306+
307+ringInt :: (String, String)
308+ringInt = (C.prelude, C.ringInt)
309+
310+moduloSemiringNumber :: (String, String)
311+moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)
312+
313+moduloSemiringInt :: (String, String)
314+moduloSemiringInt = (C.prelude, C.moduloSemiringInt)
315+
316+eqNumber :: (String, String)
317+eqNumber = (C.prelude, C.eqNumber)
318+
319+eqInt :: (String, String)
320+eqInt = (C.prelude, C.eqInt)
321+
322+eqString :: (String, String)
323+eqString = (C.prelude, C.eqNumber)
324+
325+eqBoolean :: (String, String)
326+eqBoolean = (C.prelude, C.eqNumber)
327+
328+ordNumber :: (String, String)
329+ordNumber = (C.prelude, C.ordNumber)
330+
331+ordInt :: (String, String)
332+ordInt = (C.prelude, C.ordInt)
333+
334+semigroupString :: (String, String)
335+semigroupString = (C.prelude, C.semigroupString)
336+
337+boundedBoolean :: (String, String)
338+boundedBoolean = (C.prelude, C.boundedBoolean)
339+
340+booleanAlgebraBoolean :: (String, String)
341+booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean)
342+
343+semigroupoidFn :: (String, String)
344+semigroupoidFn = (C.prelude, C.semigroupoidFn)
src/Language/PureScript/CodeGen/Cpp/Optimizer/MagicDo.hsnew file+125
@@ -0,0 +1,125 @@
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 [effDict, val]) []) | isRetPoly ret && isEffDict C.monadEffDictionary effDict = val
57+ convert (CppApp (CppApp ret [val]) []) | isReturn ret = val
58+ -- Desugar pure
59+ convert (CppApp (CppApp pure' [effDict, val]) []) | isPurePoly pure' && isEffDict C.applicativeEffDictionary effDict = val
60+ convert (CppApp (CppApp pure' [val]) []) | isPure pure' = val
61+ -- Desugar >>
62+ convert (CppApp bind [effDict, m, CppLambda _ [] rty (CppBlock cpp)]) | isBindPoly bind && isEffDict C.bindEffDictionary effDict =
63+ CppFunction fnName [] rty [] $ CppBlock (CppApp m [] : map applyReturns cpp )
64+ convert (CppApp (CppApp bind [m]) [CppLambda _ [] rty (CppBlock cpp)]) | isBind bind =
65+ CppFunction fnName [] rty [] $ CppBlock (CppApp m [] : map applyReturns cpp )
66+ -- Desugar >>=
67+ convert (CppApp bind [effDict, m, CppLambda _ [arg] rty (CppBlock cpp)]) | isBindPoly bind && isEffDict C.bindEffDictionary effDict =
68+ CppFunction fnName [] rty [] $ CppBlock (CppVariableIntroduction arg [] (Just (CppApp m [])) : map applyReturns cpp)
69+ convert (CppApp (CppApp bind [m]) [CppLambda _ [arg] rty (CppBlock cpp)]) | isBind bind =
70+ CppFunction fnName [] rty [] $ CppBlock (CppVariableIntroduction arg [] (Just (CppApp m [])) : map applyReturns cpp)
71+ -- Desugar untilE
72+ convert (CppApp (CppApp f [arg]) []) | isEffFunc C.untilE f =
73+ CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppUnary CppNot (CppApp arg [])) (CppBlock []), CppReturn $ CppObjectLiteral []])) []
74+ -- Desugar whileE
75+ convert (CppApp (CppApp f [arg1, arg2]) []) | isEffFunc C.whileE f =
76+ CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppApp arg1 []) (CppBlock [ CppApp arg2 [] ]), CppReturn $ CppObjectLiteral []])) []
77+ convert (CppApp (CppApp (CppApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
78+ CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppApp arg1 []) (CppBlock [ CppApp arg2 [] ]), CppReturn $ CppObjectLiteral []])) []
79+ convert other = other
80+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
81+ isBind (CppApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True
82+ isBind _ = False
83+ -- Check if an expression represents a monomorphic call to return for the Eff monad
84+ isReturn (CppApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
85+ isReturn _ = False
86+ -- Check if an expression represents a monomorphic call to pure for the Eff applicative
87+ isPure (CppApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True
88+ isPure _ = False
89+ -- Check if an expression represents the polymorphic >>= function
90+ isBindPoly (CppAccessor (CppVar prop) (CppVar prelude)) = prelude == C.prelude && (prop `elem` map identToCpp [Ident C.bind, Op (C.>>=)])
91+ isBindPoly (CppIndexer (CppStringLiteral bind) (CppVar prelude)) = prelude == C.prelude && (bind `elem` [C.bind, (C.>>=)])
92+ isBindPoly _ = False
93+ -- Check if an expression represents the polymorphic return function
94+ isRetPoly (CppAccessor (CppVar returnEscaped) (CppVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
95+ isRetPoly (CppIndexer (CppStringLiteral return') (CppVar prelude)) = prelude == C.prelude && return' == C.return
96+ isRetPoly _ = False
97+ -- Check if an expression represents the polymorphic pure function
98+ isPurePoly (CppAccessor (CppVar pure') (CppVar prelude)) = prelude == C.prelude && pure' == C.pure'
99+ isPurePoly (CppIndexer (CppStringLiteral pure') (CppVar prelude)) = prelude == C.prelude && pure' == C.pure'
100+ isPurePoly _ = False
101+ -- Check if an expression represents a function in the Ef module
102+ isEffFunc name (CppAccessor (CppVar name') (CppVar eff)) = eff == C.eff && name == name'
103+ isEffFunc _ _ = False
104+ -- Check if an expression represents the Monad Eff dictionary
105+ isEffDict name (CppVar ident) | ident == name = True
106+ isEffDict name (CppAccessor (CppVar prop) (CppVar eff)) = eff == C.eff && prop == name
107+ isEffDict _ _ = False
108+ -- Remove __do function applications which remain after desugaring
109+ undo :: Cpp -> Cpp
110+ undo (CppReturn (CppApp (CppFunction ident [] _ _ body) [])) | ident == fnName = body
111+ undo (CppFunction ident [] rty _ body) | ident == fnName = CppLambda [CppCaptureAll] [] rty body
112+ undo other = other
113+
114+ applyReturns :: Cpp -> Cpp
115+ applyReturns (CppReturn ret) = CppReturn (CppApp ret [])
116+ applyReturns (CppBlock cpps) = CppBlock (map applyReturns cpps)
117+ applyReturns (CppWhile cond cpp) = CppWhile cond (applyReturns cpp)
118+ applyReturns (CppIfElse cond t f) = CppIfElse cond (applyReturns t) (applyReturns `fmap` f)
119+ applyReturns other = other
120+
121+-- |
122+-- Inline functions in the ST module
123+--
124+-- TODO: various issues in C++ backend -- revisit later
125+--
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+45
@@ -0,0 +1,45 @@
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+removeCodeAfterContinueStatements :: Cpp -> Cpp
33+removeCodeAfterContinueStatements = everywhereOnCpp (removeFromBlock go)
34+ where
35+ go :: [Cpp] -> [Cpp]
36+ go cpps | not (any isCppContinue cpps) = cpps
37+ | otherwise = let (body, ret : _) = span (not . isCppContinue) cpps in body ++ [ret]
38+ isCppContinue = (== CppContinue)
39+
40+removeUnusedArg :: Cpp -> Cpp
41+removeUnusedArg = everywhereOnCpp convert
42+ where
43+ convert (CppFunction name [(arg,atyp)] rtyp qs body)
44+ | arg == C.__unused = CppFunction name [("",atyp)] rtyp qs body
45+ convert cpp = cpp
src/Language/PureScript/CodeGen/Cpp/Types.hsnew file+125
@@ -0,0 +1,125 @@
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+
23+import Language.PureScript.CodeGen.Cpp.Common
24+import Language.PureScript.Names
25+import qualified Language.PureScript.Constants as C
26+
27+-- import Debug.Trace
28+
29+data CppType = CppPrimitive String | CppAuto | CppAny [CppTypeQual]
30+ deriving (Show, Read, Eq)
31+
32+data CppTypeQual = CppConst | CppRef
33+ deriving (Show, Read, Eq)
34+
35+-- |
36+-- Value C++11 qualifiers
37+--
38+data CppValueQual
39+ -- |
40+ -- C++ static qualifier
41+ --
42+ = CppStatic
43+ -- |
44+ -- Inline function
45+ --
46+ | CppInline
47+ -- |
48+ -- C++11+ constant expression "constexpr"
49+ --
50+ | CppConstExpr
51+ -- |
52+ -- Extern value
53+ --
54+ | CppExtern
55+ -- |
56+ -- Function or lambda is involved in recursion
57+ --
58+ | CppRecursive
59+ -- |
60+ -- Function or lambda is involved in recursion
61+ --
62+ | CppTopLevel
63+ deriving (Show, Read, Eq)
64+
65+-- |
66+-- C++ lambda capture list
67+--
68+data CppCaptureType = CppCaptureAll
69+ deriving (Show, Read, Eq)
70+
71+runType :: CppType -> String
72+runType (CppPrimitive t) = t
73+runType CppAuto = "auto"
74+runType (CppAny qs)
75+ | CppConst `elem` qs = "const " ++ (runType . CppAny $ delete CppConst qs)
76+ | CppRef `elem` qs = runType (CppAny $ delete CppRef qs) ++ "&"
77+ | otherwise = "any"
78+
79+runValueQual :: CppValueQual -> String
80+runValueQual CppStatic = "static"
81+runValueQual CppInline = "inline"
82+runValueQual CppConstExpr = "constexpr"
83+runValueQual CppExtern = "extern"
84+runValueQual CppRecursive = ""
85+runValueQual CppTopLevel = ""
86+
87+runCaptureType :: CppCaptureType -> String
88+runCaptureType CppCaptureAll = "="
89+
90+-- TODO: move or remove this
91+--
92+qualifiedToStr :: ModuleName -> (a -> Ident) -> Qualified a -> String
93+qualifiedToStr _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = runIdent $ f a
94+qualifiedToStr m f (Qualified (Just m') a) | m /= m' = moduleNameToCpp m' ++ "::" ++ identToCpp (f a)
95+qualifiedToStr _ f (Qualified _ a) = identToCpp (f a)
96+
97+boolType :: CppType
98+boolType = CppPrimitive "bool"
99+
100+intType :: CppType
101+intType = CppPrimitive "long"
102+
103+doubleType :: CppType
104+doubleType = CppPrimitive "double"
105+
106+stringType :: CppType
107+stringType = CppPrimitive "string"
108+
109+charType :: CppType
110+charType = CppPrimitive "char"
111+
112+mapType :: CppType
113+mapType = CppPrimitive "any::map"
114+
115+dataType :: CppType
116+dataType = CppPrimitive "any::data"
117+
118+arrayType :: CppType
119+arrayType = CppPrimitive "any::array"
120+
121+thunkMarkerType :: CppType
122+thunkMarkerType = CppPrimitive "any::as_thunk"
123+
124+ctorKey :: String
125+ctorKey = "constructor"
src/Language/PureScript/Pretty/Cpp.hsnew file+540
@@ -0,0 +1,540 @@
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.Bits
26+import Data.Char
27+import Data.List
28+import Data.Maybe (catMaybes, fromMaybe)
29+
30+#if __GLASGOW_HASKELL__ < 710
31+import Control.Applicative
32+#endif
33+import Control.Arrow ((<+>))
34+import Control.Monad.State
35+import Control.PatternArrows
36+import qualified Control.Arrow as A
37+
38+import Language.PureScript.CodeGen.Cpp.AST
39+import Language.PureScript.CodeGen.Cpp.Types
40+import Language.PureScript.Comments
41+-- import Language.PureScript.Pretty.Common
42+import qualified Language.PureScript.Constants as C
43+import Numeric
44+-- import Debug.Trace
45+
46+---------------------------------------------------------------------------------------------------
47+-- TODO: Go back to using Pretty.Common? (will require some work)
48+--
49+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Read, Eq, Ord)
50+-- |
51+-- Pretty print with a new indentation level
52+--
53+withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
54+withIndent action = do
55+ modify $ \st -> st { indent = indent st + blockIndent }
56+ result <- action
57+ modify $ \st -> st { indent = indent st - blockIndent }
58+ return result
59+
60+-- |
61+-- Get the current indentation level
62+--
63+currentIndent :: StateT PrinterState Maybe String
64+currentIndent = do
65+ current <- get
66+ return $ replicate (indent current) ' '
67+
68+blockIndent :: Int
69+blockIndent = 2
70+
71+-- |
72+-- Wrap a string in parentheses
73+--
74+parens :: String -> String
75+parens s = '(':s ++ ")"
76+---------------------------------------------------------------------------------------------------
77+
78+literals :: Pattern PrinterState Cpp String
79+literals = mkPattern' match
80+ where
81+ match :: Cpp -> StateT PrinterState Maybe String
82+ match CppNoOp = return []
83+ match CppEndOfHeader = return []
84+ match (CppNumericLiteral (Left n)) = return $ show n
85+ match (CppNumericLiteral n) = return $ either show show n
86+ match (CppStringLiteral s) | all isAscii s = return $ string s
87+ match (CppStringLiteral s) = return $ "u8" ++ string s
88+ match (CppCharLiteral c) = return $ show c
89+ match (CppBooleanLiteral True) = return "true"
90+ match (CppBooleanLiteral False) = return "false"
91+ match (CppArrayLiteral [x@CppArrayLiteral {}]) = -- Works around what appears to be a recent clang bug
92+ fmap concat $ sequence
93+ [ return $ runType arrayType
94+ , return "{ { "
95+ , prettyPrintCpp' x
96+ , return " } }"
97+ ]
98+ match (CppArrayLiteral xs) = fmap concat $ sequence
99+ [ return $ runType arrayType
100+ , return "{ "
101+ , fmap (intercalate ", ") $ forM xs prettyPrintCpp'
102+ , return " }"
103+ ]
104+ match (CppDataLiteral xs) = fmap concat $ sequence
105+ [ return $ runType dataType
106+ , return "{ "
107+ , fmap (intercalate ", ") $ forM xs prettyPrintCpp'
108+ , return " }"
109+ ]
110+ match (CppEnum name ty es) = fmap concat $ sequence
111+ [ return "enum"
112+ , return $ maybe "" (" " ++) name
113+ , return $ maybe "" ((" : " ++) . runType) ty
114+ , return " { "
115+ , return $ intercalate ", " es
116+ , return " }"
117+ ]
118+ match (CppObjectLiteral ps) = fmap concat $ sequence
119+ [ return $ runType mapType ++ "{\n"
120+ , withIndent $ do
121+ cpps <- forM ps $ \(key, value) -> do
122+ value' <- prettyPrintCpp' value
123+ key' <- prettyPrintCpp' (CppStringLiteral key)
124+ return $ "{ " ++ key' ++ ", " ++ value' ++ " }"
125+ indentString <- currentIndent
126+ return $ intercalate ", \n" $ map (indentString ++) cpps
127+ , return "\n"
128+ , currentIndent
129+ , return "}"
130+ ]
131+ match (CppFunction name args rty qs ret) =
132+ fmap concat $ sequence
133+ [ return . concatMap (++ " ") . filter (not . null) $ runValueQual <$> qs
134+ , return "auto "
135+ , return name
136+ , return $ parens (intercalate ", " $ argstr <$> args)
137+ , return (maybe "" ((" -> " ++) . runType) rty)
138+ , if ret /= CppNoOp
139+ then do
140+ cpps <- prettyPrintCpp' ret
141+ return $ ' ' : cpps
142+ else return ""
143+ ]
144+ match (CppBlock sts) = concat <$> sequence
145+ [ return "{\n"
146+ , withIndent $ prettyStatements sts
147+ , return $ if null sts then "" else "\n"
148+ , currentIndent
149+ , return "}"
150+ ]
151+ match (CppNamespace _ []) = return []
152+ match (CppNamespace [] sts) = fmap concat $ sequence $
153+ [ return "\n"
154+ , prettyStatements sts
155+ , return "#"
156+ ]
157+ match (CppNamespace (':':':':name) sts) = fmap concat $ sequence $
158+ [ return "\n"
159+ , currentIndent
160+ , return $ "namespace " ++ (dotsTo '_' name) ++ " {\n"
161+ , withIndent $ prettyStatements sts
162+ , return "\n"
163+ , currentIndent
164+ , return "}#"
165+ ]
166+ match (CppNamespace name sts) = fmap concat $ sequence $
167+ [ return "\n"
168+ , currentIndent
169+ , return $ "namespace " ++ (dotsTo '_' name) ++ " {\n"
170+ , withIndent $ prettyStatements sts'
171+ , return "\n"
172+ , currentIndent
173+ , return "}#"
174+ ]
175+ ++ let (cpp', cpps') = fromNested nested' in
176+ map match cpp'
177+ ++ if null cpps' then [] else [match (CppNamespace name (filter isUseNamespace sts ++ cpps'))]
178+ where
179+ (sts', nested') = break isNestedNamespace sts
180+ fromNested :: [Cpp] -> ([Cpp], [Cpp])
181+ fromNested [] = ([],[])
182+ fromNested cpps@((CppNamespace nm _):_) = ([foldl1 combineNamespaces namespaces], others)
183+ where
184+ (namespaces, others) = span inSameNamespace cpps
185+ inSameNamespace :: Cpp -> Bool
186+ inSameNamespace (CppNamespace nm' _) | nm' == nm = True
187+ inSameNamespace _ = False
188+ fromNested _ = error "Not a nested namespace"
189+ combineNamespaces :: Cpp -> Cpp -> Cpp
190+ combineNamespaces (CppNamespace nm ss) (CppNamespace nm' ss')
191+ | nm == nm' = CppNamespace nm (ss ++ filter (not . isUseNamespace) ss')
192+ combineNamespaces _ _ = error "Cannot fold cpps"
193+ isUseNamespace :: Cpp -> Bool
194+ isUseNamespace (CppUseNamespace{}) = True
195+ isUseNamespace _ = False
196+ match (CppStruct (name) mems) = fmap concat $ sequence $
197+ [ return "\n"
198+ , currentIndent
199+ , return $ "struct " ++ name ++ " {\n"
200+ , withIndent $ prettyStatements mems
201+ , return "\n"
202+ , currentIndent
203+ , return "}"
204+ ]
205+ match (CppInclude path name) =
206+ let fullpath
207+ | null path = last . words . dotsTo ' ' $ name
208+ | otherwise = (dotsTo '/' path) ++ '/' : (last . words . dotsTo ' ' $ name) in
209+ fmap concat $ sequence
210+ [ return $ "#include \"" ++ fullpath ++ ".hh\""
211+ ]
212+ match (CppUseNamespace name) = fmap concat $ sequence
213+ [ return $ "using namespace " ++ (dotsTo '_' name)
214+ ]
215+ match (CppTypeAlias (newName, newTyps) typ spec) =
216+ let typ' = runType typ
217+ (tmps, name') = if null newTyps
218+ then ([], typ')
219+ else ([return (templDecl newTyps), return "\n", currentIndent], typ')
220+ in fmap concat $ sequence $
221+ tmps ++
222+ [ return $ "using "
223+ , return newName
224+ , return " = "
225+ , return $ if null spec then name' else spec ++ angles name'
226+ ]
227+ match (CppCast typ val) = return $
228+ case val of
229+ CppNumericLiteral {} -> vstr
230+ CppStringLiteral {} -> vstr
231+ CppBooleanLiteral {} -> vstr
232+ _ -> "cast" ++ angles (runType typ) ++ parens val'
233+ where
234+ vstr = prettyPrintCpp1 val
235+ val' | '(' `elem` vstr || '[' `elem` vstr = parens vstr
236+ | otherwise = vstr
237+
238+ match (CppVar ident) = return ident
239+ match (CppApp v [CppNoOp]) = return (prettyPrintCpp1 v)
240+ match (CppVariableIntroduction (ident, _) _ (Just value))
241+ | ident == C.__unused = fmap concat $ sequence
242+ [ prettyPrintCpp' value
243+ ]
244+ match (CppVariableIntroduction (ident, typ) qs value) =
245+ fmap concat $ sequence
246+ [ return . concatMap (++ " ") . filter (not . null) $ runValueQual <$> qs
247+ , return (maybe "any" runType typ ++ " ")
248+ , return ident
249+ , maybe (return "") (fmap (" = " ++) . prettyPrintCpp') value
250+ ]
251+ match (CppAssignment target value) = fmap concat $ sequence
252+ [ prettyPrintCpp' target
253+ , return " = "
254+ , prettyPrintCpp' value
255+ ]
256+ match (CppWhile cond sts) = fmap concat $ sequence
257+ [ return "while ("
258+ , prettyPrintCpp' cond
259+ , return ") "
260+ , prettyPrintCpp' sts'
261+ ]
262+ where
263+ sts' | CppBlock cpps'@(_:_) <- sts,
264+ last cpps' == CppContinue = CppBlock (init cpps')
265+ | otherwise = sts
266+ match (CppIfElse cond thens elses) = fmap concat $ sequence
267+ [ return "if ("
268+ , prettyPrintCpp' cond
269+ , return ") "
270+ , prettyPrintCpp' thens
271+ , maybe (return "") (fmap (" else " ++) . prettyPrintCpp') elses
272+ ]
273+ match (CppSwitch cond cases@((case1,_):_:_)) = fmap concat $ sequence
274+ [ return "switch "
275+ , return . parens $ prettyPrintCpp1 (cast case1 cond)
276+ , return " {\n"
277+ , withIndent $ do
278+ cpps <- forM cases $ \(c, s) -> do
279+ c' <- prettyPrintCpp' c
280+ s' <- prettyPrintCpp' s
281+ return $ "case " ++ c' ++ ": " ++ s' ++ ";"
282+ indentString <- currentIndent
283+ return $ intercalate "\n" $ map (indentString ++) cpps
284+ , return "\n"
285+ , currentIndent
286+ , return "}"
287+ ]
288+ where
289+ cast :: Cpp -> Cpp -> Cpp
290+ cast CppNumericLiteral{} cpp' = CppCast intType cpp'
291+ cast CppBooleanLiteral{} cpp' = CppCast boolType cpp'
292+ cast CppCharLiteral{} cpp' = CppCast charType cpp'
293+ cast _ cpp' = cpp'
294+ match (CppReturn (CppBlock (cpp:cpps))) = fmap concat $ sequence
295+ [ do s <- prettyPrintCpp' cpp
296+ return $ dropWhile isSpace s
297+ , return $ if null cpps then "" else "\n"
298+ , prettyStatements cpps
299+ ]
300+ match (CppReturn value@(CppStringLiteral _)) = fmap concat $ sequence
301+ [ return "return "
302+ , return . runType $ CppAny []
303+ , return "("
304+ , prettyPrintCpp' value
305+ , return ")"
306+ ]
307+ match (CppReturn value) = fmap concat $ sequence
308+ [ return "return "
309+ , prettyPrintCpp' value
310+ ]
311+ match (CppThrow value) = fmap concat $ sequence
312+ [ return "throw "
313+ , prettyPrintCpp' value
314+ ]
315+ match CppContinue = return "continue"
316+ match (CppComment [] cpp) = match cpp
317+ match (CppComment com cpp) = fmap concat $ sequence $
318+ [ return "\n"
319+ , currentIndent
320+ , return "/**\n"
321+ ] ++
322+ map asLine (concatMap commentLines com) ++
323+ [ currentIndent
324+ , return " */\n"
325+ , currentIndent
326+ , prettyPrintCpp' cpp
327+ ]
328+ where
329+ commentLines :: Comment -> [String]
330+ commentLines (LineComment s) = [s]
331+ commentLines (BlockComment s) = lines s
332+
333+ asLine :: String -> StateT PrinterState Maybe String
334+ asLine s = do
335+ i <- currentIndent
336+ return $ i ++ " * " ++ removeComments s ++ "\n"
337+
338+ removeComments :: String -> String
339+ removeComments ('*' : '/' : s) = removeComments s
340+ removeComments (c : s) = c : removeComments s
341+
342+ removeComments [] = []
343+ match (CppRaw cpp) = return cpp
344+ match _ = mzero
345+
346+string :: String -> String
347+string s = '"' : concatMap encodeChar (decodeSurrogates s) ++ "\""
348+ where
349+ decodeSurrogates :: String -> String
350+ decodeSurrogates [c] = [c]
351+ decodeSurrogates s' = catMaybes $ zipWith decodePair s' (tail s' ++ ['\0'])
352+ where
353+ decodePair :: Char -> Char -> Maybe Char
354+ decodePair a b
355+ | fromEnum a >= 0xD800 && fromEnum a <= 0xDFFF &&
356+ fromEnum b >= 0xD800 && fromEnum b <= 0xDFFF
357+ = Just . chr $ 0x10000 + shiftL (fromEnum a .&. 0x03FF) 10 + (fromEnum b .&. 0x03FF)
358+ decodePair a _
359+ | fromEnum a >= 0xD800 && fromEnum a <= 0xDFFF = Nothing
360+ decodePair a _ = Just a
361+ encodeChar :: Char -> String
362+ encodeChar '\b' = "\\b"
363+ encodeChar '\t' = "\\t"
364+ encodeChar '\n' = "\\n"
365+ encodeChar '\v' = "\\v"
366+ encodeChar '\f' = "\\f"
367+ encodeChar '\r' = "\\r"
368+ encodeChar '"' = "\\\""
369+ encodeChar '\\' = "\\\\"
370+ encodeChar c | fromEnum c > 0xFFFF = "\\U" ++ leading ++ hex
371+ where
372+ hex = showHex (fromEnum c) ""
373+ leading = replicate (8 - length hex) '0'
374+ encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""
375+ encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""
376+ encodeChar c | fromEnum c < 0x10 = "\\x0" ++ showHex (fromEnum c) ""
377+ encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""
378+ encodeChar c = [c]
379+
380+accessor :: Pattern PrinterState Cpp (String, Cpp)
381+accessor = mkPattern match
382+ where
383+ match (CppAccessor prop val) = Just (prettyPrintCpp1 prop, val)
384+ match _ = Nothing
385+
386+indexer :: Pattern PrinterState Cpp (String, Cpp)
387+indexer = mkPattern' match
388+ where
389+ match (CppIndexer (CppNumericLiteral (Left 0)) val) = return ("0UL", val)
390+ match (CppIndexer (CppNumericLiteral (Left index)) val) = return (show index, val)
391+ match (CppIndexer index val) = do
392+ index' <- prettyPrintCpp' index
393+ return (index', val)
394+ match _ = mzero
395+
396+lam :: Pattern PrinterState Cpp ((String, [(String, Maybe CppType)], Maybe CppType), Cpp)
397+lam = mkPattern match
398+ where
399+ match (CppLambda caps args rty ret) =
400+ Just ((concatMap runCaptureType caps, args, rty), ret)
401+ match _ = Nothing
402+
403+app :: Pattern PrinterState Cpp (String, Cpp)
404+app = mkPattern' match
405+ where
406+ match (CppApp _ [CppNoOp]) = mzero
407+ match (CppApp val args) = do
408+ cpps <- mapM prettyPrintCpp' args
409+ return (intercalate ", " cpps, val)
410+ match _ = mzero
411+
412+unary' :: CppUnaryOp -> (Cpp -> String) -> Operator PrinterState Cpp String
413+unary' op mkStr = Wrap match (++)
414+ where
415+ match :: Pattern PrinterState Cpp (String, Cpp)
416+ match = mkPattern match'
417+ where
418+ match' (CppUnary op' val) | op' == op = Just (mkStr val, val)
419+ match' _ = Nothing
420+
421+unary :: CppUnaryOp -> String -> Operator PrinterState Cpp String
422+unary op str = unary' op (const str)
423+
424+negateOperator :: Operator PrinterState Cpp String
425+negateOperator = unary' CppNegate (\v -> if isNegate v then "- " else "-")
426+ where
427+ isNegate (CppUnary CppNegate _) = True
428+ isNegate _ = False
429+
430+binary :: BinaryOp -> String -> Operator PrinterState Cpp String
431+binary op str = AssocL match (\v1 v2 -> v1 ++ str ++ v2)
432+ where
433+ match :: Pattern PrinterState Cpp (Cpp, Cpp)
434+ match = mkPattern match'
435+ where
436+ match' (CppBinary op' v1 v2) | op' == op = Just (v1, v2)
437+ match' _ = Nothing
438+
439+prettyStatements :: [Cpp] -> StateT PrinterState Maybe String
440+prettyStatements sts = do
441+ cpps <- forM (filter (not . isNoOp) sts) prettyPrintCpp'
442+ indentString <- currentIndent
443+ return $ intercalate "\n" $ map (addsemi . (indentString ++)) cpps
444+ where
445+ addsemi :: String -> String
446+ addsemi [] = []
447+ addsemi s | all isSpace s = []
448+ addsemi s@('#':_) = s
449+ addsemi s | last s == '#' = init s
450+ addsemi s = s ++ ";"
451+
452+-- |
453+-- Generate a pretty-printed string representing a C++11 expression
454+--
455+prettyPrintCpp1 :: Cpp -> String
456+prettyPrintCpp1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintCpp'
457+
458+-- |
459+-- Generate a pretty-printed string representing a collection of C++11 expressions at the same indentation level
460+--
461+prettyPrintCpp :: [Cpp] -> String
462+prettyPrintCpp = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements
463+
464+-- |
465+-- Generate an indented, pretty-printed string representing a C++11 expression
466+--
467+prettyPrintCpp' :: Cpp -> StateT PrinterState Maybe String
468+prettyPrintCpp' = A.runKleisli $ runPattern matchValue
469+ where
470+ matchValue :: Pattern PrinterState Cpp String
471+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
472+ operators :: OperatorTable PrinterState Cpp String
473+ operators =
474+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "::" ++ prop ]
475+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
476+ , [ Wrap app $ \args val -> val ++ parens args ]
477+ , [ unary CppNew "new " ]
478+ , [ Wrap lam $ \(caps, args, rty) ret -> '[' : caps ++ "]"
479+ ++ let args' = argstr <$> args in
480+ parens (intercalate ", " args')
481+ ++ maybe "" ((" -> " ++) . runType) rty
482+ ++ " "
483+ ++ ret ]
484+ , [ unary CppNot "!"
485+ , unary CppBitwiseNot "~"
486+ , unary CppPositive "+"
487+ , negateOperator ]
488+ , [ binary Multiply " * "
489+ , binary Divide " / "
490+ , binary Modulus " % "
491+ , binary Dot "." ]
492+ , [ binary Add " + "
493+ , binary Subtract " - " ]
494+ , [ binary ShiftLeft " << "
495+ , binary ShiftRight " >> " ]
496+ , [ binary LessThan " < "
497+ , binary LessThanOrEqual " <= "
498+ , binary GreaterThan " > "
499+ , binary GreaterThanOrEqual " >= "
500+ , binary Equal " == "
501+ , binary NotEqual " != " ]
502+ , [ binary BitwiseAnd " & " ]
503+ , [ binary BitwiseXor " ^ " ]
504+ , [ binary BitwiseOr " | " ]
505+ , [ binary And " && " ]
506+ , [ binary Or " || " ]
507+ ]
508+
509+dotsTo :: Char -> String -> String
510+dotsTo chr' = map (\c -> if c == '.' then chr' else c)
511+
512+argstr :: (String, Maybe CppType) -> String
513+argstr (name, Nothing) = argStr name CppAuto
514+argstr (name, Just typ) | name == C.__unused = argStr [] typ
515+argstr (name, Just typ) = argStr name typ
516+
517+argStr :: String -> CppType -> String
518+argStr name typ = runType typ ++ if null name then [] else " " ++ name
519+
520+templDecl :: [(String, Int)] -> String
521+templDecl ps = "template " ++ angles (intercalate ", " (go <$> ps))
522+ where
523+ go :: (String, Int) -> String
524+ go (name, 0) = "typename " ++ name
525+ go (name, n) = "typename" ++ parens (intercalate "," $ replicate n "typename") ++ ' ' : name
526+
527+isNestedNamespace :: Cpp -> Bool
528+isNestedNamespace (CppNamespace (':':':':_) _) = True
529+isNestedNamespace _ = False
530+
531+angles :: String -> String
532+angles s = '<' : s ++ ">"
533+
534+linebreak :: [Cpp]
535+linebreak = [CppRaw ""]
536+
537+isNoOp :: Cpp -> Bool
538+isNoOp CppNoOp = True
539+isNoOp (CppComment [] CppNoOp) = True
540+isNoOp _ = False