Skip to content

Commit a70b5dd

Browse files
brandonhamiltonpaf31
brandonhamilton
authored and
paf31
committed
Allow symbols in data contructors (purescript#2384)
* Allow symbols in data contructors * Accept bindings with data contructors containing symbols * Refactor identifier codegen to use common code * Update data constructor example
1 parent 427c2a2 commit a70b5dd

File tree

6 files changed

+63
-14
lines changed

6 files changed

+63
-14
lines changed

‎examples/passing/DctorName.purs‎

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
module Main where
2+
3+
import Prelude
4+
import Control.Monad.Eff.Console (log)
5+
6+
newtype Bar' = Bar' Int
7+
8+
data Foo' = Foo' Bar'
9+
10+
data Baz'' = Baz'' | Baz'
11+
12+
f ∷ Foo' → Boolean
13+
f a = case a of Foo' b → true
14+
15+
f' ∷ Boolean
16+
f' = f $ Foo' $ Bar' 0
17+
18+
g ∷ Baz'' → Int
19+
g Baz'' = 0
20+
g Baz' = 1
21+
22+
g' ∷ Int
23+
g' = g Baz''
24+
25+
h ∷ Bar' → Int
26+
h (Bar' x)
27+
| x <= 10 = x * 2
28+
| otherwise = 10
29+
30+
h' ∷ Int
31+
h' = h $ Bar' 4
32+
33+
main = log "Done"

‎src/Language/PureScript/CodeGen/JS.hs‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -244,23 +244,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
244244
ret <- valueToJs val
245245
return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []
246246
valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
247-
return $ JSVariableIntroduction Nothing ctor (Just $
247+
return $ JSVariableIntroduction Nothing (properToJs ctor) (Just $
248248
JSObjectLiteral Nothing [("create",
249249
JSFunction Nothing Nothing ["value"]
250250
(JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
251251
valueToJs' (Constructor _ _ (ProperName ctor) []) =
252-
return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])
253-
, JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))
254-
(JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]
252+
return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])
253+
, JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing (properToJs ctor)))
254+
(JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]
255255
valueToJs' (Constructor _ _ (ProperName ctor) fields) =
256256
let constructor =
257257
let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
258-
in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)
258+
in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
259259
createFn =
260-
let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)
260+
let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
261261
in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
262-
in return $ iife ctor [ constructor
263-
, JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn
262+
in return $ iife (properToJs ctor) [ constructor
263+
, JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn
264264
]
265265

266266
iife :: String -> [JS] -> JS

‎src/Language/PureScript/CodeGen/JS/Common.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,10 +26,13 @@ moduleNameToJs (ModuleName pns) =
2626
-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
2727
--
2828
identToJs :: Ident -> String
29-
identToJs (Ident name)
29+
identToJs (Ident name) = properToJs name
30+
identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
31+
32+
properToJs :: String -> String
33+
properToJs name
3034
| nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name
3135
| otherwise = concatMap identCharToString name
32-
identToJs (GenIdent _ _) = internalError "GenIdent in identToJs"
3336

3437
-- |
3538
-- Test if a string is a valid JS identifier without escaping.

‎src/Language/PureScript/Parser/Common.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,12 @@ properName = ProperName <$> uname
2828
typeName :: TokenParser (ProperName 'TypeName)
2929
typeName = ProperName <$> tyname
3030

31+
-- |
32+
-- Parse a proper name for a data constructor.
33+
--
34+
dataConstructorName :: TokenParser (ProperName 'ConstructorName)
35+
dataConstructorName = ProperName <$> dconsname
36+
3137
-- |
3238
-- Parse a module name
3339
--

‎src/Language/PureScript/Parser/Declarations.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -71,7 +71,7 @@ parseDataDeclaration = do
7171
tyArgs <- many (indented *> kindedIdent)
7272
ctors <- P.option [] $ do
7373
indented *> equals
74-
P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
74+
P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
7575
return $ DataDeclaration dtype name tyArgs ctors
7676

7777
parseTypeDeclaration :: TokenParser Declaration
@@ -360,7 +360,7 @@ parseVar :: TokenParser Expr
360360
parseVar = Var <$> C.parseQualified C.parseIdent
361361

362362
parseConstructor :: TokenParser Expr
363-
parseConstructor = Constructor <$> C.parseQualified C.properName
363+
parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName
364364

365365
parseCase :: TokenParser Expr
366366
parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue)
@@ -494,10 +494,10 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)
494494
<|> return id
495495

496496
parseNullaryConstructorBinder :: TokenParser Binder
497-
parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
497+
parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure []
498498

499499
parseConstructorBinder :: TokenParser Binder
500-
parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
500+
parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens)
501501

502502
parseObjectBinder:: TokenParser Binder
503503
parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)

‎src/Language/PureScript/Parser/Lexer.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ module Language.PureScript.Parser.Lexer
4343
, lname'
4444
, qualifier
4545
, tyname
46+
, dconsname
4647
, uname
4748
, uname'
4849
, mname
@@ -452,6 +453,12 @@ tyname = token go P.<?> "type name"
452453
go (UName s) = Just s
453454
go _ = Nothing
454455

456+
dconsname :: TokenParser String
457+
dconsname = token go P.<?> "data constructor name"
458+
where
459+
go (UName s) = Just s
460+
go _ = Nothing
461+
455462
mname :: TokenParser String
456463
mname = token go P.<?> "module name"
457464
where

0 commit comments

Comments
 (0)