e2c3e33 · rowtype-yoga/purescm

git.iko.soy/rowtype-yoga/purescm

on bytevector help sign in

Refactor ChezExpr to support pretty-printing (#119)

e2c3e33JordanMartinez4 years ago

src/PureScript/Backend/Chez/Convert.purs+89−40

compare with bytevector

unifiedsplit

@@ -14,16 +14,19 @@ import Data.Newtype (unwrap, wrap)

14import Data.Set as Set

15import Data.String as String

16import Data.String.CodeUnits as CodeUnits

17+import Data.String.Regex as R

18+import Data.String.Regex.Flags as R.Flags

19+import Data.String.Regex.Unsafe as R.Unsafe

17import Data.Tuple (Tuple(..), uncurry)

20import Data.Tuple (Tuple(..), uncurry)

18import Data.Tuple as Tuple

21import Data.Tuple as Tuple

19import Partial.Unsafe (unsafeCrashWith)

22import Partial.Unsafe (unsafeCrashWith)

20import PureScript.Backend.Chez.Constants (libChezSchemePrefix, moduleForeign, moduleLib, runtimePrefix, scmPrefixed)

23import PureScript.Backend.Chez.Constants (libChezSchemePrefix, moduleForeign, moduleLib, runtimePrefix, scmPrefixed)

21−import PureScript.Backend.Chez.Syntax (ChezDefinition(..), ChezExport(..), ChezExpr, ChezImport(..), ChezImportSet(..), ChezLibrary)

24+import PureScript.Backend.Chez.Syntax (ChezDefinition(..), ChezExport(..), ChezExpr, ChezImport(..), ChezImportSet(..), ChezLibrary, recordTypeAccessor, recordTypeCurriedConstructor, recordTypePredicate, recordTypeUncurriedConstructor)

22import PureScript.Backend.Chez.Syntax as S

25import PureScript.Backend.Chez.Syntax as S

23import PureScript.Backend.Optimizer.Convert (BackendModule, BackendBindingGroup)

26import PureScript.Backend.Optimizer.Convert (BackendModule, BackendBindingGroup)

24−import PureScript.Backend.Optimizer.CoreFn (Ident(..), Literal(..), ModuleName(..))

27+import PureScript.Backend.Optimizer.CoreFn (Ident(..), Literal(..), ModuleName(..), Qualified(..))

25import PureScript.Backend.Optimizer.Semantics (NeutralExpr)

28import PureScript.Backend.Optimizer.Semantics (NeutralExpr)

26−import PureScript.Backend.Optimizer.Syntax (BackendAccessor(..), BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorNum(..), BackendOperatorOrd(..), BackendSyntax(..), Pair(..))

29+import PureScript.Backend.Optimizer.Syntax (BackendAccessor(..), BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorNum(..), BackendOperatorOrd(..), BackendSyntax(..), Level(..), Pair(..))

27import Safe.Coerce (coerce)

30import Safe.Coerce (coerce)

29type CodegenEnv =

32type CodegenEnv =

@@ -43,7 +46,7 @@ codegenModule { name, bindings, imports, foreign: foreign_ } =

43 exports' :: Array ChezExport

46 exports' :: Array ChezExport

44 exports' = map ExportIdentifier

47 exports' = map ExportIdentifier

45 $ Array.sort

48 $ Array.sort

46− $ Array.concatMap S.definitionIdentifiers definitions

49+ $ Array.concatMap definitionIdentifiers definitions

47 <> map coerce (Array.fromFoldable foreign_)

50 <> map coerce (Array.fromFoldable foreign_)

49 pursImports :: Array ChezImport

52 pursImports :: Array ChezImport

@@ -83,6 +86,34 @@ codegenModule { name, bindings, imports, foreign: foreign_ } =

83 , body: { definitions, expressions: [] }

86 , body: { definitions, expressions: [] }

84 }

87 }

89+definitionIdentifiers :: ChezDefinition -> Array String

90+definitionIdentifiers = case _ of

91+ DefineValue i _ -> [ i ]

92+ DefineCurriedFunction i _ _ -> [ i ]

93+ DefineUncurriedFunction i _ _ -> [ i ]

94+ DefineRecordType i [ x ] ->

95+ [ recordTypeCurriedConstructor i

96+ , recordTypePredicate i

97+ , recordTypeAccessor i x

98+ ]

99+ DefineRecordType i fields ->

100+ [ recordTypeUncurriedConstructor i

101+ , recordTypePredicate i

102+ ] <> map (recordTypeAccessor i) fields

103+

104+flattenQualified :: ModuleName -> Qualified Ident -> String

105+flattenQualified _ (Qualified Nothing (Ident i)) = i

106+flattenQualified currentModule (Qualified (Just m) (Ident i))

107+ | currentModule == m = i

108+ | otherwise = coerce m <> "." <> i

109+

110+toChezIdent :: Maybe Ident -> Level -> String

111+toChezIdent i (Level l) = case i of

112+ Just (Ident i') -> case i' of

113+ "$__unused" -> "_"

114+ _ -> i' <> show l

115+ Nothing -> "_" <> show l

116+

86codegenTopLevelBindingGroup

117codegenTopLevelBindingGroup

87 :: CodegenEnv

118 :: CodegenEnv

88 -> BackendBindingGroup Ident NeutralExpr

119 -> BackendBindingGroup Ident NeutralExpr

@@ -102,13 +133,13 @@ codegenTopLevelBinding codegenEnv (Tuple (Ident i) n) =

102 Abs a e ->

133 Abs a e ->

103 [ DefineCurriedFunction

134 [ DefineCurriedFunction

104 i

135 i

105− (uncurry S.toChezIdent <$> a)

136+ (uncurry toChezIdent <$> a)

106 (codegenExpr codegenEnv e)

137 (codegenExpr codegenEnv e)

107 ]

138 ]

108 UncurriedAbs a e ->

139 UncurriedAbs a e ->

109 [ DefineUncurriedFunction

140 [ DefineUncurriedFunction

110 i

141 i

111− (uncurry S.toChezIdent <$> a)

142+ (uncurry toChezIdent <$> a)

112 (codegenExpr codegenEnv e)

143 (codegenExpr codegenEnv e)

113 ]

144 ]

114 CtorDef _ _ _ ss ->

145 CtorDef _ _ _ ss ->

@@ -126,7 +157,7 @@ codegenTopLevelBinding codegenEnv (Tuple (Ident i) n) =

126 | otherwise ->

157 | otherwise ->

127 [ DefineRecordType i ss

158 [ DefineRecordType i ss

128 , DefineCurriedFunction i xs

159 , DefineCurriedFunction i xs

129− $ S.chezUncurriedApplication

160+ $ S.runUncurriedFn

130 (S.Identifier $ S.recordTypeUncurriedConstructor i)

161 (S.Identifier $ S.recordTypeUncurriedConstructor i)

131 (map S.Identifier ss)

162 (map S.Identifier ss)

132 ]

163 ]

@@ -136,42 +167,45 @@ codegenTopLevelBinding codegenEnv (Tuple (Ident i) n) =

136codegenExpr :: CodegenEnv -> NeutralExpr -> ChezExpr

167codegenExpr :: CodegenEnv -> NeutralExpr -> ChezExpr

137codegenExpr codegenEnv@{ currentModule } s = case unwrap s of

168codegenExpr codegenEnv@{ currentModule } s = case unwrap s of

138 Var qi ->

169 Var qi ->

139− S.Identifier $ S.resolve currentModule qi

170+ S.Identifier $ flattenQualified currentModule qi

140 Local i l ->

171 Local i l ->

141− S.Identifier $ coerce $ S.toChezIdent i l

172+ S.Identifier $ coerce $ toChezIdent i l

142 Lit l ->

173 Lit l ->

143 codegenLiteral codegenEnv l

174 codegenLiteral codegenEnv l

144 App f p ->

175 App f p ->

145− S.chezCurriedApplication (codegenExpr codegenEnv f) (codegenExpr codegenEnv <$> p)

176+ S.runCurriedFn (codegenExpr codegenEnv f) (codegenExpr codegenEnv <$> p)

146 Abs a e -> do

177 Abs a e -> do

147− S.chezCurriedFunction (uncurry S.toChezIdent <$> a) (codegenExpr codegenEnv e)

178+ S.mkCurriedFn (uncurry toChezIdent <$> a) (codegenExpr codegenEnv e)

148 UncurriedApp f p ->

179 UncurriedApp f p ->

149− S.chezUncurriedApplication (codegenExpr codegenEnv f) (codegenExpr codegenEnv <$> p)

180+ S.runUncurriedFn (codegenExpr codegenEnv f) (codegenExpr codegenEnv <$> p)

150 UncurriedAbs a e ->

181 UncurriedAbs a e ->

151− S.chezUncurriedFunction (uncurry S.toChezIdent <$> a) (codegenExpr codegenEnv e)

182+ S.mkUncurriedFn (uncurry toChezIdent <$> a) (codegenExpr codegenEnv e)

152 UncurriedEffectApp f p ->

183 UncurriedEffectApp f p ->

153− S.chezThunk $ S.chezUncurriedApplication (codegenExpr codegenEnv f)

184+ S.thunk $ S.runUncurriedFn (codegenExpr codegenEnv f)

154 (codegenExpr codegenEnv <$> p)

185 (codegenExpr codegenEnv <$> p)

155 UncurriedEffectAbs a e ->

186 UncurriedEffectAbs a e ->

156− S.chezUncurriedFunction (uncurry S.toChezIdent <$> a)

187+ S.mkUncurriedFn (uncurry toChezIdent <$> a)

157 (codegenChain effectChainMode codegenEnv e)

188 (codegenChain effectChainMode codegenEnv e)

158

189

159 Accessor e (GetProp i) ->

190 Accessor e (GetProp i) ->

160− S.chezUncurriedApplication

191+ S.runUncurriedFn

161 (S.Identifier $ scmPrefixed "hashtable-ref")

192 (S.Identifier $ scmPrefixed "hashtable-ref")

193+ [ codegenExpr codegenEnv e

162− [ codegenExpr codegenEnv e, S.String $ Json.stringify $ Json.fromString i, S.Boolean false ]

194+ , S.StringExpr $ Json.stringify $ Json.fromString i

195+ , S.Bool false

196+ ]

163 Accessor e (GetIndex i) ->

197 Accessor e (GetIndex i) ->

164− S.chezUncurriedApplication

198+ S.runUncurriedFn

165 (S.Identifier $ scmPrefixed "vector-ref")

199 (S.Identifier $ scmPrefixed "vector-ref")

166 [ codegenExpr codegenEnv e, S.Integer $ wrap $ show i ]

200 [ codegenExpr codegenEnv e, S.Integer $ wrap $ show i ]

167 Accessor e (GetCtorField qi _ _ _ field _) ->

201 Accessor e (GetCtorField qi _ _ _ field _) ->

168− S.recordAccessor (codegenExpr codegenEnv e) (S.resolve currentModule qi) field

202+ S.recordAccessor (codegenExpr codegenEnv e) (flattenQualified currentModule qi) field

169 Update _ _ ->

203 Update _ _ ->

170 S.Identifier "object-update"

204 S.Identifier "object-update"

171

205

172 CtorSaturated qi _ _ _ xs ->

206 CtorSaturated qi _ _ _ xs ->

173− S.chezUncurriedApplication

207+ S.runUncurriedFn

174− (S.Identifier $ S.recordTypeUncurriedConstructor $ S.resolve currentModule qi)

208+ (S.Identifier $ S.recordTypeUncurriedConstructor $ flattenQualified currentModule qi)

175 (map (codegenExpr codegenEnv <<< Tuple.snd) xs)

209 (map (codegenExpr codegenEnv <<< Tuple.snd) xs)

176 CtorDef _ _ _ _ ->

210 CtorDef _ _ _ _ ->

177 unsafeCrashWith "codegenExpr:CtorDef - handled by codegenTopLevelBinding!"

211 unsafeCrashWith "codegenExpr:CtorDef - handled by codegenTopLevelBinding!"

@@ -182,9 +216,9 @@ codegenExpr codegenEnv@{ currentModule } s = case unwrap s of

182 codegenPureChain codegenEnv s

216 codegenPureChain codegenEnv s

183 Branch b o -> do

217 Branch b o -> do

184 let

218 let

185− goPair :: Pair NeutralExpr -> { c :: _, e :: _ }

219+ goPair :: Pair NeutralExpr -> Tuple ChezExpr ChezExpr

186− goPair (Pair c e) = { c: codegenExpr codegenEnv c, e: codegenExpr codegenEnv e }

220+ goPair (Pair c e) = Tuple (codegenExpr codegenEnv c) (codegenExpr codegenEnv e)

187− S.chezCond (goPair <$> b) (codegenExpr codegenEnv <$> o)

221+ S.Cond (goPair <$> b) (codegenExpr codegenEnv <$> o)

188

222

189 EffectBind _ _ _ _ ->

223 EffectBind _ _ _ _ ->

190 codegenEffectChain codegenEnv s

224 codegenEffectChain codegenEnv s

@@ -211,7 +245,7 @@ codegenExpr codegenEnv@{ currentModule } s = case unwrap s of

211 , S.List [ S.Identifier $ scmPrefixed "make-error" ]

245 , S.List [ S.Identifier $ scmPrefixed "make-error" ]

212 , S.List

246 , S.List

213 [ S.Identifier $ scmPrefixed "make-message-condition"

247 [ S.Identifier $ scmPrefixed "make-message-condition"

214− , S.String $ Json.stringify $ Json.fromString i

248+ , S.StringExpr $ Json.stringify $ Json.fromString i

215 ]

249 ]

216 ]

