Skip to content

Commit 765aeb4

Browse files
no-longer-on-githu-bpaf31
no-longer-on-githu-b
authored and
paf31
committed
Add --dump-corefn command line option (purescript#2275)
* Add --dump-corefn command line option * Derive ToJSON instances for CoreFn * Revert "Derive ToJSON instances for CoreFn" This reverts commit 96bbd1f. * Add rightfold to contributors list and license to their contributions * Implement typeToJSON * Implement kindToJSON * Implement missing JSON converters needed for typeToJSON * Implement annToJSON * License under MIT instead of BSD * Add PureScript version to JSON CoreFn dump * Use internalError instead of error * Clarify --dump-corefn option * Add Haddock comment to CoreFn.ToJSON, and export fewer functions * Remove types from CoreFn dump * Remove source spans from CoreFn dump * Simplify CoreFn dump of product types * More descriptive type tags for int and float literals * Smaller core JSON * Bits * Add back data constructor names for Var and VarBinder * Keep Rec/NoRec info in core AST
1 parent 8197c06 commit 765aeb4

File tree

6 files changed

+137
-1
lines changed

6 files changed

+137
-1
lines changed

‎CONTRIBUTORS.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
6464
- [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
6565
- [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
6666
- [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler.
67+
- [@rightfold](https://github.com/rightfold) (rightfold) My existing contributions and all future contributions until further notice are Copyright rightfold, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](https://opensource.org/licenses/MIT).
6768
- [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
6869
- [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
6970
- [@rvion](https://github.com/rvion) (Rémi Vion) My existing contributions and all future contributions until further notice are Copyright Rémi Vion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

‎psc/Main.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -143,6 +143,11 @@ sourceMaps = switch $
143143
long "source-maps"
144144
<> help "Generate source maps"
145145

146+
dumpCoreFn :: Parser Bool
147+
dumpCoreFn = switch $
148+
long "dump-corefn"
149+
<> help "Dump the (functional) core representation of the compiled code at output/*/corefn.json"
150+
146151

147152
options :: Parser P.Options
148153
options = P.Options <$> noTco
@@ -152,6 +157,7 @@ options = P.Options <$> noTco
152157
<*> verboseErrors
153158
<*> (not <$> comments)
154159
<*> sourceMaps
160+
<*> dumpCoreFn
155161

156162
pscMakeOptions :: Parser PSCMakeOptions
157163
pscMakeOptions = PSCMakeOptions <$> many inputFile

‎purescript.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -180,6 +180,7 @@ library
180180
Language.PureScript.CoreFn.Meta
181181
Language.PureScript.CoreFn.Module
182182
Language.PureScript.CoreFn.Traversals
183+
Language.PureScript.CoreFn.ToJSON
183184
Language.PureScript.Comments
184185
Language.PureScript.Environment
185186
Language.PureScript.Errors

‎src/Language/PureScript/CoreFn/ToJSON.hs‎

Lines changed: 116 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,116 @@
1+
-- |
2+
-- Dump the core functional representation in JSON format for consumption
3+
-- by third-party code generators
4+
--
5+
module Language.PureScript.CoreFn.ToJSON
6+
( moduleToJSON
7+
) where
8+
9+
import Prelude.Compat
10+
11+
import Data.Aeson
12+
import Data.Version (Version, showVersion)
13+
import Data.Text (pack)
14+
15+
import Language.PureScript.AST.Literals
16+
import Language.PureScript.CoreFn
17+
import Language.PureScript.Names
18+
19+
literalToJSON :: (a -> Value) -> Literal a -> Value
20+
literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n)
21+
literalToJSON _ (NumericLiteral (Right n)) = toJSON ("NumberLiteral", n)
22+
literalToJSON _ (StringLiteral s) = toJSON ("StringLiteral", s)
23+
literalToJSON _ (CharLiteral c) = toJSON ("CharLiteral", c)
24+
literalToJSON _ (BooleanLiteral b) = toJSON ("BooleanLiteral", b)
25+
literalToJSON t (ArrayLiteral xs) = toJSON ("ArrayLiteral", map t xs)
26+
literalToJSON t (ObjectLiteral xs) = toJSON ("ObjectLiteral", recordToJSON t xs)
27+
28+
identToJSON :: Ident -> Value
29+
identToJSON = toJSON . runIdent
30+
31+
properNameToJSON :: ProperName a -> Value
32+
properNameToJSON = toJSON . runProperName
33+
34+
qualifiedToJSON :: (a -> String) -> Qualified a -> Value
35+
qualifiedToJSON f = toJSON . showQualified f
36+
37+
moduleNameToJSON :: ModuleName -> Value
38+
moduleNameToJSON = toJSON . runModuleName
39+
40+
moduleToJSON :: Version -> Module a -> Value
41+
moduleToJSON v m = object [ pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m)
42+
, pack "exports" .= map identToJSON (moduleExports m)
43+
, pack "foreign" .= map (identToJSON . fst) (moduleForeign m)
44+
, pack "decls" .= map bindToJSON (moduleDecls m)
45+
, pack "builtWith" .= toJSON (showVersion v)
46+
]
47+
48+
bindToJSON :: Bind a -> Value
49+
bindToJSON (NonRec _ n e) = object [ pack (runIdent n) .= exprToJSON e ]
50+
bindToJSON (Rec bs) = object $ map (\((_, n), e) -> pack (runIdent n) .= exprToJSON e) bs
51+
52+
recordToJSON :: (a -> Value) -> [(String, a)] -> Value
53+
recordToJSON f = object . map (\(label, a) -> pack label .= f a)
54+
55+
exprToJSON :: Expr a -> Value
56+
exprToJSON (Var _ i) = toJSON ( "Var"
57+
, qualifiedToJSON runIdent i
58+
)
59+
exprToJSON (Literal _ l) = toJSON ( "Literal"
60+
, literalToJSON (exprToJSON) l
61+
)
62+
exprToJSON (Constructor _ d c is) = toJSON ( "Constructor"
63+
, properNameToJSON d
64+
, properNameToJSON c
65+
, map identToJSON is
66+
)
67+
exprToJSON (Accessor _ f r) = toJSON ( "Accessor"
68+
, f
69+
, exprToJSON r
70+
)
71+
exprToJSON (ObjectUpdate _ r fs) = toJSON ( "ObjectUpdate"
72+
, exprToJSON r
73+
, recordToJSON exprToJSON fs
74+
)
75+
exprToJSON (Abs _ p b) = toJSON ( "Abs"
76+
, identToJSON p
77+
, exprToJSON b
78+
)
79+
exprToJSON (App _ f x) = toJSON ( "App"
80+
, exprToJSON f
81+
, exprToJSON x
82+
)
83+
exprToJSON (Case _ ss cs) = toJSON ( "Case"
84+
, map exprToJSON ss
85+
, map caseAlternativeToJSON cs
86+
)
87+
exprToJSON (Let _ bs e) = toJSON ( "Let"
88+
, map bindToJSON bs
89+
, exprToJSON e
90+
)
91+
92+
caseAlternativeToJSON :: CaseAlternative a -> Value
93+
caseAlternativeToJSON (CaseAlternative bs r') =
94+
toJSON [ toJSON (map binderToJSON bs)
95+
, case r' of
96+
Left rs -> toJSON $ map (\(g, e) -> (exprToJSON g, exprToJSON e)) rs
97+
Right r -> exprToJSON r
98+
]
99+
100+
binderToJSON :: Binder a -> Value
101+
binderToJSON (VarBinder _ v) = toJSON ( "VarBinder"
102+
, identToJSON v
103+
)
104+
binderToJSON (NullBinder _) = toJSON "NullBinder"
105+
binderToJSON (LiteralBinder _ l) = toJSON ( "LiteralBinder"
106+
, literalToJSON binderToJSON l
107+
)
108+
binderToJSON (ConstructorBinder _ d c bs) = toJSON ( "ConstructorBinder"
109+
, qualifiedToJSON runProperName d
110+
, qualifiedToJSON runProperName c
111+
, map binderToJSON bs
112+
)
113+
binderToJSON (NamedBinder _ n b) = toJSON ( "NamedBinder"
114+
, identToJSON n
115+
, binderToJSON b
116+
)

‎src/Language/PureScript/Make.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
22
{-# LANGUAGE TypeFamilies #-}
3+
{-# LANGUAGE OverloadedStrings #-}
34

45
module Language.PureScript.Make
56
(
@@ -36,6 +37,7 @@ import Control.Monad.Trans.Except
3637
import Control.Monad.Writer.Class (MonadWriter(..))
3738

3839
import Data.Aeson (encode, decode)
40+
import qualified Data.Aeson as Aeson
3941
import Data.ByteString.Builder (toLazyByteString, stringUtf8)
4042
import Data.Either (partitionEithers)
4143
import Data.Foldable (for_)
@@ -69,6 +71,7 @@ import qualified Language.PureScript.Bundle as Bundle
6971
import qualified Language.PureScript.CodeGen.JS as J
7072
import qualified Language.PureScript.Constants as C
7173
import qualified Language.PureScript.CoreFn as CF
74+
import qualified Language.PureScript.CoreFn.ToJSON as CFJ
7275
import qualified Language.PureScript.Parser as PSParser
7376

7477
import qualified Paths_purescript as Paths
@@ -369,6 +372,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
369372
for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
370373
writeTextFile externsFile exts
371374
lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
375+
dumpCoreFn <- lift $ asks optionsDumpCoreFn
376+
when dumpCoreFn $ do
377+
let coreFnFile = outputDir </> filePath </> "corefn.json"
378+
let jsonPayload = CFJ.moduleToJSON Paths.version m
379+
let json = Aeson.object [ (fromString (runModuleName mn), jsonPayload) ]
380+
lift $ writeTextFile coreFnFile (BU8.toString . B.toStrict . encode $ json)
372381

373382
genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
374383
genSourceMap dir mapFile extraLines mappings = do

‎src/Language/PureScript/Options.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -31,9 +31,12 @@ data Options = Options {
3131
-- |
3232
-- Generate soure maps
3333
, optionsSourceMaps :: Bool
34+
-- |
35+
-- Dump CoreFn
36+
, optionsDumpCoreFn :: Bool
3437
} deriving Show
3538

3639
-- |
3740
-- Default make options
3841
defaultOptions :: Options
39-
defaultOptions = Options False False Nothing False False False False
42+
defaultOptions = Options False False Nothing False False False False False

0 commit comments

Comments
 (0)