@@ -15,7 +15,6 @@ import Control.Arrow ((<+>))
1515import Control.Monad (forM, mzero)
1616import Control.Monad.State (StateT, evalStateT)
1717import Control.PatternArrows
18−import Data.Char (isAscii)
1918import Data.List (filter, (\\))
2019import qualified Control.Arrow as A
2120
@@ -49,26 +48,23 @@ literals = mkPattern' match'
4948 match (BooleanLiteral _ True) = return $ emit "true"
5049 match (BooleanLiteral _ False) = return $ emit "false"
5150 match (ArrayLiteral _ xs) = mconcat <$> sequence
52− [ return . emit $ arrayType <> "{ "
51+ [ return . emit $ arrayType <> "{"
5352 , intercalate (emit ", ") <$> forM xs prettyPrintIL'
54− , return $ emit " }"
53+ , return $ emit "}"
5554 ]
5655 -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
5756 match (ObjectLiteral _ ps) = mconcat <$> sequence
58− [ return . emit $ dictType <> "{\n"
57+ [ return . emit $ dictType <> "{"
5958 , withIndent $ do
6059 ils <- forM ps $ \(key, value) -> do
6160 value' <- prettyPrintIL' value
62− return $ emit "{ " <> objectPropertyToString key <> value' <> emit " }"
63− indentString <- currentIndent
64− return $ intercalate (emit ",\n") $ map (indentString <>) ils
65− , return $ emit "\n"
66− , currentIndent
61+ return $ objectPropertyToString key <> value'
62+ return $ intercalate (emit " ") $ map (<> emit ",") ils
6763 , return $ emit "}"
6864 ]
6965 where
7066 objectPropertyToString :: (Emit gen) => PSString -> gen
71− objectPropertyToString s = emit $ stringLiteral s <> ", "
67+ objectPropertyToString s = emit $ stringLiteral s <> ": "
7268 match (Block _ sts) = mconcat <$> sequence
7369 [ return $ emit "{\n"
7470 , withIndent $ prettyStatements sts
@@ -78,7 +74,7 @@ literals = mkPattern' match'
7874 ]
7975 match (Var _ ident) = return $ emit ident
8076 match (VariableIntroduction _ ident value) = mconcat <$> sequence
81− [ return $ emit $ "boxed " <> ident
77+ [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
8278 , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value
8379 ]
8480 match (Assignment _ target value) = mconcat <$> sequence
@@ -87,13 +83,20 @@ literals = mkPattern' match'
8783 , prettyPrintIL' value
8884 ]
8985 match (App _ val []) = mconcat <$> sequence
90− [ prettyPrintIL' val
91− , return $ emit "()"
86+ [ return $ emit "EffApply("
87+ , prettyPrintIL' val
88+ , return $ emit ")"
89+ ]
90+ match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
91+ [ return $ emit arrayLengthFn
92+ , return $ emit "("
93+ , prettyPrintIL' arg
94+ , return $ emit ")"
9295 ]
93− match (App ss (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])
96+ match (App ss (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod), x, y])
9497 | fnMod == dictMod
9598 , dictMod == C.dataEq || dictMod == C.dataSemiring || dictMod == C.dataRing ||
96− dictMod == C.dataEuclideanRing || dictMod == C.dataHeytingAlgebra
99+ dictMod == C.dataEuclideanRing || dictMod == C.dataHeytingAlgebra || dictMod == C.dataOrd
97100 , Just op <- renderOp fn
98101 , Just t <- unboxType dict
99102 = mconcat <$> sequence
@@ -101,130 +104,151 @@ literals = mkPattern' match'
101104 , return $ emit op
102105 , return $ emit $ unbox' t y
103106 ]
104− match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
107+ match (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod), n])
105108 | fnMod == dictMod
106109 , dictMod == C.dataRing
107110 , fn == C.negate
108111 , Just t <- unboxType dict
109112 = mconcat <$> sequence
110− [ return $ emit "-"
113+ [ return $ emit "-("
111114 , return $ emit $ unbox' t n
115+ , return $ emit ")"
112116 ]
113− match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
117+ match (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod), n])
114118 | fnMod == dictMod
115119 , dictMod == C.dataHeytingAlgebra
116120 , fn == properToIL C.not
117121 , Just t <- unboxType dict
118122 = mconcat <$> sequence
119− [ return $ emit "!"
123+ [ return $ emit "!("
120124 , return $ emit $ unbox' t n
125+ , return $ emit ")"
121126 ]
122127 match (App _ val args) = mconcat <$> sequence
123− [ prettyPrintIL' val
124− , return $ emit "("
128+ [ return $ emit "Apply("
129+ , prettyPrintIL' val
130+ , return $ emit ", "
125131 , intercalate (emit ", ") <$> forM args prettyPrintIL'
126132 , return $ emit ")"
127133 ]
128134 match (Function _ (Just name) [] (Block _ [Return _ ret]))
129− | isLiteral ret = mconcat <$> sequence
130− [ return $ emit "auto "
131− , return $ emit name
132− , return $ emit "() -> const boxed& "
135+ | isComplexLiteral ret = mconcat <$> sequence
136+ [ return $ emit "\n"
137+ , return . emit $ varDecl <> " " <> initName name <> " Once\n"
138+ , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing
139+ , return $ emit "\n\n"
140+ , return $ emit "func "
141+ , return . emit $ withPrefix name
142+ , return . emit $ "() " <> anyType <> " "
133143 , return $ emit "{\n"
134144 , withIndent $ do
135− indentString <- currentIndent
136− return $ indentString <> emit staticValueBegin
145+ indentString <- currentIndent
146+ return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>
147+ indentString <> indentString <> (emit $ valueName name <> " = ")
137148 , withIndent $ do
138149 case ret of
139150 Function _ Nothing args body -> mconcat <$> sequence
140− [ return $ emit "[]("
141− , return $ emit $ intercalate ", " (renderArg <$> args)
142− , return $ emit ") -> boxed "
151+ [ return $ emit "func("
152+ , return . emit $ intercalate ", " (renderArg anyType <$> args)
153+ , return . emit $ ") " <> anyType <> " "
143154 , prettyPrintIL' body
144155 ]
145156 _ -> do
146157 prettyPrintIL' ret
147− , return $ emit ";\n"
158+ , return $ emit "\n"
148159 , withIndent $ do
149− indentString <- currentIndent
150− return $ indentString <> emit staticValueEnd
151− , return $ emit "\n}"
160+ indentString <- currentIndent
161+ return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")
162+ , return $ emit "}\n\n"
152163 ]
153164 match (Function _ (Just name) [] ret) = mconcat <$> sequence
154− [ return $ emit "auto "
155− , return $ emit name
156− , return $ emit "() -> boxed "
165+ [ return $ emit "func "
166+ , return . emit $ withPrefix name
167+ , return . emit $ "() " <> anyType <> " "
157168 , prettyPrintIL' ret
158169 ]
159− match (Function _ name args ret) = mconcat <$> sequence
160− [ return $ emit captures
161− , return $ emit "("
162− , return $ emit $ intercalate ", " (render <$> args)
163− , return $ emit ") -> boxed "
170+ match (Function _ _ args ret) = mconcat <$> sequence
171+ [ return $ emit "func("
172+ , return . emit $ intercalate ", " (renderArg anyType <$> args)
173+ , return . emit $ ") " <> anyType <> " "
164174 , prettyPrintIL' ret
165175 ]
166− where
167− (captures, render)
168− | name == Just tcoLoop = ("[&]", renderArgByVal)
169− | otherwise = ("[=]", renderArg)
170− match (Indexer _ prop@(Var _ name) val) = mconcat <$> sequence
176+ match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence
177+ [ prettyPrintIL' (Var Nothing $ withPrefix name)
178+ , return $ emit "()"
179+ ]
180+ match (Indexer _ (Var _ name) val) = mconcat <$> sequence
171181 [ prettyPrintIL' val
172− , return $ emit "::"
173− , prettyPrintIL' prop
182+ , return $ emit "."
183+ , prettyPrintIL' (Var Nothing $ withPrefix name)
174184 , return $ emit "()"
175185 ]
176186 match (Indexer _ prop val) = mconcat <$> sequence
177− [ prettyPrintIL' val
178− , return $ emit "["
187+ [ return $ emit "Get("
188+ , prettyPrintIL' val
189+ , return $ emit ", "
179190 , prettyPrintIL' prop
180− , return $ emit "]"
191+ , return $ emit ")"
181192 ]
182193 match (InstanceOf _ val ty) = mconcat <$> sequence
183− [ return . emit $ unbox' dictType val
184− , return $ emit ".contains("
194+ [ return $ emit "Contains("
195+ , prettyPrintIL' val
196+ , return $ emit ", "
185197 , prettyPrintIL' ty
186198 , return $ emit ")"
187199 ]
188200 match (While _ cond sts) = mconcat <$> sequence
189− [ return $ emit "while ("
201+ [ return $ emit "for "
190202 , prettyPrintIL' cond
191− , return $ emit ") "
203+ , return $ emit " "
192204 , prettyPrintIL' sts
193205 ]
194206 match (For _ ident start end sts) = mconcat <$> sequence
195− [ return $ emit $ "for (boxed " <> ident <> " = "
207+ [ return $ emit $ "for var " <> ident <> " = "
196208 , prettyPrintIL' start
197209 , return $ emit $ "; " <> ident <> " < "
198210 , prettyPrintIL' end
199− , return $ emit $ "; " <> ident <> "++) "
211+ , return $ emit $ "; " <> ident <> "++ "
200212 , prettyPrintIL' sts
201213 ]
202214 match (ForIn _ ident obj sts) = mconcat <$> sequence
203− [ return $ emit $ "for (boxed " <> ident <> " in "
215+ [ return $ emit $ "for var " <> ident <> " in "
204216 , prettyPrintIL' obj
205− , return $ emit ") "
217+ , return $ emit " "
206218 , prettyPrintIL' sts
207219 ]
220+ match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses)
221+ | (App ss (Indexer _ (Var _ _) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod), x, y]) <- cond
222+ , fnMod == dictMod
223+ , dictMod == C.dataEq || dictMod == C.dataOrd
224+ , Just _ <- unboxTypeInt dict
225+ = mconcat <$> sequence
226+ [ return $ emit "if "
227+ , prettyPrintIL' cond
228+ , return $ emit " "
229+ , prettyPrintIL' thens
230+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
231+ ]
208232 match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
209− [ return $ emit "if ("
233+ [ return $ emit "if "
210234 , return $ emit $ unbox' "bool" cond
211− , return $ emit ") "
235+ , return $ emit " "
212236 , prettyPrintIL' thens
213237 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
214238 ]
215239 match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
216− [ return $ emit "if (!("
240+ [ return $ emit "if !("
217241 , return $ emit $ unbox' "bool" cond
218− , return $ emit ")) "
242+ , return $ emit ") "
219243 , prettyPrintIL' thens
220244 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
221245 ]
222246 match (IfElse _ (Binary _ EqualTo x y@(NumericLiteral _ n)) thens elses) = mconcat <$> sequence
223− [ return $ emit "if ("
247+ [ return $ emit "if "
224248 , return $ emit $ unbox' t x
225249 , return $ emit $ " == "
226250 , prettyPrintIL' y
227− , return $ emit ") "
251+ , return $ emit " "
228252 , prettyPrintIL' thens
229253 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
230254 ]
@@ -232,18 +256,18 @@ literals = mkPattern' match'
232256 t | Left _ <- n = int
233257 | Right _ <- n = float
234258 match (IfElse _ (Binary _ EqualTo a b@StringLiteral{}) thens elses) = mconcat <$> sequence
235− [ return $ emit "if ("
259+ [ return $ emit "if "
236260 , return $ emit $ unbox' string a
237261 , return $ emit $ " == "
238262 , prettyPrintIL' b
239− , return $ emit ") "
263+ , return $ emit " "
240264 , prettyPrintIL' thens
241265 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
242266 ]
243267 match (IfElse _ cond thens elses) = mconcat <$> sequence
244− [ return $ emit "if ("
268+ [ return $ emit "if "
245269 , prettyPrintIL' cond
246− , return $ emit ") "
270+ , return $ emit " "
247271 , prettyPrintIL' thens
248272 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
249273 ]
@@ -251,11 +275,12 @@ literals = mkPattern' match'
251275 [ return $ emit "return "
252276 , prettyPrintIL' value
253277 ]
254− match (ReturnNoResult _) = return $ emit "return undefined"
278+ match (ReturnNoResult _) = return . emit $ "return " <> undefinedName
255279 -- match (Throw _ _) = return mempty
256280 match (Throw _ value) = mconcat <$> sequence
257− [ return $ emit "THROW_("
281+ [ return $ emit "panic("
258282 , return $ emit "\"PatternMatchFailure: \""
283+ , return $ emit " + "
259284 , prettyPrintIL' value
260285 , return $ emit ")"
261286 ]
@@ -330,11 +355,17 @@ isLiteral ObjectLiteral{} = True
330355isLiteral ArrayLiteral{} = True
331356isLiteral _ = False
332357
358+isComplexLiteral :: AST -> Bool
359+-- isComplexLiteral Function{} = True
360+isComplexLiteral ObjectLiteral{} = True
361+isComplexLiteral ArrayLiteral{} = True
362+isComplexLiteral _ = False
363+
333364prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
334365prettyStatements sts = do
335366 ils <- forM sts prettyPrintIL'
336367 indentString <- currentIndent
337− return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) ils
368+ return $ intercalate (emit "\n") $ map (indentString <>) ils
338369
339370-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
340371prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])
@@ -383,15 +414,12 @@ prettyPrintIL1 :: AST -> Text
383414prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'
384415
385416stringLiteral :: PSString -> Text
386−stringLiteral pss | Just s <- decodeString pss =
387− (if T.all isAscii s
388− then ""
389− else ("u8")) <> stringLiteral' s
417+stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
390418 where
391419 stringLiteral' :: Text -> Text
392420 stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
393421 encodeChar :: Char -> Text
394− encodeChar '\0' = "\\0"
422+ encodeChar '\0' = "\\x00"
395423 encodeChar '\b' = "\\b"
396424 encodeChar '\t' = "\\t"
397425 encodeChar '\n' = "\\n"
@@ -407,13 +435,14 @@ unbox' :: Text -> AST -> Text
407435unbox' _ v@(NumericLiteral{}) = prettyPrintIL1 v
408436unbox' _ v@(BooleanLiteral{}) = prettyPrintIL1 v
409437unbox' _ v@(StringLiteral{}) = prettyPrintIL1 v
410−unbox' t v = unbox t <> "(" <> prettyPrintIL1 v <> ")"
438+unbox' t v = "(" <> prettyPrintIL1 v <> ")" <> unbox t -- unbox t <> "(" <> prettyPrintIL1 v <> ")"
411439
412440unboxType :: Text -> Maybe Text
413441unboxType t
414442 | t == C.eqInt ||
415443 t == C.semiringInt ||
416− t == C.ringInt
444+ t == C.ringInt ||
445+ t == C.ordInt
417446 = Just int
418447 | t == C.semiringNumber ||
419448 t == C.ringNumber ||
@@ -423,10 +452,23 @@ unboxType t
423452 = Just bool
424453 | otherwise = Nothing
425454
455+unboxTypeInt :: Text -> Maybe Text
456+unboxTypeInt t
457+ | t == C.eqInt ||
458+ t == C.semiringInt ||
459+ t == C.ringInt ||
460+ t == C.ordInt
461+ = Just int
462+ | otherwise = Nothing
463+
426464renderOp :: Text -> Maybe Text
427465renderOp op
428466 | op == C.eq = Just " == "
429467 | op == C.notEq = Just " != "
468+ | op == C.lessThan = Just " < "
469+ | op == C.lessThanOrEq = Just " <= "
470+ | op == C.greaterThan = Just " > "
471+ | op == C.greaterThanOrEq = Just " >= "
430472 | op == C.add = Just " + "
431473 | op == C.sub = Just " - "
432474 | op == C.mul = Just " * "
@@ -436,29 +478,22 @@ renderOp op
436478 | otherwise = Nothing
437479
438480interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
439−interfaceSource mn values foreigns =
440− let foreigns' = identToIL <$> foreigns
441− valueNames = fst <$> values
442− values' = filter ((`notElem` foreigns') . fst) values ++
443− zip (foreigns' \\ valueNames) (repeat True)
444− in
445− "// Generated by psil compiler\n\n" <>
446− "#ifndef " <> mn <> "_H\n" <>
447− "#define " <> mn <> "_H\n\n" <>
448− "#include \"purescript.h\"\n\n" <>
449− "namespace " <> mn <> " {\n\n" <>
450− "using namespace purescript;\n\n" <>
451− (T.concat $ (\(export, static) ->
452− let rty = if static then "const boxed&" else "boxed" in
453− "auto " <> export <> "() -> " <> rty <> ";\n") <$> values') <> "\n" <>
454− "} // end namespace " <> mn <> "\n\n" <>
455− "#endif // " <> mn <> "_H\n\n"
481+interfaceSource _ _ _ = ""
456482
457483implHeaderSource :: Text -> [Text] -> Text -> Text
458−implHeaderSource mn imports interfaceImport =
459− T.concat imports <> "\n"<>
460− interfaceImport <> "\n\n" <>
461− "namespace " <> mn <> " {\n\n"
484+implHeaderSource mn imports _ =
485+ "// Code generated by psgo. DO NOT EDIT.\n\n" <>
486+ "package " <> (if mn == "Main" then "main" else mn) <> "\n\n" <>
487+ "import . \"purescript\"\n" <>
488+ (if mn == "Main"
489+ then "import \"purescript_ffi\"\n"
490+ else "") <>
491+ T.concat imports <> "\n" <>
492+ "type IGNORE_UNUSED_IMPORTS = bool\n" <>
493+ "type _ = IGNORE_UNUSED_RUNTIME\n" <>
494+ (if mn == "Main"
495+ then "\nconst _ = purescript_ffi.Loader\n\n"
496+ else "\n")
462497
463498implFooterSource :: Text -> [Ident] -> Text
464499implFooterSource mn foreigns =
@@ -466,50 +501,41 @@ implFooterSource mn foreigns =
466501 (if null foreigns
467502 then ""
468503 else ("// Foreign values\n\n" <>
469− "DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR()\n\n" <>
470− (T.concat $ (\foreign' -> "auto " <>
471− identToIL foreign' <>
472− "() -> const boxed& { " <>
473− staticValueBegin <>
474− foreignDict <> "().at(" <>
475− (stringLiteral . mkString $ runIdent foreign') <> "); " <>
476− staticValueEnd <>
477− " };\n") <$> foreigns) <>
478− "\n")) <>
479− "} // end namespace " <> mn <>
480− "\n\n" <>
504+ "var " <> foreignDict <> " = " <> dictType <> "{}\n\n" <>
505+ (T.concat $ (\foreign' ->
506+ let name = identToIL foreign' in
507+ varDecl <> " " <> initName name <> " Once\n" <>
508+ varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>
509+ "func " <>
510+ withPrefix name <>
511+ "() Any { \n" <>
512+ " " <> initName name <> ".Do(func() {\n" <>
513+ " " <> valueName name <> " = " <>
514+ "SafeGet(" <> foreignDict <> ", " <>
515+ (stringLiteral $ mkString name) <> ")\n" <>
516+ " })\n" <>
517+ " return " <> valueName name <> "\n" <>
518+ "}\n\n") <$> foreigns))) <>
481519 if mn == "Main" then mainSource else "\n"
482520 where
483521 mainSource :: Text
484522 mainSource = "\
485− \int main(int argc, const char * argv[]) {\n\
486− \ Main::main()();\n\
487− \ return 0;\n\
523+ \func main() {\n\
524+ \ EffApply(PS__main())\n\
488525 \}\n\n\
489526 \"
490527
491528varDecl :: Text
492−varDecl = "const boxed"
493−
494−varRefDecl :: Text
495−varRefDecl = varDecl <> "&"
496−
497−renderArg' :: Text -> Text -> Text
498−renderArg' decl arg
499− | arg == unusedName = decl
500− | otherwise = decl <> " " <> arg
501−
502−renderArg :: Text -> Text
503−renderArg = renderArg' varRefDecl
529+varDecl = "var"
504530
505−renderArgByVal :: Text -> Text
506−renderArgByVal = renderArg' varDecl
531+renderArg :: Text -> Text -> Text
532+renderArg decl arg = arg <> " " <> decl
507533
508534foreignDict :: Text
509−foreignDict = "foreign"
535+foreignDict = "Foreign"
510536
511−staticValueBegin :: Text
512−staticValueBegin = "static const boxed _ = "
537+initName :: Text -> Text
538+initName s = "_" <> s <> "_init_"
513539
514−staticValueEnd :: Text
515−staticValueEnd = "return _;"
540+valueName :: Text -> Text
541+valueName s = "_" <> s <> "_value_"