250 ]

217 ]

251 ]

@@ -220,12 +254,29 @@ codegenLiteral :: CodegenEnv -> Literal NeutralExpr -> ChezExpr

220codegenLiteral codegenEnv = case _ of

254codegenLiteral codegenEnv = case _ of

221 LitInt i -> S.Integer $ wrap $ show i

255 LitInt i -> S.Integer $ wrap $ show i

222 LitNumber n -> S.Float $ wrap $ show n

256 LitNumber n -> S.Float $ wrap $ show n

223− LitString s -> S.String $ S.jsonToChezString $ Json.stringify $ Json.fromString s

257+ LitString s -> S.StringExpr $ jsonToChezString $ Json.stringify $ Json.fromString s

224 LitChar c -> codegenChar c

258 LitChar c -> codegenChar c

225 LitBoolean b -> S.Identifier $ if b then "#t" else "#f"

259 LitBoolean b -> S.Identifier $ if b then "#t" else "#f"

226 LitArray a -> S.vector $ codegenExpr codegenEnv <$> a

260 LitArray a -> S.vector $ codegenExpr codegenEnv <$> a

227 LitRecord r -> S.record $ (map $ codegenExpr codegenEnv) <$> r

261 LitRecord r -> S.record $ (map $ codegenExpr codegenEnv) <$> r

228

262

263+jsonToChezString :: String -> String

264+jsonToChezString str = unicodeReplace str

265+ where

266+ unicodeRegex :: R.Regex

267+ unicodeRegex = R.Unsafe.unsafeRegex """\\u([A-F\d]{4})""" R.Flags.global

268+

269+ unicodeReplace :: String -> String

270+ unicodeReplace s = R.replace' unicodeRegex unicodeReplaceMatch s

271+

272+ unicodeReplaceMatch

273+ :: String

274+ -> Array (Maybe String)

275+ -> String

276+ unicodeReplaceMatch _ = case _ of

277+ [ (Just x) ] -> "\\x" <> x <> ";"

278+ _ -> unsafeCrashWith "Error matching at unicodeReplaceMatch in jsonToChezString"

279+

229-- > In addition to the standard named characters

280-- > In addition to the standard named characters

230-- > #\alarm, #\backspace, #\delete, #\esc, #\linefeed, #\newline, #\page, #\return, #\space, and #\tab,

281-- > #\alarm, #\backspace, #\delete, #\esc, #\linefeed, #\newline, #\page, #\return, #\space, and #\tab,

231-- > Chez Scheme recognizes #\bel, #\ls, #\nel, #\nul, #\rubout, and #\vt (or #\vtab).

282-- > Chez Scheme recognizes #\bel, #\ls, #\nel, #\nul, #\rubout, and #\vt (or #\vtab).

@@ -264,34 +315,32 @@ codegenPureChain :: CodegenEnv -> NeutralExpr -> ChezExpr

264codegenPureChain codegenEnv = codegenChain pureChainMode codegenEnv

315codegenPureChain codegenEnv = codegenChain pureChainMode codegenEnv

265

316

266codegenEffectChain :: CodegenEnv -> NeutralExpr -> ChezExpr

317codegenEffectChain :: CodegenEnv -> NeutralExpr -> ChezExpr

267−codegenEffectChain codegenEnv = S.chezThunk <<< codegenChain effectChainMode codegenEnv

318+codegenEffectChain codegenEnv = S.thunk <<< codegenChain effectChainMode codegenEnv

268

319

269codegenChain :: ChainMode -> CodegenEnv -> NeutralExpr -> ChezExpr

320codegenChain :: ChainMode -> CodegenEnv -> NeutralExpr -> ChezExpr

270codegenChain chainMode codegenEnv = collect []

321codegenChain chainMode codegenEnv = collect []

271 where

322 where

323+ recursive = false

324+

272 finish :: Boolean -> Array _ -> NeutralExpr -> ChezExpr

325 finish :: Boolean -> Array _ -> NeutralExpr -> ChezExpr

273 finish shouldUnthunk bindings expression = do

326 finish shouldUnthunk bindings expression = do

274 let

327 let

275 maybeUnthunk :: ChezExpr -> ChezExpr

328 maybeUnthunk :: ChezExpr -> ChezExpr

276− maybeUnthunk = if shouldUnthunk then S.chezUnthunk else identity

329+ maybeUnthunk = if shouldUnthunk then S.unthunk else identity

277− if Array.null bindings then

330+ case NEA.fromArray bindings of

278− maybeUnthunk $ codegenExpr codegenEnv expression

331+ Nothing -> maybeUnthunk $ codegenExpr codegenEnv expression

279− else

280− S.List $

281− [ S.Identifier $ scmPrefixed "let*"

282− , S.List $ bindings <#> \binding ->

283− S.List [ S.Identifier $ S.toChezIdent binding.i binding.l, binding.v ]

284− , maybeUnthunk $ codegenExpr codegenEnv expression

332+ Just bindings' -> S.Let recursive bindings' $ maybeUnthunk $ codegenExpr codegenEnv expression

285− ]

286

333

287 collect :: Array _ -> NeutralExpr -> ChezExpr

334 collect :: Array _ -> NeutralExpr -> ChezExpr

288 collect bindings expression = case unwrap expression of

335 collect bindings expression = case unwrap expression of

289 Let i l v e' ->

336 Let i l v e' ->

290− collect (Array.snoc bindings { i, l, v: codegenExpr codegenEnv v }) e'

337+ collect (Array.snoc bindings $ Tuple (toChezIdent i l) (codegenExpr codegenEnv v)) e'

291 EffectPure e' | chainMode.effect ->

