@@ -0,0 +1,115 @@
1+module PureScript.Backend.Chez.Convert where
2+
3+import Prelude
4+
5+import Data.Argonaut as Json
6+import Data.Array as A
7+import Data.Array as Array
8+import Data.Array.NonEmpty as NEA
9+import Data.Array.NonEmpty as NonEmptyArray
10+import Data.Maybe (Maybe(..))
11+import Data.Newtype (wrap)
12+import Data.Profunctor.Strong (second)
13+import Data.String.CodeUnits as CodeUnits
14+import Data.Tuple (Tuple, uncurry)
15+import Partial.Unsafe (unsafeCrashWith)
16+import PureScript.Backend.Chez.Syntax (ChezExpr)
17+import PureScript.Backend.Chez.Syntax as S
18+import PureScript.Backend.Optimizer.Convert (BackendModule, BackendBindingGroup)
19+import PureScript.Backend.Optimizer.CoreFn (Ident(..), Literal(..), ModuleName(..), Qualified(..))
20+import PureScript.Backend.Optimizer.Semantics (NeutralExpr(..))
21+import PureScript.Backend.Optimizer.Syntax (BackendSyntax(..))
22+import Safe.Coerce (coerce)
23+
24+codegenModule :: BackendModule -> ChezExpr
25+codegenModule { name, bindings, exports } =
26+ let
27+ name' :: String
28+ name' = coerce name
29+
30+ exports' :: Array String
31+ exports' = coerce $ A.fromFoldable exports
32+
33+ bindings' :: Array ChezExpr
34+ bindings' = Array.concat $ codegenTopLevelBindingGroup <$> bindings
35+ in
36+ S.library name' exports' bindings'
37+
38+codegenTopLevelBindingGroup :: BackendBindingGroup Ident NeutralExpr -> Array ChezExpr
39+codegenTopLevelBindingGroup { recursive, bindings }
40+ | recursive, Just bindings' <- NonEmptyArray.fromArray bindings = unsafeCrashWith "undefined"
41+ | otherwise = codegenBindings bindings
42+
43+codegenBindings :: Array (Tuple Ident NeutralExpr) -> Array ChezExpr
44+codegenBindings = map (coerce $ uncurry S.define) <<< map (second go)
45+ where
46+ go :: NeutralExpr -> ChezExpr
47+ go (NeutralExpr s) = case s of
48+ Var (Qualified (Just (ModuleName mn)) (Ident v)) ->
49+ S.Identifier $ mn <> "." <> v
50+ Var (Qualified _ (Ident v)) ->
51+ S.Identifier v
52+ Local _ _ ->
53+ S.Identifier "local-variable"
54+
55+ Lit l ->
56+ codegenLiteral l
57+
58+ App f p ->
59+ NEA.foldl1 S.app $ NEA.cons (go f) (go <$> p)
60+ Abs _ _ ->
61+ S.Identifier "abs"
62+
63+ UncurriedApp _ _ ->
64+ S.Identifier "uncurried-app"
65+ UncurriedAbs _ _ ->
66+ S.Identifier "uncurried-abs"
67+
68+ UncurriedEffectApp _ _ ->
69+ S.Identifier "uncurried-effect-app"
70+ UncurriedEffectAbs _ _ ->
71+ S.Identifier "uncurried-effect-ab"
72+
73+ Accessor _ _ ->
74+ S.Identifier "object-accessor"
75+ Update _ _ ->
76+ S.Identifier "object-update"
77+
78+ CtorSaturated _ _ _ _ _ ->
79+ S.Identifier "ctor-saturated"
80+ CtorDef _ _ _ _ ->
81+ S.Identifier "ctor-def"
82+
83+ LetRec _ _ _ ->
84+ S.Identifier "let-rec"
85+ Let _ _ _ _ ->
86+ S.Identifier "let"
87+ Branch _ _ ->
88+ S.Identifier "branch"
89+
90+ EffectBind _ _ _ _ ->
91+ S.Identifier "effect-bind"
92+ EffectPure _ ->
93+ S.Identifier "effect-pure"
94+ EffectDefer _ ->
95+ S.Identifier "effect-defer"
96+
97+ PrimOp _ ->
98+ S.Identifier "prim-op"
99+ PrimEffect _ ->
100+ S.Identifier "prim-effect"
101+ PrimUndefined ->
102+ S.Identifier "prim-undefined"
103+
104+ Fail _ ->
105+ S.Identifier "fail"
106+
107+codegenLiteral :: forall a. Literal a -> ChezExpr
108+codegenLiteral = case _ of
109+ LitInt i -> S.Integer $ wrap $ show i
110+ LitNumber n -> S.Float $ wrap $ show n
111+ LitString s -> S.String $ Json.stringify $ Json.fromString s
112+ LitChar c -> S.Identifier $ "#\\" <> CodeUnits.singleton c
113+ LitBoolean b -> S.Identifier $ if b then "#t" else "#f"
114+ LitArray _ -> S.Identifier "literal-array"
115+ LitRecord _ -> S.Identifier "literal-object"