git.iko.soy/rowtype-yoga/purescm
on bytevector help sign in
Refactor ChezExpr to support pretty-printing (#119)

* Move all print-related things to Printer * Rename Boolean/String; drop qualified Prim alias * Move code defined in Syntax.purs that is only used in Convert.purs to Convert module * Drop old syntax utils (e.g. library, define) * Pretty-print `cond` * Pretty-print `let` bindings * Pretty-print `lambda` (uncurried & curried) * Use mk/run terms for curried/uncurried fns * Rename `resolve` to `flattenQualified`

commite2c3e336c61e62dca9013bfc8d95ad9d0f1e98f2 authorJordanMartinez <jordanalex.martinez@protonmail.com> dateFri 7 Apr 2023, 12:16 (4 years ago) parent90c86f3
11 files changed+584−490
compare with bytevector
unifiedsplit
src/PureScript/Backend/Chez/Convert.purs+89−40 src/PureScript/Backend/Chez/Printer.purs+354 src/PureScript/Backend/Chez/Syntax.purs+61−429 test-snapshots/src/snapshots-output/Snapshot.ArrayIndex.ss+3−1 test-snapshots/src/snapshots-output/Snapshot.Branch.ss+20−4 test-snapshots/src/snapshots-output/Snapshot.ConstructorAccessor.ss+10−3 test-snapshots/src/snapshots-output/Snapshot.Effect.ss+17−4 test-snapshots/src/snapshots-output/Snapshot.Let.ss+5−1 test-snapshots/src/snapshots-output/Snapshot.Prime.ss+5−1 test-snapshots/src/snapshots-output/Snapshot.UncurriedFunction.ss+17−4 test/Main.purs+3−3
src/PureScript/Backend/Chez/Convert.purs+89−40
@@ -14,16 +14,19 @@ import Data.Newtype (unwrap, wrap)
1414import Data.Set as Set
1515import Data.String as String
1616import 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
1720import Data.Tuple (Tuple(..), uncurry)
1821import Data.Tuple as Tuple
1922import Partial.Unsafe (unsafeCrashWith)
2023import 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)
2225import PureScript.Backend.Chez.Syntax as S
2326import 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(..))
2528import 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(..))
2730import Safe.Coerce (coerce)
2831
2932type CodegenEnv =
@@ -43,7 +46,7 @@ codegenModule { name, bindings, imports, foreign: foreign_ } =
4346 exports' :: Array ChezExport
4447 exports' = map ExportIdentifier
4548 $ Array.sort
46− $ Array.concatMap S.definitionIdentifiers definitions
49+ $ Array.concatMap definitionIdentifiers definitions
4750 <> map coerce (Array.fromFoldable foreign_)
4851
4952 pursImports :: Array ChezImport
@@ -83,6 +86,34 @@ codegenModule { name, bindings, imports, foreign: foreign_ } =
8386 , body: { definitions, expressions: [] }
8487 }
8588
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+
86117codegenTopLevelBindingGroup
87118 :: CodegenEnv
88119 -> BackendBindingGroup Ident NeutralExpr
@@ -102,13 +133,13 @@ codegenTopLevelBinding codegenEnv (Tuple (Ident i) n) =
102133 Abs a e ->
103134 [ DefineCurriedFunction
104135 i
105− (uncurry S.toChezIdent <$> a)
136+ (uncurry toChezIdent <$> a)
106137 (codegenExpr codegenEnv e)
107138 ]
108139 UncurriedAbs a e ->
109140 [ DefineUncurriedFunction
110141 i
111− (uncurry S.toChezIdent <$> a)
142+ (uncurry toChezIdent <$> a)
112143 (codegenExpr codegenEnv e)
113144 ]
114145 CtorDef _ _ _ ss ->
@@ -126,7 +157,7 @@ codegenTopLevelBinding codegenEnv (Tuple (Ident i) n) =
126157 | otherwise ->
127158 [ DefineRecordType i ss
128159 , DefineCurriedFunction i xs
129− $ S.chezUncurriedApplication
160+ $ S.runUncurriedFn
130161 (S.Identifier $ S.recordTypeUncurriedConstructor i)
131162 (map S.Identifier ss)
132163 ]
@@ -136,42 +167,45 @@ codegenTopLevelBinding codegenEnv (Tuple (Ident i) n) =
136167codegenExpr :: CodegenEnv -> NeutralExpr -> ChezExpr
137168codegenExpr codegenEnv@{ currentModule } s = case unwrap s of
138169 Var qi ->
139− S.Identifier $ S.resolve currentModule qi
170+ S.Identifier $ flattenQualified currentModule qi
140171 Local i l ->
141− S.Identifier $ coerce $ S.toChezIdent i l
172+ S.Identifier $ coerce $ toChezIdent i l
142173 Lit l ->
143174 codegenLiteral codegenEnv l
144175 App f p ->
145− S.chezCurriedApplication (codegenExpr codegenEnv f) (codegenExpr codegenEnv <$> p)
176+ S.runCurriedFn (codegenExpr codegenEnv f) (codegenExpr codegenEnv <$> p)
146177 Abs a e -> do
147− S.chezCurriedFunction (uncurry S.toChezIdent <$> a) (codegenExpr codegenEnv e)
178+ S.mkCurriedFn (uncurry toChezIdent <$> a) (codegenExpr codegenEnv e)
148179 UncurriedApp f p ->
149− S.chezUncurriedApplication (codegenExpr codegenEnv f) (codegenExpr codegenEnv <$> p)
180+ S.runUncurriedFn (codegenExpr codegenEnv f) (codegenExpr codegenEnv <$> p)
150181 UncurriedAbs a e ->
151− S.chezUncurriedFunction (uncurry S.toChezIdent <$> a) (codegenExpr codegenEnv e)
182+ S.mkUncurriedFn (uncurry toChezIdent <$> a) (codegenExpr codegenEnv e)
152183 UncurriedEffectApp f p ->
153− S.chezThunk $ S.chezUncurriedApplication (codegenExpr codegenEnv f)
184+ S.thunk $ S.runUncurriedFn (codegenExpr codegenEnv f)
154185 (codegenExpr codegenEnv <$> p)
155186 UncurriedEffectAbs a e ->
156− S.chezUncurriedFunction (uncurry S.toChezIdent <$> a)
187+ S.mkUncurriedFn (uncurry toChezIdent <$> a)
157188 (codegenChain effectChainMode codegenEnv e)
158189
159190 Accessor e (GetProp i) ->
160− S.chezUncurriedApplication
191+ S.runUncurriedFn
161192 (S.Identifier $ scmPrefixed "hashtable-ref")
162− [ codegenExpr codegenEnv e, S.String $ Json.stringify $ Json.fromString i, S.Boolean false ]
193+ [ codegenExpr codegenEnv e
194+ , S.StringExpr $ Json.stringify $ Json.fromString i
195+ , S.Bool false
196+ ]
163197 Accessor e (GetIndex i) ->
164− S.chezUncurriedApplication
198+ S.runUncurriedFn
165199 (S.Identifier $ scmPrefixed "vector-ref")
166200 [ codegenExpr codegenEnv e, S.Integer $ wrap $ show i ]
167201 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
169203 Update _ _ ->
170204 S.Identifier "object-update"
171205
172206 CtorSaturated qi _ _ _ xs ->
173− S.chezUncurriedApplication
174− (S.Identifier $ S.recordTypeUncurriedConstructor $ S.resolve currentModule qi)
207+ S.runUncurriedFn
208+ (S.Identifier $ S.recordTypeUncurriedConstructor $ flattenQualified currentModule qi)
175209 (map (codegenExpr codegenEnv <<< Tuple.snd) xs)
176210 CtorDef _ _ _ _ ->
177211 unsafeCrashWith "codegenExpr:CtorDef - handled by codegenTopLevelBinding!"
@@ -182,9 +216,9 @@ codegenExpr codegenEnv@{ currentModule } s = case unwrap s of
182216 codegenPureChain codegenEnv s
183217 Branch b o -> do
184218 let
185− goPair :: Pair NeutralExpr -> { c :: _, e :: _ }
186− goPair (Pair c e) = { c: codegenExpr codegenEnv c, e: codegenExpr codegenEnv e }
187− S.chezCond (goPair <$> b) (codegenExpr codegenEnv <$> o)
219+ goPair :: Pair NeutralExpr -> Tuple ChezExpr ChezExpr
220+ goPair (Pair c e) = Tuple (codegenExpr codegenEnv c) (codegenExpr codegenEnv e)
221+ S.Cond (goPair <$> b) (codegenExpr codegenEnv <$> o)
188222
189223 EffectBind _ _ _ _ ->
190224 codegenEffectChain codegenEnv s
@@ -211,7 +245,7 @@ codegenExpr codegenEnv@{ currentModule } s = case unwrap s of
211245 , S.List [ S.Identifier $ scmPrefixed "make-error" ]
212246 , S.List
213247 [ S.Identifier $ scmPrefixed "make-message-condition"
214− , S.String $ Json.stringify $ Json.fromString i
248+ , S.StringExpr $ Json.stringify $ Json.fromString i
215249 ]
216250 ]
217251 ]
@@ -220,12 +254,29 @@ codegenLiteral :: CodegenEnv -> Literal NeutralExpr -> ChezExpr
220254codegenLiteral codegenEnv = case _ of
221255 LitInt i -> S.Integer $ wrap $ show i
222256 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
224258 LitChar c -> codegenChar c
225259 LitBoolean b -> S.Identifier $ if b then "#t" else "#f"
226260 LitArray a -> S.vector $ codegenExpr codegenEnv <$> a
227261 LitRecord r -> S.record $ (map $ codegenExpr codegenEnv) <$> r
228262
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+
229280-- > In addition to the standard named characters
230281-- > #\alarm, #\backspace, #\delete, #\esc, #\linefeed, #\newline, #\page, #\return, #\space, and #\tab,
231282-- > Chez Scheme recognizes #\bel, #\ls, #\nel, #\nul, #\rubout, and #\vt (or #\vtab).
@@ -264,34 +315,32 @@ codegenPureChain :: CodegenEnv -> NeutralExpr -> ChezExpr
264315codegenPureChain codegenEnv = codegenChain pureChainMode codegenEnv
265316
266317codegenEffectChain :: CodegenEnv -> NeutralExpr -> ChezExpr
267−codegenEffectChain codegenEnv = S.chezThunk <<< codegenChain effectChainMode codegenEnv
318+codegenEffectChain codegenEnv = S.thunk <<< codegenChain effectChainMode codegenEnv
268319
269320codegenChain :: ChainMode -> CodegenEnv -> NeutralExpr -> ChezExpr
270321codegenChain chainMode codegenEnv = collect []
271322 where
323+ recursive = false
324+
272325 finish :: Boolean -> Array _ -> NeutralExpr -> ChezExpr
273326 finish shouldUnthunk bindings expression = do
274327 let
275328 maybeUnthunk :: ChezExpr -> ChezExpr
276− maybeUnthunk = if shouldUnthunk then S.chezUnthunk else identity
277− if Array.null bindings then
278− 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
285− ]
329+ maybeUnthunk = if shouldUnthunk then S.unthunk else identity
330+ case NEA.fromArray bindings of
331+ Nothing -> maybeUnthunk $ codegenExpr codegenEnv expression
332+ Just bindings' -> S.Let recursive bindings' $ maybeUnthunk $ codegenExpr codegenEnv expression
286333
287334 collect :: Array _ -> NeutralExpr -> ChezExpr
288335 collect bindings expression = case unwrap expression of
289336 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'
291338 EffectPure e' | chainMode.effect ->
292339 finish false bindings e'
293340 EffectBind i l v e' | chainMode.effect ->
294− collect (Array.snoc bindings { i, l, v: S.chezUnthunk $ codegenExpr codegenEnv v }) e'
341+ collect
342+ (Array.snoc bindings $ Tuple (toChezIdent i l) (S.unthunk $ codegenExpr codegenEnv v))
343+ e'
295344 EffectDefer e' | chainMode.effect ->
296345 collect bindings e'
297346 _ ->
@@ -315,7 +364,7 @@ codegenPrimOp codegenEnv@{ currentModule } = case _ of
315364 S.List [ S.Identifier $ scmPrefixed "vector-length", x' ]
316365 OpIsTag qi ->
317366 S.app
318− (S.Identifier $ S.recordTypePredicate $ S.resolve currentModule qi)
367+ (S.Identifier $ S.recordTypePredicate $ flattenQualified currentModule qi)
319368 x'
320369 Op2 o x y ->
321370 let
src/PureScript/Backend/Chez/Printer.pursnew file+354
@@ -0,0 +1,354 @@
1+module PureScript.Backend.Chez.Printer
2+ ( printLibrary
3+ ) where
4+
5+import Prelude
6+
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
22
33import Prelude
44
5−import Control.Alternative as Alternative
65import Data.Argonaut as Json
76import Data.Array as Array
87import Data.Array.NonEmpty (NonEmptyArray)
9−import Data.Array.NonEmpty as NEA
108import Data.Array.NonEmpty as NonEmptyArray
11−import Data.Maybe (Maybe(..), maybe)
12−import Data.Newtype (class Newtype, un)
13−import Data.String (Pattern(..), Replacement(..))
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)
23−import PureScript.Backend.Optimizer.CoreFn (Ident(..), ModuleName(..), Prop(..), Qualified(..))
24−import PureScript.Backend.Optimizer.Syntax (Level(..))
25−import Safe.Coerce (coerce)
9+import Data.Maybe (Maybe)
10+import Data.Newtype (class Newtype)
11+import Data.Tuple (Tuple)
12+import PureScript.Backend.Chez.Constants (scmPrefixed)
13+import PureScript.Backend.Optimizer.CoreFn (Prop(..))
2614
2715type ChezLibrary =
28− { "#!r6rs" :: Prim.Boolean
29− , "#!chezscheme" :: Prim.Boolean
16+ { "#!r6rs" :: Boolean
17+ , "#!chezscheme" :: Boolean
3018 , name :: LibraryName
31− , exports :: Prim.Array ChezExport
32− , imports :: Prim.Array ChezImport
19+ , exports :: Array ChezExport
20+ , imports :: Array ChezImport
3321 , body :: LibraryBody
3422 }
3523
3624type LibraryName =
37− { identifiers :: NonEmptyArray Prim.String
38− , version :: Prim.Array LibraryVersion
25+ { identifiers :: NonEmptyArray String
26+ , version :: Array LibraryVersion
3927 }
4028
4129newtype LibraryVersion = LibraryVersion Prim.Int
@@ -43,31 +31,31 @@ newtype LibraryVersion = LibraryVersion Prim.Int
4331derive instance Newtype LibraryVersion _
4432
4533data ChezExport
46− = ExportIdentifier Prim.String
47− | ExportRename (Prim.Array { original :: Prim.String, rename :: Prim.String })
34+ = ExportIdentifier String
35+ | ExportRename (Array { original :: String, rename :: String })
4836
4937type LibraryReference =
50− { identifiers :: NonEmptyArray Prim.String
38+ { identifiers :: NonEmptyArray String
5139 , version :: Maybe VersionReference
5240 }
5341
5442data VersionReference
5543 = VersionRef (NonEmptyArray SubVersionReference)
56− | VersionAnd (Prim.Array VersionReference)
57− | VersionOr (Prim.Array VersionReference)
44+ | VersionAnd (Array VersionReference)
45+ | VersionOr (Array VersionReference)
5846 | VersionNot VersionReference
5947
6048data SubVersionReference
6149 = SubVersionRef LibraryVersion
6250 | SubVersionGTE LibraryVersion
6351 | SubVersionLTE LibraryVersion
64− | SubVersionAnd (Prim.Array SubVersionReference)
65− | SubVersionOr (Prim.Array SubVersionReference)
52+ | SubVersionAnd (Array SubVersionReference)
53+ | SubVersionOr (Array SubVersionReference)
6654 | SubVersionNot SubVersionReference
6755
6856data ChezImport
6957 = ImportSet ChezImportSet
70− | ImportFor ChezImportSet (Prim.Array ChezImportLevel)
58+ | ImportFor ChezImportSet (Array ChezImportLevel)
7159
7260data ChezImportLevel
7361 = ImportLevelRun
@@ -76,23 +64,23 @@ data ChezImportLevel
7664
7765data ChezImportSet
7866 = ImportLibrary LibraryReference
79− | ImportOnly ChezImportSet (Prim.Array Prim.String)
80− | ImportExcept ChezImportSet (Prim.Array Prim.String)
81− | ImportPrefix ChezImportSet Prim.String
82− | ImportRename ChezImportSet (Prim.Array { original :: Prim.String, rename :: Prim.String })
67+ | ImportOnly ChezImportSet (Array String)
68+ | ImportExcept ChezImportSet (Array String)
69+ | ImportPrefix ChezImportSet String
70+ | ImportRename ChezImportSet (Array { original :: String, rename :: String })
8371
8472type LibraryBody =
85− { definitions :: Prim.Array ChezDefinition
86− , expressions :: Prim.Array ChezExpr
73+ { definitions :: Array ChezDefinition
74+ , expressions :: Array ChezExpr
8775 }
8876
8977data ChezDefinition
90− = DefineValue Prim.String ChezExpr
91− | DefineCurriedFunction Prim.String (NonEmptyArray Prim.String) ChezExpr
92− | DefineUncurriedFunction Prim.String (Prim.Array Prim.String) ChezExpr
93− | DefineRecordType Prim.String (Prim.Array Prim.String)
78+ = DefineValue String ChezExpr
79+ | DefineCurriedFunction String (NonEmptyArray String) ChezExpr
80+ | DefineUncurriedFunction String (Array String) ChezExpr
81+ | DefineRecordType String (Array String)
9482
95−newtype LiteralDigit = LiteralDigit Prim.String
83+newtype LiteralDigit = LiteralDigit String
9684
9785derive instance Newtype LiteralDigit _
9886derive newtype instance Eq LiteralDigit
@@ -101,394 +89,41 @@ derive newtype instance Ord LiteralDigit
10189data ChezExpr
10290 = Integer LiteralDigit
10391 | Float LiteralDigit
104− | Char Prim.String
105− | String Prim.String
106− | Boolean Prim.Boolean
107− | Identifier Prim.String
108− | List (Prim.Array ChezExpr)
109−
110−definitionIdentifiers :: ChezDefinition -> Prim.Array Prim.String
111−definitionIdentifiers (DefineValue i _) = [ i ]
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"
92+ | Char String
93+ | StringExpr String
94+ | Bool Boolean
95+ | Identifier String
96+ | List (Array ChezExpr)
97+ | Cond (NonEmptyArray (Tuple ChezExpr ChezExpr)) (Maybe ChezExpr)
98+ | Let Boolean (NonEmptyArray (Tuple String ChezExpr)) ChezExpr
99+ | Lambda (Array String) ChezExpr
430100
431101--
432102
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
445−chezUncurriedApplication f s = List $ Array.cons f s
103+runUncurriedFn :: ChezExpr -> Array ChezExpr -> ChezExpr
104+runUncurriedFn f s = List $ Array.cons f s
446105
447−chezUncurriedFunction :: Prim.Array Prim.String -> ChezExpr -> ChezExpr
448−chezUncurriedFunction a e = List
449− [ Identifier $ scmPrefixed "lambda", List $ Identifier <$> a, e ]
106+mkUncurriedFn :: Array String -> ChezExpr -> ChezExpr
107+mkUncurriedFn a e = Lambda a e
450108
451−chezCurriedApplication :: ChezExpr -> NonEmptyArray ChezExpr -> ChezExpr
452−chezCurriedApplication f s = NonEmptyArray.foldl1 app $ NonEmptyArray.cons f s
109+runCurriedFn :: ChezExpr -> NonEmptyArray ChezExpr -> ChezExpr
110+runCurriedFn f s = NonEmptyArray.foldl1 app $ NonEmptyArray.cons f s
453111
454−chezCurriedFunction :: NonEmptyArray Prim.String -> ChezExpr -> ChezExpr
455−chezCurriedFunction a e = Array.foldr lambda e $ NonEmptyArray.toArray a
112+mkCurriedFn :: NonEmptyArray String -> ChezExpr -> ChezExpr
113+mkCurriedFn a e = Array.foldr (Lambda <<< Array.singleton) e $ NonEmptyArray.toArray a
456114
457−chezThunk :: ChezExpr -> ChezExpr
458−chezThunk e = List [ Identifier $ scmPrefixed "lambda", List [], e ]
115+thunk :: ChezExpr -> ChezExpr
116+thunk e = Lambda [] e
459117
460−chezUnthunk :: ChezExpr -> ChezExpr
461−chezUnthunk e = List [ e ]
118+unthunk :: ChezExpr -> ChezExpr
119+unthunk e = List [ e ]
462120
463121--
464122
465123app :: ChezExpr -> ChezExpr -> ChezExpr
466124app f x = List [ f, x ]
467125
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
492127record r =
493128 let
494129 field :: Prop ChezExpr -> ChezExpr
@@ -496,7 +131,7 @@ record r =
496131 List
497132 [ Identifier $ scmPrefixed "hashtable-set!"
498133 , Identifier "$record"
499− , String $ Json.stringify $ Json.fromString k
134+ , StringExpr $ Json.stringify $ Json.fromString k
500135 , v
501136 ]
502137 in
@@ -518,29 +153,26 @@ quote :: ChezExpr -> ChezExpr
518153quote e = app (Identifier $ scmPrefixed "quote") e
519154
520155eqQ :: ChezExpr -> ChezExpr -> ChezExpr
521−eqQ x y = chezUncurriedApplication (Identifier $ scmPrefixed "eq?") [ x, y ]
522−
523−lambda :: Prim.String -> ChezExpr -> ChezExpr
524−lambda a e = List [ Identifier $ scmPrefixed "lambda", List [ Identifier a ], e ]
156+eqQ x y = runUncurriedFn (Identifier $ scmPrefixed "eq?") [ x, y ]
525157
526−vector :: Prim.Array ChezExpr -> ChezExpr
158+vector :: Array ChezExpr -> ChezExpr
527159vector = List <<< Array.cons (Identifier $ scmPrefixed "vector")
528160
529−recordTypeName :: Prim.String -> Prim.String
161+recordTypeName :: String -> String
530162recordTypeName i = i <> "$"
531163
532−recordTypeCurriedConstructor :: Prim.String -> Prim.String
164+recordTypeCurriedConstructor :: String -> String
533165recordTypeCurriedConstructor i = i
534166
535−recordTypeUncurriedConstructor :: Prim.String -> Prim.String
167+recordTypeUncurriedConstructor :: String -> String
536168recordTypeUncurriedConstructor i = i <> "*"
537169
538−recordTypePredicate :: Prim.String -> Prim.String
170+recordTypePredicate :: String -> String
539171recordTypePredicate i = i <> "?"
540172
541−recordTypeAccessor :: Prim.String -> Prim.String -> Prim.String
173+recordTypeAccessor :: String -> String -> String
542174recordTypeAccessor i field = i <> "-" <> field
543175
544−recordAccessor :: ChezExpr -> Prim.String -> Prim.String -> ChezExpr
176+recordAccessor :: ChezExpr -> String -> String -> ChezExpr
545177recordAccessor 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 @@
1010
1111 (scm:define testAccessorGetIndex
1212 (scm:lambda (v0)
13− (scm:cond ((scm:fx=? (scm:vector-length v0) 1) (scm:vector-ref v0 0)) (scm:else 0)))))
13+ (scm:cond
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 @@
1414 (scm:define i
1515 (scm:lambda (v0)
1616 (scm:lambda (v11)
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"))))))))
17+ (scm:cond
18+ [v0 (scm:not v11)]
19+ [(scm:not v11) #t]
20+ [v11 #f]
21+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))]))))
1822
1923 (scm:define h
2024 (scm:lambda (v0)
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")))))))
25+ (scm:cond
26+ [(scm:fl=? v0 3.14) 3.14159]
27+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))])))
2228
2329 (scm:define g
2430 (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])))
2636
2737 (scm:define f
2838 (scm:lambda (x0)
2939 (scm:lambda (y1)
3040 (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 @@
7878 (scm:define test5
7979 (scm:lambda (_)
8080 (scm:lambda (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"))))))))
81+ (scm:cond
82+ [(First? v1) (First-value0 v1)]
83+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))]))))
8284
8385 (scm:define test4
8486 (scm:lambda (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")))))))
87+ (scm:cond
88+ [(First? v0) (First-value0 v0)]
89+ [(Last? v0) (Last-value0 v0)]
90+ [scm:else (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "Failed pattern match")))])))
8691
8792 (scm:define test3
8893 (scm:lambda (v0)
89− (scm:cond ((scm:fx<? (HasArgs-value0 v0) (HasArgs-value2 v0)) (HasArgs-value0 v0)) (scm:else (HasArgs-value1 v0)))))
94+ (scm:cond
95+ [(scm:fx<? (HasArgs-value0 v0) (HasArgs-value2 v0)) (HasArgs-value0 v0)]
96+ [scm:else (HasArgs-value1 v0)])))
9097
9198 (scm:define test2
9299 (scm:lambda (v0)
test-snapshots/src/snapshots-output/Snapshot.Effect.ss+17−4
@@ -14,13 +14,26 @@
1414
1515 (scm:define dontInlineMe
1616 (scm:lambda (v0)
17− (scm:lambda () Data.Unit.unit)))
17+ (scm:lambda ()
18+ Data.Unit.unit)))
1819
1920 (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"))))))
2127
2228 (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))))
2435
2536 (scm:define main
26− (scm:lambda () (scm:let* ((_ (lastComponentIsRun))) (lastPureIsUnwrapped)))))
37+ (scm:lambda ()
38+ (scm:let ([_ (lastComponentIsRun)])
39+ (lastPureIsUnwrapped)))))
test-snapshots/src/snapshots-output/Snapshot.Let.ss+5−1
@@ -10,4 +10,8 @@
1010
1111 (scm:define letChain
1212 (scm:lambda (x0)
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))))))
13+ (scm:let*
14+ ([a1 (scm:fx+ x0 x0)]
15+ [b2 (scm:fx+ a1 a1)]
16+ [c3 (scm:fx+ b2 b2)])
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 @@
104104 (scm:string-append ((scm:hashtable-ref dictNormal0 "normal" #f) a2) ((scm:hashtable-ref dictNormal11 "normal" #f) b3)))))))
105105
106106 (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))
108112
109113 (scm:define useInstance
110114 "F1F2")
test-snapshots/src/snapshots-output/Snapshot.UncurriedFunction.ss+17−4
@@ -20,10 +20,15 @@
2020 (prefix (Test.Assert lib) Test.Assert.))
2121
2222 (scm:define test4a
23− (scm:lambda (a0) (scm:let* ((_1 (Effect.Console.log a0)) (_ (_1))) a0)))
23+ (scm:lambda (a0)
24+ (scm:let*
25+ ([_1 (Effect.Console.log a0)]
26+ [_ (_1)])
27+ a0)))
2428
2529 (scm:define test4b
26− (scm:lambda () (test4a "test4b")))
30+ (scm:lambda ()
31+ (test4a "test4b")))
2732
2833 (scm:define test3a
2934 (scm:lambda (v0 b1)
@@ -40,10 +45,18 @@
4045 (test2a 1 2))
4146
4247 (scm:define test1a
43− (Data.Function.Uncurried.mkFn0 (scm:lambda (v0) 1)))
48+ (Data.Function.Uncurried.mkFn0 (scm:lambda (v0)
49+ 1)))
4450
4551 (scm:define test1b
4652 (Data.Function.Uncurried.runFn0 test1a))
4753
4854 (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
4343import Partial.Unsafe (unsafeCrashWith)
4444import PureScript.Backend.Chez.Constants (moduleForeign, moduleLib, schemeExt)
4545import PureScript.Backend.Chez.Convert (codegenModule)
46+import PureScript.Backend.Chez.Printer as P
4647import PureScript.Backend.Chez.Runtime (runtimeModule)
47−import PureScript.Backend.Chez.Syntax as S
4848import PureScript.Backend.Optimizer.Builder (buildModules)
4949import PureScript.Backend.Optimizer.Convert (BackendModule)
5050import PureScript.Backend.Optimizer.CoreFn (Comment(..), Module(..), ModuleName(..))
@@ -99,7 +99,7 @@ runSnapshotTests { accept, filter } = do
9999 let runtimePath = Path.concat [ testOut, "_Chez_Runtime" ]
100100 mkdirp runtimePath
101101 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
103103 FS.writeTextFile UTF8 runtimeFilePath runtimeContents
104104 coreFnModulesFromOutput "output" filter >>= case _ of
105105 Left errors -> do
@@ -117,7 +117,7 @@ runSnapshotTests { accept, filter } = do
117117 let
118118 formatted =
119119 Dodo.print plainText Dodo.twoSpaces
120− $ S.printLibrary
120+ $ P.printLibrary
121121 $ codegenModule backend
122122 let testFileDir = Path.concat [ testOut, name ]
123123 let testFilePath = Path.concat [ testFileDir, moduleLib <> schemeExt ]