338 EffectPure e' | chainMode.effect ->

292 finish false bindings e'

339 finish false bindings e'

293 EffectBind i l v e' | chainMode.effect ->

340 EffectBind i l v e' | chainMode.effect ->

341+ collect

294− collect (Array.snoc bindings { i, l, v: S.chezUnthunk $ codegenExpr codegenEnv v }) e'

342+ (Array.snoc bindings $ Tuple (toChezIdent i l) (S.unthunk $ codegenExpr codegenEnv v))

343+ e'

295 EffectDefer e' | chainMode.effect ->

344 EffectDefer e' | chainMode.effect ->

296 collect bindings e'

345 collect bindings e'

297 _ ->

346 _ ->

@@ -315,7 +364,7 @@ codegenPrimOp codegenEnv@{ currentModule } = case _ of

315 S.List [ S.Identifier $ scmPrefixed "vector-length", x' ]

364 S.List [ S.Identifier $ scmPrefixed "vector-length", x' ]

316 OpIsTag qi ->

365 OpIsTag qi ->

317 S.app

366 S.app

318− (S.Identifier $ S.recordTypePredicate $ S.resolve currentModule qi)

367+ (S.Identifier $ S.recordTypePredicate $ flattenQualified currentModule qi)

319 x'

368 x'

320 Op2 o x y ->

369 Op2 o x y ->

321 let

370 let

src/PureScript/Backend/Chez/Printer.pursnew file+354

@@ -0,0 +1,354 @@

1+module PureScript.Backend.Chez.Printer

2+ ( printLibrary

3+ ) where

5+import Prelude

7+import Control.Alternative as Alternative

8+import Data.Array as Array

9+import Data.Array.NonEmpty (NonEmptyArray)

10+import Data.Array.NonEmpty as NEA

11+import Data.Array.NonEmpty as NonEmptyArray

12+import Data.Bifunctor (bimap)

13+import Data.Foldable (foldMap)

14+import Data.Maybe (Maybe(..), maybe)

15+import Data.Newtype (un)

16+import Data.String (Pattern(..), Replacement(..))

17+import Data.String as String

18+import Data.Tuple (Tuple(..))

19+import Dodo (Doc)

20+import Dodo as D

21+import PureScript.Backend.Chez.Constants (scmPrefixed)

22+import PureScript.Backend.Chez.Syntax (ChezDefinition(..), ChezExport(..), ChezExpr(..), ChezImport(..), ChezImportLevel(..), ChezImportSet(..), ChezLibrary, LibraryBody, LibraryName, LibraryReference, LibraryVersion(..), LiteralDigit(..), SubVersionReference(..), VersionReference(..), recordTypeAccessor, recordTypeCurriedConstructor, recordTypeName, recordTypePredicate, recordTypeUncurriedConstructor)

23+

24+printWrap :: Doc Void -> Doc Void -> Doc Void -> Doc Void

25+printWrap l r x = l <> x <> r

26+

27+printList :: Doc Void -> Doc Void

28+printList = printWrap (D.text "(") (D.text ")")

29+

30+printBrackets :: Doc Void -> Doc Void

31+printBrackets = printWrap (D.text "[") (D.text "]")

32+

33+printNamedList :: Prim.String -> Doc Void -> Doc Void

34+printNamedList name body

35+ | D.isEmpty body =

36+ printList $ D.text name

37+ | otherwise =

38+ printList $ D.words [ D.text name, body ]

39+

40+printIndentedList :: Doc Void -> Doc Void -> Doc Void

41+printIndentedList ident body

42+ | D.isEmpty body =

43+ printList ident

44+ | otherwise =

45+ D.lines

46+ [ D.text "(" <> ident

47+ , D.indent body <> D.text ")"

48+ ]

49+

50+linesSeparated :: Prim.Array (Doc Void) -> Doc Void

51+linesSeparated = Array.intercalate twoLineBreaks

52+ where

53+ twoLineBreaks = D.break <> D.break

54+

55+escapeIdentifiers :: ChezLibrary -> ChezLibrary

56+escapeIdentifiers lib = lib

57+ { name = lib.name { identifiers = map escapeIdent lib.name.identifiers }

58+ , exports = map escapeExport lib.exports

59+ , imports = map escapeImport lib.imports

60+ , body =

61+ { definitions: escapeDefinition <$> lib.body.definitions

62+ , expressions: escapeExpr <$> lib.body.expressions

63+ }

64+ }

65+ where

66+ escapeIdent = String.replaceAll (Pattern "'") (Replacement "$p")

67+ escapeExport = case _ of

68+ ExportIdentifier x -> ExportIdentifier $ escapeIdent x

69+ ExportRename arr -> ExportRename $ arr <#> \r ->

70+ { original: escapeIdent r.original, rename: escapeIdent r.rename }

71+

72+ escapeImport = case _ of

73+ ImportSet set -> ImportSet $ escapeImportSet set

74+ ImportFor set lvls -> ImportFor (escapeImportSet set) lvls

75+

76+ escapeImportSet = case _ of

77+ ImportLibrary libRef ->

78+ ImportLibrary $ escapeLibRef libRef

79+ ImportOnly set idents ->

80+ ImportOnly (escapeImportSet set) $ map escapeIdent idents

81+ ImportExcept set idents ->

82+ ImportExcept (escapeImportSet set) $ map escapeIdent idents

83+ ImportPrefix set ident ->

84+ ImportPrefix (escapeImportSet set) $ escapeIdent ident

85+ ImportRename set renames ->

86+ ImportRename (escapeImportSet set) $ renames <#> \r ->

87+ { original: escapeIdent r.original, rename: escapeIdent r.rename }

88+

89+ escapeLibRef libRef = libRef { identifiers = map escapeIdent libRef.identifiers }

90+

91+ escapeDefinition = case _ of

92+ DefineValue i expr -> DefineValue (escapeIdent i) $ escapeExpr expr

93+ DefineCurriedFunction i args expr ->

94+ DefineCurriedFunction (escapeIdent i) (map escapeIdent args) $ escapeExpr expr

95+ DefineUncurriedFunction i args expr ->

96+ DefineUncurriedFunction (escapeIdent i) (map escapeIdent args) $ escapeExpr expr

97+ DefineRecordType i fields -> DefineRecordType (escapeIdent i) $ map escapeIdent fields

98+

99+ escapeExpr = case _ of

100+ Identifier i -> Identifier $ escapeIdent i

101+ List exprs -> List $ map escapeExpr exprs

102+ Cond b o -> Cond (map (bimap escapeExpr escapeExpr) b) (map escapeExpr o)

103+ Let recursive bindings expr ->

104+ Let recursive (map (bimap escapeIdent escapeExpr) bindings) $ escapeExpr expr

105+ Lambda args expr -> Lambda (map escapeIdent args) $ escapeExpr expr

106+ x@(Integer _) -> x

107+ x@(Float _) -> x

108+ x@(StringExpr _) -> x

109+ x@(Char _) -> x

110+ x@(Bool _) -> x

111+

112+printLibrary :: ChezLibrary -> Doc Void

113+printLibrary = escapeIdentifiers >>> printLibrary'

114+

115+printLibrary' :: ChezLibrary -> Doc Void

116+printLibrary' lib =

117+ flip append D.break

118+ $ D.lines

119+ $ Array.catMaybes

120+ [ D.text "#!r6rs" <$ Alternative.guard lib."#!r6rs"

121+ , D.text "#!chezscheme" <$ Alternative.guard lib."#!chezscheme"

122+ , Just $ printNamedIndentedList (D.text "library") $ D.lines

123+ [ printLibraryName lib.name

124+ , printIndentedList (D.text "export") $ D.lines $ map printExport lib.exports

125+ , (printIndentedList (D.text "import") $ D.lines $ map printImport lib.imports)

126+ <> D.break

127+ , printBody lib.body

128+ ]

129+ ]

130+

131+printLibraryName :: LibraryName -> Doc Void

132+printLibraryName { identifiers, version } =

133+ printList $ D.words

134+ [ D.words $ map D.text identifiers

135+ , case version of

136+ [] -> mempty

137+ _ -> printList $ D.words $ map printLibraryVersion version

138+ ]

139+

140+printLibraryVersion :: LibraryVersion -> Doc Void

141+printLibraryVersion = D.text <<< show <<< un LibraryVersion

142+

143+printExport :: ChezExport -> Doc Void

144+printExport = case _ of

145+ ExportIdentifier s -> D.text s

146+ ExportRename arr ->

147+ printNamedList "rename"

148+ $ D.words

149+ $ map (\r -> printList $ D.words [ D.text r.original, D.text r.rename ]) arr

150+

151+printImport :: ChezImport -> Doc Void

152+printImport = case _ of

153+ ImportSet is -> printImportSet is

154+ ImportFor is lvls ->

155+ printNamedList "for" $ D.words

156+ [ printImportSet is

157+ , D.words $ map printImportLevel lvls

158+ ]

159+

160+printImportLevel :: ChezImportLevel -> Doc Void

161+printImportLevel = case _ of

162+ ImportLevelRun -> D.text "run"

163+ ImportLevelExpand -> D.text "expand"

164+ ImportLevelMeta level -> printNamedList "meta" $ D.text $ show level

165+

166+printImportSet :: ChezImportSet -> Doc Void

167+printImportSet = case _ of

168+ ImportLibrary libRef ->

169+ printLibraryReference libRef

170+ ImportOnly impSet identifiers ->

171+ printNamedList "only" $ D.words

172+ [ printImportSet impSet, D.words $ map D.text identifiers ]

173+ ImportExcept impSet identifiers ->

174+ printNamedList "except" $ D.words

175+ [ printImportSet impSet, D.words $ map D.text identifiers ]

176+ ImportPrefix impSet rename ->

177+ printNamedList "prefix" $ D.words [ printImportSet impSet, D.text rename ]

178+ ImportRename impSet identifiers ->

179+ printNamedList "rename" $ D.words

180+ [ printImportSet impSet

181+ , D.words $ map (\r -> printList $ D.words $ map D.text [ r.original, r.rename ])

182+ identifiers

183+ ]

184+

185+printLibraryReference :: LibraryReference -> Doc Void

186+printLibraryReference lib = do

187+ let

188+ printListFn

189+ | Array.elem (NEA.head lib.identifiers)

190+ [ "for", "library", "only", "except", "prefix", "rename" ] =

191+ printNamedList "library"

192+ | otherwise =

193+ printList

194+ printListFn $ D.words

195+ [ D.words $ map D.text lib.identifiers

196+ , maybe mempty printVersionReference lib.version

197+ ]

198+

199+printVersionReference :: VersionReference -> Doc Void

200+printVersionReference = case _ of

201+ VersionRef ref ->

202+ printList $ D.words $ map printSubVersionReference ref

203+ VersionAnd ref ->

204+ printNamedList "and" $ D.words $ map printVersionReference ref

205+ VersionOr ref ->

206+ printNamedList "or" $ D.words $ map printVersionReference ref

207+ VersionNot ref ->

208+ printNamedList "not" $ printVersionReference ref

209+

210+printSubVersionReference :: SubVersionReference -> Doc Void

211+printSubVersionReference = case _ of

212+ SubVersionRef ref -> printList $ printLibraryVersion ref

213+ SubVersionGTE ref -> printNamedList ">=" $ printLibraryVersion ref

214+ SubVersionLTE ref -> printNamedList "<=" $ printLibraryVersion ref

215+ SubVersionAnd ref -> printNamedList "and" $ D.words

216+ $ map printSubVersionReference ref

217+ SubVersionOr ref -> printNamedList "or" $ D.words

218+ $ map printSubVersionReference ref

219+ SubVersionNot ref -> printNamedList "not" $ printSubVersionReference ref

220+

221+printBody :: LibraryBody -> Doc Void

222+printBody lib = do

223+ let

224+ defs = map printDefinition lib.definitions

225+ exprs = map printChezExpr lib.expressions

226+ linesSeparated $ defs <> exprs

227+

228+printNamedIndentedList :: Doc Void -> Doc Void -> Doc Void

229+printNamedIndentedList firstLine body

230+ | D.isEmpty body =

231+ printList firstLine

232+ | otherwise =

233+ D.lines

234+ [ D.text "(" <> firstLine

235+ , D.indent $ body <> D.text ")"

236+ ]

237+

238+printDefinition :: ChezDefinition -> Doc Void

239+printDefinition = case _ of

240+ DefineValue ident expr ->

241+ printNamedIndentedList (D.words [ D.text $ scmPrefixed "define", D.text ident ])

242+ $ printChezExpr expr

243+ DefineCurriedFunction ident args expr ->

244+ printNamedIndentedList (D.text (scmPrefixed "define ") <> D.text ident)

245+ $ printCurriedAbs (NEA.toArray args) expr

246+ DefineUncurriedFunction ident args expr ->

247+ printNamedIndentedList (D.text (scmPrefixed "define ") <> D.text ident)

248+ $ printNamedIndentedList

249+ (D.text (scmPrefixed "lambda ") <> printList (D.words $ map D.text args))

250+ (printChezExpr expr)

251+ DefineRecordType ident [ field ] ->

252+ printRecordDefinition

253+ ident

254+ (recordTypeName ident)

255+ (recordTypeCurriedConstructor ident)

256+ (recordTypePredicate ident)

257+ [ field ]

258+ DefineRecordType ident fields ->

259+ printRecordDefinition

260+ ident

261+ (recordTypeName ident)

262+ (recordTypeUncurriedConstructor ident)

263+ (recordTypePredicate ident)

264+ fields

265+

266+printCurriedAbs :: Prim.Array Prim.String -> ChezExpr -> Doc Void

267+printCurriedAbs args body = Array.foldr foldFn (printChezExpr body) args

268+ where

269+ foldFn next bodyOrRest =

270+ printNamedIndentedList

271+ (D.words [ D.text $ scmPrefixed "lambda", printList (D.text next) ])

272+ bodyOrRest

273+

274+printChezExpr :: ChezExpr -> Doc Void

275+printChezExpr e = case e of

276+ Integer (LiteralDigit x) -> D.text x

277+ Float (LiteralDigit x) -> D.text x

278+ Char x -> D.text x

279+ StringExpr x -> D.text x

280+ Bool x -> D.text $ if x then "#t" else "#f"

281+ Identifier x -> D.text x

282+ List xs -> printList $ D.words (printChezExpr <$> xs)

283+ Cond branches fallback -> printCond branches fallback

284+ Let recursive bindings' expr -> printLet recursive bindings' expr

285+ Lambda args expr -> printLambda args expr

286+

287+printRecordDefinition

288+ :: Prim.String

289+ -> Prim.String

290+ -> Prim.String

291+ -> Prim.String

292+ -> Prim.Array Prim.String

293+ -> Doc Void

294+printRecordDefinition ident name constructor predicate fields =

295+ printNamedIndentedList defineForm fieldsForm

296+ where

297+ defineForm :: Doc Void

298+ defineForm = D.words

299+ [ D.text $ scmPrefixed "define-record-type"

300+ , printList $ D.words $ map D.text [ name, constructor, predicate ]

301+ ]

302+

303+ fieldForm :: Prim.String -> Doc Void

304+ fieldForm field = printList $ D.words

305+ $ map D.text [ scmPrefixed "immutable", field, recordTypeAccessor ident field ]

306+

307+ fieldsForm :: Doc Void

308+ fieldsForm = printList $ D.words $ Array.cons (D.text $ scmPrefixed "fields")

309+ $ map fieldForm fields

310+

311+printLet :: Boolean -> NonEmptyArray (Tuple String ChezExpr) -> ChezExpr -> Doc Void

312+printLet recursive bindings' expr = do

313+ let

314+ multiLetKeyword

315+ | recursive = D.text $ scmPrefixed "letrec*"

316+ | otherwise = D.text $ scmPrefixed "let*"

317+ printBinding (Tuple b e) = printBrackets $ D.words [ D.text b, printChezExpr e ]

318+

319+ case NEA.uncons bindings' of

320+ { head, tail: [] } ->

321+ D.lines

322+ [ D.text "(" <> D.words [ D.text (scmPrefixed "let"), printList $ printBinding head ]

323+ , D.indent $ printChezExpr expr <> D.text ")"

324+ ]

325+ { head, tail } ->

326+ D.lines

327+ [ D.text "(" <> multiLetKeyword

328+ , D.indent $ D.lines

329+ [ D.text "(" <> printBinding head

330+ , (D.lines $ map (append D.space <<< printBinding) tail) <> D.text ")"

331+ , D.indent $ printChezExpr expr <> D.text ")"

332+ ]

333+ ]

334+

335+printLambda :: Array String -> ChezExpr -> Doc Void

336+printLambda args expr =

337+ printNamedIndentedList

338+ (D.words [ D.text $ scmPrefixed "lambda", printList $ D.words $ map D.text args ])

339+ $ printChezExpr expr

340+

341+printCond :: NonEmptyArray (Tuple ChezExpr ChezExpr) -> Maybe ChezExpr -> Doc Void

342+printCond branches fallback = do

343+ let

344+ b' :: Array (Doc Void)

345+ b' = NonEmptyArray.toArray branches <#> \(Tuple cond expr) ->

346+ printBrackets $ D.words [ printChezExpr cond, printChezExpr expr ]

347+

348+ o' :: Doc Void

349+ o' = fallback # foldMap \x ->

350+ printBrackets $ D.words [ D.text $ scmPrefixed "else", printChezExpr x ]

351+

352+ printNamedIndentedList (D.text $ scmPrefixed "cond")

353+ $ D.lines

354+ $ Array.snoc b' o'

src/PureScript/Backend/Chez/Syntax.purs+61−429

@@ -2,40 +2,28 @@ module PureScript.Backend.Chez.Syntax where

3import Prelude

5−import Control.Alternative as Alternative

6import Data.Argonaut as Json

5import Data.Argonaut as Json

7import Data.Array as Array

6import Data.Array as Array

8import Data.Array.NonEmpty (NonEmptyArray)

7import Data.Array.NonEmpty (NonEmptyArray)

9−import Data.Array.NonEmpty as NEA

10import Data.Array.NonEmpty as NonEmptyArray

8import Data.Array.NonEmpty as NonEmptyArray

11−import Data.Maybe (Maybe(..), maybe)

9+import Data.Maybe (Maybe)

12−import Data.Newtype (class Newtype, un)

10+import Data.Newtype (class Newtype)

13−import Data.String (Pattern(..), Replacement(..))

11+import Data.Tuple (Tuple)

14−import Data.String as String

15−import Data.String.Regex as R

16−import Data.String.Regex.Flags as R.Flags

17−import Data.String.Regex.Unsafe as R.Unsafe

18−import Dodo (Doc)

19−import Dodo as D

20−import Partial.Unsafe (unsafeCrashWith)

21−import Prim as Prim

22−import PureScript.Backend.Chez.Constants (libChezSchemePrefix, scmPrefixed)

12+import PureScript.Backend.Chez.Constants (scmPrefixed)

23−import PureScript.Backend.Optimizer.CoreFn (Ident(..), ModuleName(..), Prop(..), Qualified(..))

13+import PureScript.Backend.Optimizer.CoreFn (Prop(..))

24−import PureScript.Backend.Optimizer.Syntax (Level(..))

25−import Safe.Coerce (coerce)

27type ChezLibrary =

15type ChezLibrary =

28− { "#!r6rs" :: Prim.Boolean

16+ { "#!r6rs" :: Boolean

29− , "#!chezscheme" :: Prim.Boolean

17+ , "#!chezscheme" :: Boolean

30 , name :: LibraryName

18 , name :: LibraryName

31− , exports :: Prim.Array ChezExport

19+ , exports :: Array ChezExport

32− , imports :: Prim.Array ChezImport

20+ , imports :: Array ChezImport

33 , body :: LibraryBody

21 , body :: LibraryBody

34 }

22 }

36type LibraryName =

24type LibraryName =

37− { identifiers :: NonEmptyArray Prim.String

25+ { identifiers :: NonEmptyArray String

38− , version :: Prim.Array LibraryVersion

26+ , version :: Array LibraryVersion

39 }

27 }

41newtype LibraryVersion = LibraryVersion Prim.Int

29newtype LibraryVersion = LibraryVersion Prim.Int

@@ -43,31 +31,31 @@ newtype LibraryVersion = LibraryVersion Prim.Int

43derive instance Newtype LibraryVersion _

31derive instance Newtype LibraryVersion _

45data ChezExport

33data ChezExport

46− = ExportIdentifier Prim.String

34+ = ExportIdentifier String

47− | ExportRename (Prim.Array { original :: Prim.String, rename :: Prim.String })

35+ | ExportRename (Array { original :: String, rename :: String })

49type LibraryReference =

37type LibraryReference =

50− { identifiers :: NonEmptyArray Prim.String

38+ { identifiers :: NonEmptyArray String

51 , version :: Maybe VersionReference

39 , version :: Maybe VersionReference

52 }

40 }

54data VersionReference

42data VersionReference

55 = VersionRef (NonEmptyArray SubVersionReference)

43 = VersionRef (NonEmptyArray SubVersionReference)

56− | VersionAnd (Prim.Array VersionReference)

44+ | VersionAnd (Array VersionReference)

57− | VersionOr (Prim.Array VersionReference)

45+ | VersionOr (Array VersionReference)

58 | VersionNot VersionReference

46 | VersionNot VersionReference

60data SubVersionReference

48data SubVersionReference

61 = SubVersionRef LibraryVersion

49 = SubVersionRef LibraryVersion

62 | SubVersionGTE LibraryVersion

50 | SubVersionGTE LibraryVersion

63 | SubVersionLTE LibraryVersion

51 | SubVersionLTE LibraryVersion

64− | SubVersionAnd (Prim.Array SubVersionReference)

52+ | SubVersionAnd (Array SubVersionReference)

65− | SubVersionOr (Prim.Array SubVersionReference)

53+ | SubVersionOr (Array SubVersionReference)

66 | SubVersionNot SubVersionReference

54 | SubVersionNot SubVersionReference

68data ChezImport

56data ChezImport

69 = ImportSet ChezImportSet

57 = ImportSet ChezImportSet

70− | ImportFor ChezImportSet (Prim.Array ChezImportLevel)

58+ | ImportFor ChezImportSet (Array ChezImportLevel)

72data ChezImportLevel

60data ChezImportLevel

73 = ImportLevelRun

61 = ImportLevelRun

@@ -76,23 +64,23 @@ data ChezImportLevel

77data ChezImportSet

65data ChezImportSet

78 = ImportLibrary LibraryReference

66 = ImportLibrary LibraryReference

79− | ImportOnly ChezImportSet (Prim.Array Prim.String)

67+ | ImportOnly ChezImportSet (Array String)

80− | ImportExcept ChezImportSet (Prim.Array Prim.String)

68+ | ImportExcept ChezImportSet (Array String)

81− | ImportPrefix ChezImportSet Prim.String

69+ | ImportPrefix ChezImportSet String

82− | ImportRename ChezImportSet (Prim.Array { original :: Prim.String, rename :: Prim.String })

70+ | ImportRename ChezImportSet (Array { original :: String, rename :: String })

84type LibraryBody =

72type LibraryBody =

85− { definitions :: Prim.Array ChezDefinition

73+ { definitions :: Array ChezDefinition

86− , expressions :: Prim.Array ChezExpr

74+ , expressions :: Array ChezExpr

87 }

75 }

89data ChezDefinition

77data ChezDefinition

90− = DefineValue Prim.String ChezExpr

78+ = DefineValue String ChezExpr

91− | DefineCurriedFunction Prim.String (NonEmptyArray Prim.String) ChezExpr

79+ | DefineCurriedFunction String (NonEmptyArray String) ChezExpr

92− | DefineUncurriedFunction Prim.String (Prim.Array Prim.String) ChezExpr

80+ | DefineUncurriedFunction String (Array String) ChezExpr

93− | DefineRecordType Prim.String (Prim.Array Prim.String)

81+ | DefineRecordType String (Array String)

95−newtype LiteralDigit = LiteralDigit Prim.String

83+newtype LiteralDigit = LiteralDigit String

97derive instance Newtype LiteralDigit _

85derive instance Newtype LiteralDigit _

98derive newtype instance Eq LiteralDigit

86derive newtype instance Eq LiteralDigit

@@ -101,394 +89,41 @@ derive newtype instance Ord LiteralDigit

101data ChezExpr

89data ChezExpr

102 = Integer LiteralDigit

90 = Integer LiteralDigit

103 | Float LiteralDigit

91 | Float LiteralDigit

104− | Char Prim.String

92+ | Char String

105− | String Prim.String

93+ | StringExpr String

106− | Boolean Prim.Boolean

94+ | Bool Boolean

107− | Identifier Prim.String

95+ | Identifier String

108− | List (Prim.Array ChezExpr)

96+ | List (Array ChezExpr)

109−

97+ | Cond (NonEmptyArray (Tuple ChezExpr ChezExpr)) (Maybe ChezExpr)

110−definitionIdentifiers :: ChezDefinition -> Prim.Array Prim.String

98+ | Let Boolean (NonEmptyArray (Tuple String ChezExpr)) ChezExpr

111−definitionIdentifiers (DefineValue i _) = [ i ]

99+ | Lambda (Array String) ChezExpr

112−definitionIdentifiers (DefineCurriedFunction i _ _) = [ i ]

113−definitionIdentifiers (DefineUncurriedFunction i _ _) = [ i ]

114−definitionIdentifiers (DefineRecordType i [ x ]) =

115− [ recordTypeCurriedConstructor i

116− , recordTypePredicate i

117− , recordTypeAccessor i x

118− ]

119−definitionIdentifiers (DefineRecordType i fields) =

120− [ recordTypeUncurriedConstructor i

121− , recordTypePredicate i

122− ] <> map (recordTypeAccessor i) fields

123−

124−resolve :: ModuleName -> Qualified Ident -> Prim.String

125−resolve _ (Qualified Nothing (Ident i)) = i

126−resolve currentModule (Qualified (Just m) (Ident i))

127− | currentModule == m = i

128− | otherwise = coerce m <> "." <> i

129−

130−printWrap :: Doc Void -> Doc Void -> Doc Void -> Doc Void

131−printWrap l r x = l <> x <> r

132−

133−printList :: Doc Void -> Doc Void

134−printList = printWrap (D.text "(") (D.text ")")

135−

136−printNamedList :: Prim.String -> Doc Void -> Doc Void

137−printNamedList name body

138− | D.isEmpty body =

139− printList $ D.text name

140− | otherwise =

141− printList $ D.words [ D.text name, body ]

142−

143−printIndentedList :: Doc Void -> Doc Void -> Doc Void

144−printIndentedList ident body

145− | D.isEmpty body =

146− printList ident

147− | otherwise =

148− D.lines

149− [ D.text "(" <> ident

150− , D.indent body <> D.text ")"

151− ]

152−

153−linesSeparated :: Prim.Array (Doc Void) -> Doc Void

154−linesSeparated = Array.intercalate twoLineBreaks

155− where

156− twoLineBreaks = D.break <> D.break

157−

158−escapeIdentifiers :: ChezLibrary -> ChezLibrary

159−escapeIdentifiers lib = lib

160− { name = lib.name { identifiers = map escapeIdent lib.name.identifiers }

161− , exports = map escapeExport lib.exports

162− , imports = map escapeImport lib.imports

163− , body =

164− { definitions: escapeDefinition <$> lib.body.definitions

165− , expressions: escapeExpr <$> lib.body.expressions

166− }

167− }

168− where

169− escapeIdent = String.replaceAll (Pattern "'") (Replacement "$p")

170− escapeExport = case _ of

171− ExportIdentifier x -> ExportIdentifier $ escapeIdent x

172− ExportRename arr -> ExportRename $ arr <#> \r ->

173− { original: escapeIdent r.original, rename: escapeIdent r.rename }

174−

175− escapeImport = case _ of

176− ImportSet set -> ImportSet $ escapeImportSet set

177− ImportFor set lvls -> ImportFor (escapeImportSet set) lvls

178−

179− escapeImportSet = case _ of

180− ImportLibrary libRef ->

181− ImportLibrary $ escapeLibRef libRef

182− ImportOnly set idents ->

183− ImportOnly (escapeImportSet set) $ map escapeIdent idents

184− ImportExcept set idents ->

185− ImportExcept (escapeImportSet set) $ map escapeIdent idents

186− ImportPrefix set ident ->

187− ImportPrefix (escapeImportSet set) $ escapeIdent ident

188− ImportRename set renames ->

189− ImportRename (escapeImportSet set) $ renames <#> \r ->

190− { original: escapeIdent r.original, rename: escapeIdent r.rename }

191−

192− escapeLibRef libRef = libRef { identifiers = map escapeIdent libRef.identifiers }

193−

194− escapeDefinition = case _ of

195− DefineValue i expr -> DefineValue (escapeIdent i) $ escapeExpr expr

196− DefineCurriedFunction i args expr ->

197− DefineCurriedFunction (escapeIdent i) (map escapeIdent args) $ escapeExpr expr

198− DefineUncurriedFunction i args expr ->

199− DefineUncurriedFunction (escapeIdent i) (map escapeIdent args) $ escapeExpr expr

200− DefineRecordType i fields -> DefineRecordType (escapeIdent i) $ map escapeIdent fields

201−

202− escapeExpr = case _ of

203− Identifier i -> Identifier $ escapeIdent i

204− List exprs -> List $ map escapeExpr exprs

205− x@(Integer _) -> x

206− x@(Float _) -> x

207− x@(String _) -> x

208− x@(Char _) -> x

209− x@(Boolean _) -> x

210−

211−printLibrary :: ChezLibrary -> Doc Void

212−printLibrary = escapeIdentifiers >>> printLibrary'

213−

214−printLibrary' :: ChezLibrary -> Doc Void

215−printLibrary' lib =

216− flip append D.break

217− $ D.lines

218− $ Array.catMaybes

219− [ D.text "#!r6rs" <$ Alternative.guard lib."#!r6rs"

220− , D.text "#!chezscheme" <$ Alternative.guard lib."#!chezscheme"

221− , Just $ printNamedIndentedList (D.text "library") $ D.lines

222− [ printLibraryName lib.name

223− , printIndentedList (D.text "export") $ D.lines $ map printExport lib.exports

224− , (printIndentedList (D.text "import") $ D.lines $ map printImport lib.imports)

225− <> D.break

226− , printBody lib.body

227− ]

228− ]

229−

230−printLibraryName :: LibraryName -> Doc Void

231−printLibraryName { identifiers, version } =

232− printList $ D.words

233− [ D.words $ map D.text identifiers

234− , case version of

235− [] -> mempty

236− _ -> printList $ D.words $ map printLibraryVersion version

237− ]

238−

239−printLibraryVersion :: LibraryVersion -> Doc Void

240−printLibraryVersion = D.text <<< show <<< un LibraryVersion

241−

242−printExport :: ChezExport -> Doc Void

243−printExport = case _ of

244− ExportIdentifier s -> D.text s

245− ExportRename arr ->

246− printNamedList "rename"

247− $ D.words

248− $ map (\r -> printList $ D.words [ D.text r.original, D.text r.rename ]) arr

249−

250−printImport :: ChezImport -> Doc Void

251−printImport = case _ of

252− ImportSet is -> printImportSet is

253− ImportFor is lvls ->

254− printNamedList "for" $ D.words

255− [ printImportSet is

256− , D.words $ map printImportLevel lvls

257− ]

258−

259−printImportLevel :: ChezImportLevel -> Doc Void

260−printImportLevel = case _ of

261− ImportLevelRun -> D.text "run"

262− ImportLevelExpand -> D.text "expand"

263− ImportLevelMeta level -> printNamedList "meta" $ D.text $ show level

264−

265−printImportSet :: ChezImportSet -> Doc Void

266−printImportSet = case _ of

267− ImportLibrary libRef ->

268− printLibraryReference libRef

269− ImportOnly impSet identifiers ->

270− printNamedList "only" $ D.words

271− [ printImportSet impSet, D.words $ map D.text identifiers ]

272− ImportExcept impSet identifiers ->

273− printNamedList "except" $ D.words

274− [ printImportSet impSet, D.words $ map D.text identifiers ]

275− ImportPrefix impSet rename ->

276− printNamedList "prefix" $ D.words [ printImportSet impSet, D.text rename ]

277− ImportRename impSet identifiers ->

278− printNamedList "rename" $ D.words

279− [ printImportSet impSet

280− , D.words $ map (\r -> printList $ D.words $ map D.text [ r.original, r.rename ])

281− identifiers

282− ]

283−

284−printLibraryReference :: LibraryReference -> Doc Void

285−printLibraryReference lib = do

286− let

287− printListFn

288− | Array.elem (NEA.head lib.identifiers)

289− [ "for", "library", "only", "except", "prefix", "rename" ] =

290− printNamedList "library"

291− | otherwise =

292− printList

293− printListFn $ D.words

294− [ D.words $ map D.text lib.identifiers

295− , maybe mempty printVersionReference lib.version

296− ]

297−

298−printVersionReference :: VersionReference -> Doc Void

299−printVersionReference = case _ of

300− VersionRef ref ->

301− printList $ D.words $ map printSubVersionReference ref

302− VersionAnd ref ->

303− printNamedList "and" $ D.words $ map printVersionReference ref

304− VersionOr ref ->

305− printNamedList "or" $ D.words $ map printVersionReference ref

306− VersionNot ref ->

307− printNamedList "not" $ printVersionReference ref

308−

309−printSubVersionReference :: SubVersionReference -> Doc Void

310−printSubVersionReference = case _ of

311− SubVersionRef ref -> printList $ printLibraryVersion ref

312− SubVersionGTE ref -> printNamedList ">=" $ printLibraryVersion ref

313− SubVersionLTE ref -> printNamedList "<=" $ printLibraryVersion ref

314− SubVersionAnd ref -> printNamedList "and" $ D.words

315− $ map printSubVersionReference ref

316− SubVersionOr ref -> printNamedList "or" $ D.words

317− $ map printSubVersionReference ref

318− SubVersionNot ref -> printNamedList "not" $ printSubVersionReference ref

319−

320−printBody :: LibraryBody -> Doc Void

321−printBody lib = do

322− let

323− defs = map printDefinition lib.definitions

324− exprs = map printChezExpr lib.expressions

325− linesSeparated $ defs <> exprs

326−

327−printNamedIndentedList :: Doc Void -> Doc Void -> Doc Void

328−printNamedIndentedList firstLine body

329− | D.isEmpty body =

330− printList firstLine

331− | otherwise =

332− D.lines

333− [ D.text "(" <> firstLine

334− , D.indent $ body <> D.text ")"

335− ]

336−

337−printDefinition :: ChezDefinition -> Doc Void

338−printDefinition = case _ of

339− DefineValue ident expr ->

340− printNamedIndentedList (D.words [ D.text $ scmPrefixed "define", D.text ident ])

341− $ printChezExpr expr

342− DefineCurriedFunction ident args expr ->

343− printNamedIndentedList (D.text (scmPrefixed "define ") <> D.text ident)

344− $ printCurriedAbs (NEA.toArray args) expr

345− DefineUncurriedFunction ident args expr ->

346− printNamedIndentedList (D.text (scmPrefixed "define ") <> D.text ident)

347− $ printNamedIndentedList

348− (D.text (scmPrefixed "lambda ") <> printList (D.words $ map D.text args))

349− (printChezExpr expr)

350− DefineRecordType ident [ field ] ->

351− printRecordDefinition

352− ident

353− (recordTypeName ident)

354− (recordTypeCurriedConstructor ident)

355− (recordTypePredicate ident)

356− [ field ]

357− DefineRecordType ident fields ->

358− printRecordDefinition

359− ident

360− (recordTypeName ident)

361− (recordTypeUncurriedConstructor ident)

362− (recordTypePredicate ident)

363− fields

364−

365−printCurriedAbs :: Prim.Array Prim.String -> ChezExpr -> Doc Void

366−printCurriedAbs args body = Array.foldr foldFn (printChezExpr body) args

367− where

368− foldFn next bodyOrRest =

369− printNamedIndentedList

370− (D.words [ D.text $ scmPrefixed "lambda", printList (D.text next) ])

371− bodyOrRest

372−

373−printChezExpr :: forall a. ChezExpr -> Doc a

374−printChezExpr e = case e of

375− Integer (LiteralDigit x) -> D.text x

376− Float (LiteralDigit x) -> D.text x

377− Char x -> D.text x

378− String x -> D.text x

379− Boolean x -> D.text $ if x then "#t" else "#f"

380− Identifier x -> D.text x

381− List xs -> D.text "(" <> D.words (printChezExpr <$> xs) <> D.text ")"

382−

383−printRecordDefinition

384− :: Prim.String

385− -> Prim.String

386− -> Prim.String

387− -> Prim.String

388− -> Prim.Array Prim.String

389− -> Doc Void

390−printRecordDefinition ident name constructor predicate fields =

391− printNamedIndentedList defineForm fieldsForm

392− where

393− defineForm :: Doc Void

394− defineForm = D.words

395− [ D.text $ scmPrefixed "define-record-type"

396− , printList $ D.words $ map D.text [ name, constructor, predicate ]

397− ]

398−

399− fieldForm :: Prim.String -> Doc Void

400− fieldForm field = printList $ D.words

401− $ map D.text [ scmPrefixed "immutable", field, recordTypeAccessor ident field ]

402−

403− fieldsForm :: Doc Void

404− fieldsForm = printList $ D.words $ Array.cons (D.text $ scmPrefixed "fields")

405− $ map fieldForm fields

406−

407−toChezIdent :: Maybe Ident -> Level -> Prim.String

408−toChezIdent i (Level l) = case i of

409− Just (Ident i') -> case i' of

410− "$__unused" -> "_"

411− _ -> i' <> show l

412− Nothing -> "_" <> show l

413−

414−jsonToChezString :: Prim.String -> Prim.String

415−jsonToChezString str = unicodeReplace str

416− where

417− unicodeRegex :: R.Regex

418− unicodeRegex = R.Unsafe.unsafeRegex """\\u([A-F\d]{4})""" R.Flags.global

419−

420− unicodeReplace :: Prim.String -> Prim.String

421− unicodeReplace s = R.replace' unicodeRegex unicodeReplaceMatch s

422−

423− unicodeReplaceMatch

424− :: Prim.String

425− -> Prim.Array (Maybe Prim.String)

426− -> Prim.String

427− unicodeReplaceMatch _ = case _ of

428− [ (Just x) ] -> "\\x" <> x <> ";"

429− _ -> unsafeCrashWith "Error matching at unicodeReplaceMatch in jsonToChezString"

430

100

431--

101--

432

102

433−chezCond :: NonEmptyArray { c :: ChezExpr, e :: ChezExpr } -> Maybe ChezExpr -> ChezExpr

434−chezCond b o =

435− let

436− b' :: Prim.Array ChezExpr

437− b' = NonEmptyArray.toArray b <#> \{ c, e } -> List [ c, e ]

438−

439− o' :: Prim.Array ChezExpr

440− o' = Array.fromFoldable o <#> \x -> List [ Identifier $ scmPrefixed "else", x ]

441− in

442− List $ [ Identifier $ scmPrefixed "cond" ] <> b' <> o'

443−

444−chezUncurriedApplication :: ChezExpr -> Prim.Array ChezExpr -> ChezExpr

103+runUncurriedFn :: ChezExpr -> Array ChezExpr -> ChezExpr

445−chezUncurriedApplication f s = List $ Array.cons f s

104+runUncurriedFn f s = List $ Array.cons f s

446

105

447−chezUncurriedFunction :: Prim.Array Prim.String -> ChezExpr -> ChezExpr

106+mkUncurriedFn :: Array String -> ChezExpr -> ChezExpr

448−chezUncurriedFunction a e = List

107+mkUncurriedFn a e = Lambda a e

449− [ Identifier $ scmPrefixed "lambda", List $ Identifier <$> a, e ]

450

108

451−chezCurriedApplication :: ChezExpr -> NonEmptyArray ChezExpr -> ChezExpr

109+runCurriedFn :: ChezExpr -> NonEmptyArray ChezExpr -> ChezExpr

452−chezCurriedApplication f s = NonEmptyArray.foldl1 app $ NonEmptyArray.cons f s

110+runCurriedFn f s = NonEmptyArray.foldl1 app $ NonEmptyArray.cons f s

453

111

454−chezCurriedFunction :: NonEmptyArray Prim.String -> ChezExpr -> ChezExpr

112+mkCurriedFn :: NonEmptyArray String -> ChezExpr -> ChezExpr

455−chezCurriedFunction a e = Array.foldr lambda e $ NonEmptyArray.toArray a

113+mkCurriedFn a e = Array.foldr (Lambda <<< Array.singleton) e $ NonEmptyArray.toArray a

456

114

457−chezThunk :: ChezExpr -> ChezExpr

115+thunk :: ChezExpr -> ChezExpr

458−chezThunk e = List [ Identifier $ scmPrefixed "lambda", List [], e ]

116+thunk e = Lambda [] e

459

117

460−chezUnthunk :: ChezExpr -> ChezExpr

118+unthunk :: ChezExpr -> ChezExpr

461−chezUnthunk e = List [ e ]

119+unthunk e = List [ e ]

462

120

463--

121--

464

122

465app :: ChezExpr -> ChezExpr -> ChezExpr

123app :: ChezExpr -> ChezExpr -> ChezExpr

466app f x = List [ f, x ]

124app f x = List [ f, x ]

467

125

468−define :: Ident -> ChezExpr -> ChezExpr

469−define i e = List [ Identifier $ scmPrefixed "define", Identifier $ coerce i, e ]

470−

471−library :: ModuleName -> Prim.Array Ident -> Prim.Array ChezExpr -> ChezExpr

472−library moduleName exports bindings =

473− List $

474− [ Identifier "library"

475− , Identifier $ "(" <> coerce moduleName <> " lib" <> ")"

476− , List $

477− [ Identifier "export"

478− ] <> (Identifier <$> coerce exports)

479− , List

480− [ Identifier "import"

481− , List

482− [ Identifier "prefix"

483− , List

484− [ Identifier "chezscheme"

485− ]

486− , Identifier libChezSchemePrefix

487− ]

488− ]

489− ] <> bindings

490−

491−record :: Prim.Array (Prop ChezExpr) -> ChezExpr

126+record :: Array (Prop ChezExpr) -> ChezExpr

492record r =

127record r =

493 let

128 let

494 field :: Prop ChezExpr -> ChezExpr

129 field :: Prop ChezExpr -> ChezExpr

@@ -496,7 +131,7 @@ record r =

496 List

131 List

497 [ Identifier $ scmPrefixed "hashtable-set!"

132 [ Identifier $ scmPrefixed "hashtable-set!"

498 , Identifier "$record"

133 , Identifier "$record"

499− , String $ Json.stringify $ Json.fromString k

134+ , StringExpr $ Json.stringify $ Json.fromString k

500 , v

135 , v

501 ]

136 ]

502 in

137 in

@@ -518,29 +153,26 @@ quote :: ChezExpr -> ChezExpr

518quote e = app (Identifier $ scmPrefixed "quote") e

153quote e = app (Identifier $ scmPrefixed "quote") e

519

154

520eqQ :: ChezExpr -> ChezExpr -> ChezExpr

155eqQ :: ChezExpr -> ChezExpr -> ChezExpr

521−eqQ x y = chezUncurriedApplication (Identifier $ scmPrefixed "eq?") [ x, y ]

156+eqQ x y = runUncurriedFn (Identifier $ scmPrefixed "eq?") [ x, y ]

522−

523−lambda :: Prim.String -> ChezExpr -> ChezExpr

524−lambda a e = List [ Identifier $ scmPrefixed "lambda", List [ Identifier a ], e ]

525

157

526−vector :: Prim.Array ChezExpr -> ChezExpr

158+vector :: Array ChezExpr -> ChezExpr

527vector = List <<< Array.cons (Identifier $ scmPrefixed "vector")

159vector = List <<< Array.cons (Identifier $ scmPrefixed "vector")

528

160

529−recordTypeName :: Prim.String -> Prim.String

161+recordTypeName :: String -> String

530recordTypeName i = i <> "$"

162recordTypeName i = i <> "$"

531

163

532−recordTypeCurriedConstructor :: Prim.String -> Prim.String

164+recordTypeCurriedConstructor :: String -> String

533recordTypeCurriedConstructor i = i

165recordTypeCurriedConstructor i = i

534

166

535−recordTypeUncurriedConstructor :: Prim.String -> Prim.String

167+recordTypeUncurriedConstructor :: String -> String

536recordTypeUncurriedConstructor i = i <> "*"

168recordTypeUncurriedConstructor i = i <> "*"

537

169

538−recordTypePredicate :: Prim.String -> Prim.String

170+recordTypePredicate :: String -> String

539recordTypePredicate i = i <> "?"

171recordTypePredicate i = i <> "?"

540

172

541−recordTypeAccessor :: Prim.String -> Prim.String -> Prim.String

173+recordTypeAccessor :: String -> String -> String

542recordTypeAccessor i field = i <> "-" <> field

174recordTypeAccessor i field = i <> "-" <> field

543

175

544−recordAccessor :: ChezExpr -> Prim.String -> Prim.String -> ChezExpr

176+recordAccessor :: ChezExpr -> String -> String -> ChezExpr

545recordAccessor expr name field =

177recordAccessor expr name field =

546− chezUncurriedApplication (Identifier $ recordTypeAccessor name field) [ expr ]

178+ runUncurriedFn (Identifier $ recordTypeAccessor name field) [ expr ]

test-snapshots/src/snapshots-output/Snapshot.ArrayIndex.ss+3−1

@@ -10,4 +10,6 @@

11 (scm:define testAccessorGetIndex

12 (scm:lambda (v0)

13+ (scm:cond

13− (scm:cond ((scm:fx=? (scm:vector-length v0) 1) (scm:vector-ref v0 0)) (scm:else 0)))))

14+ [(scm:fx=? (scm:vector-length v0) 1) (scm:vector-ref v0 0)]

15+ [scm:else 0]))))

test-snapshots/src/snapshots-output/Snapshot.Branch.ss+20−4

@@ -14,18 +14,34 @@

14 (scm:define i

15 (scm:lambda (v0)

16 (scm:lambda (v11)

17+ (scm:cond

18+ [v0 (scm:not v11)]

19+ [(scm:not v11) #t]

20+ [v11 #f]

17− (scm:cond (v0 (scm:not v11)) ((scm:not v11) #t) (v11 #f) (scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match"))))))))

21+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))]))))

19 (scm:define h

23 (scm:define h

20 (scm:lambda (v0)

24 (scm:lambda (v0)

25+ (scm:cond

26+ [(scm:fl=? v0 3.14) 3.14159]

21− (scm:cond ((scm:fl=? v0 3.14) 3.14159) (scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))))))

27+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))])))

23 (scm:define g

29 (scm:define g

24 (scm:lambda (v0)

30 (scm:lambda (v0)

25− (scm:cond ((scm:fx=? v0 0) 1) ((scm:fx=? v0 1) 2) ((scm:fx=? v0 2) 3) (scm:else 0))))

31+ (scm:cond

32+ [(scm:fx=? v0 0) 1]

33+ [(scm:fx=? v0 1) 2]

34+ [(scm:fx=? v0 2) 3]

35+ [scm:else 0])))

27 (scm:define f

37 (scm:define f

28 (scm:lambda (x0)

38 (scm:lambda (x0)

29 (scm:lambda (y1)

39 (scm:lambda (y1)

30 (scm:lambda (z2)

40 (scm:lambda (z2)

31− (scm:cond (x0 (scm:cond (y1 (scm:cond (z2 0) (scm:else 1))) (scm:else 2))) (scm:else 3)))))))

41+ (scm:cond

42+ [x0 (scm:cond

43+ [y1 (scm:cond

44+ [z2 0]

45+ [scm:else 1])]

46+ [scm:else 2])]

47+ [scm:else 3]))))))

test-snapshots/src/snapshots-output/Snapshot.ConstructorAccessor.ss+10−3

@@ -78,15 +78,22 @@

78 (scm:define test5

79 (scm:lambda (_)

80 (scm:lambda (v1)

81+ (scm:cond

82+ [(First? v1) (First-value0 v1)]

81− (scm:cond ((First? v1) (First-value0 v1)) (scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match"))))))))

83+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))]))))

83 (scm:define test4

85 (scm:define test4

84 (scm:lambda (v0)

86 (scm:lambda (v0)

87+ (scm:cond

88+ [(First? v0) (First-value0 v0)]

89+ [(Last? v0) (Last-value0 v0)]

85− (scm:cond ((First? v0) (First-value0 v0)) ((Last? v0) (Last-value0 v0)) (scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))))))

90+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))])))

87 (scm:define test3

92 (scm:define test3

88 (scm:lambda (v0)

93 (scm:lambda (v0)

94+ (scm:cond

89− (scm:cond ((scm:fx<? (HasArgs-value0 v0) (HasArgs-value2 v0)) (HasArgs-value0 v0)) (scm:else (HasArgs-value1 v0)))))

95+ [(scm:fx<? (HasArgs-value0 v0) (HasArgs-value2 v0)) (HasArgs-value0 v0)]

96+ [scm:else (HasArgs-value1 v0)])))

91 (scm:define test2

98 (scm:define test2

92 (scm:lambda (v0)

99 (scm:lambda (v0)

test-snapshots/src/snapshots-output/Snapshot.Effect.ss+17−4

@@ -14,13 +14,26 @@

15 (scm:define dontInlineMe

16 (scm:lambda (v0)

17+ (scm:lambda ()

17− (scm:lambda () Data.Unit.unit)))

18+ Data.Unit.unit)))

19 (scm:define lastComponentIsRun

20 (scm:define lastComponentIsRun

20− (scm:let* ((_0 (dontInlineMe "a"))) (scm:lambda () (scm:let* ((_ (_0)) (_ ((dontInlineMe "b")))) ((dontInlineMe "c"))))))

21+ (scm:let ([_0 (dontInlineMe "a")])

22+ (scm:lambda ()

23+ (scm:let*

24+ ([_ (_0)]

25+ [_ ((dontInlineMe "b"))])

26+ ((dontInlineMe "c"))))))

22 (scm:define lastPureIsUnwrapped

28 (scm:define lastPureIsUnwrapped

23− (scm:let* ((_0 (dontInlineMe "a"))) (scm:lambda () (scm:let* ((value1 (_0)) (_ ((dontInlineMe "b")))) value1))))

29+ (scm:let ([_0 (dontInlineMe "a")])

30+ (scm:lambda ()

31+ (scm:let*

32+ ([value1 (_0)]

33+ [_ ((dontInlineMe "b"))])

34+ value1))))

25 (scm:define main

36 (scm:define main

37+ (scm:lambda ()

26− (scm:lambda () (scm:let* ((_ (lastComponentIsRun))) (lastPureIsUnwrapped)))))

38+ (scm:let ([_ (lastComponentIsRun)])

39+ (lastPureIsUnwrapped)))))

test-snapshots/src/snapshots-output/Snapshot.Let.ss+5−1

@@ -10,4 +10,8 @@

11 (scm:define letChain

12 (scm:lambda (x0)

13+ (scm:let*

14+ ([a1 (scm:fx+ x0 x0)]

15+ [b2 (scm:fx+ a1 a1)]

16+ [c3 (scm:fx+ b2 b2)])

13− (scm:let* ((a1 (scm:fx+ x0 x0)) (b2 (scm:fx+ a1 a1)) (c3 (scm:fx+ b2 b2))) (scm:fx+ (scm:fx+ (scm:fx+ a1 b2) c3) (scm:fx* c3 c3))))))

17+ (scm:fx+ (scm:fx+ (scm:fx+ a1 b2) c3) (scm:fx* c3 c3))))))

test-snapshots/src/snapshots-output/Snapshot.Prime.ss+5−1

@@ -104,7 +104,11 @@

104 (scm:string-append ((scm:hashtable-ref dictNormal0 "normal" #f) a2) ((scm:hashtable-ref dictNormal11 "normal" #f) b3)))))))

105

106 (scm:define instanceName$p

107− (scm:letrec* (($record (scm:make-hashtable scm:string-hash scm:string=?))) (scm:hashtable-set! $record "normal" (scm:lambda (v0) (scm:cond ((F1? v0) "F1") ((F2? v0) "F2") (scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match"))))))) $record))

107+ (scm:letrec* (($record (scm:make-hashtable scm:string-hash scm:string=?))) (scm:hashtable-set! $record "normal" (scm:lambda (v0)

108+ (scm:cond

109+ [(F1? v0) "F1"]

110+ [(F2? v0) "F2"]

111+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))]))) $record))

108

112

109 (scm:define useInstance

113 (scm:define useInstance

110 "F1F2")

114 "F1F2")

test-snapshots/src/snapshots-output/Snapshot.UncurriedFunction.ss+17−4

@@ -20,10 +20,15 @@

20 (prefix (Test.Assert lib) Test.Assert.))

22 (scm:define test4a

23+ (scm:lambda (a0)

24+ (scm:let*

23− (scm:lambda (a0) (scm:let* ((_1 (Effect.Console.log a0)) (_ (_1))) a0)))

25+ ([_1 (Effect.Console.log a0)]

26+ [_ (_1)])

27+ a0)))

25 (scm:define test4b

29 (scm:define test4b

30+ (scm:lambda ()

26− (scm:lambda () (test4a "test4b")))

31+ (test4a "test4b")))

28 (scm:define test3a

33 (scm:define test3a

29 (scm:lambda (v0 b1)

34 (scm:lambda (v0 b1)

@@ -40,10 +45,18 @@

40 (test2a 1 2))

45 (test2a 1 2))

42 (scm:define test1a

47 (scm:define test1a

43− (Data.Function.Uncurried.mkFn0 (scm:lambda (v0) 1)))

48+ (Data.Function.Uncurried.mkFn0 (scm:lambda (v0)

49+ 1)))

45 (scm:define test1b

51 (scm:define test1b

46 (Data.Function.Uncurried.runFn0 test1a))

52 (Data.Function.Uncurried.runFn0 test1a))

48 (scm:define main

54 (scm:define main

49− (scm:let* ((_0 (Test.Assert.assert (scm:fx=? test1b 1)))) (scm:lambda () (scm:let* ((_ (_0)) (_ ((Test.Assert.assert (scm:fx=? test2b 1)))) (_ ((Test.Assert.assert (scm:fx=? test3b 2)))) (v4 (test4b))) ((Test.Assert.assert (scm:string=? v4 "test4b"))))))))

55+ (scm:let ([_0 (Test.Assert.assert (scm:fx=? test1b 1))])

56+ (scm:lambda ()

57+ (scm:let*

58+ ([_ (_0)]

59+ [_ ((Test.Assert.assert (scm:fx=? test2b 1)))]

60+ [_ ((Test.Assert.assert (scm:fx=? test3b 2)))]

61+ [v4 (test4b)])

62+ ((Test.Assert.assert (scm:string=? v4 "test4b"))))))))

test/Main.purs+3−3

@@ -43,8 +43,8 @@ import Node.Process as Process

43import Partial.Unsafe (unsafeCrashWith)

44import PureScript.Backend.Chez.Constants (moduleForeign, moduleLib, schemeExt)

45import PureScript.Backend.Chez.Convert (codegenModule)

46+import PureScript.Backend.Chez.Printer as P

46import PureScript.Backend.Chez.Runtime (runtimeModule)

47import PureScript.Backend.Chez.Runtime (runtimeModule)

47−import PureScript.Backend.Chez.Syntax as S

48import PureScript.Backend.Optimizer.Builder (buildModules)

49import PureScript.Backend.Optimizer.Convert (BackendModule)

50import PureScript.Backend.Optimizer.CoreFn (Comment(..), Module(..), ModuleName(..))

@@ -99,7 +99,7 @@ runSnapshotTests { accept, filter } = do

99 let runtimePath = Path.concat [ testOut, "_Chez_Runtime" ]

100 mkdirp runtimePath

101 let runtimeFilePath = Path.concat [ runtimePath, moduleLib <> schemeExt ]

102− let runtimeContents = Dodo.print plainText Dodo.twoSpaces $ S.printLibrary $ runtimeModule

102+ let runtimeContents = Dodo.print plainText Dodo.twoSpaces $ P.printLibrary $ runtimeModule

103 FS.writeTextFile UTF8 runtimeFilePath runtimeContents

104 coreFnModulesFromOutput "output" filter >>= case _ of

105 Left errors -> do

@@ -117,7 +117,7 @@ runSnapshotTests { accept, filter } = do

117 let

118 formatted =

119 Dodo.print plainText Dodo.twoSpaces

120− $ S.printLibrary

120+ $ P.printLibrary

121 $ codegenModule backend

122 let testFileDir = Path.concat [ testOut, name ]

123 let testFilePath = Path.concat [ testFileDir, moduleLib <> schemeExt ]