git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Don't check constructor name if there is only one constructor #85
139d308Phil Freeman
examples/passing/OneConstructor.pursnew file+5
compare with golang
unifiedsplit
@@ -0,0 +1,5 @@
1+module OneConstructor where
2+
3+data One a = One a
4+
5+one (One a) = a
src/Language/PureScript/CodeGen/JS.hs+30−4
@@ -12,14 +12,17 @@
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15+{-# LANGUAGE DoAndIfThenElse #-}
16+
15module Language.PureScript.CodeGen.JS (
17module Language.PureScript.CodeGen.JS (
16 module AST,
18 module AST,
17 declToJs,
19 declToJs,
18 moduleToJs
20 moduleToJs
19) where
21) where
20
22
21−import Data.Maybe (mapMaybe)
23+import Data.Maybe (fromMaybe, mapMaybe)
22import Data.List (sortBy)
24import Data.List (sortBy)
25+import Data.Function (on)
23
26
24import Control.Arrow (second)
27import Control.Arrow (second)
25import Control.Monad (replicateM, forM)
28import Control.Monad (replicateM, forM)
@@ -184,12 +187,23 @@ binderToJs _ _ varName done (BooleanBinder False) =
184 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
187 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
185binderToJs _ _ varName done (VarBinder ident) =
188binderToJs _ _ varName done (VarBinder ident) =
186 return (JSVariableIntroduction ident (Just (JSVar varName)) : done)
189 return (JSVariableIntroduction ident (Just (JSVar varName)) : done)
187−binderToJs m _ varName done (NullaryBinder ctor) =
190+binderToJs m e varName done (NullaryBinder ctor) =
191+ if isOnlyConstructor m e ctor
192+ then
193+ return done
194+ else
188− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
195+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
189binderToJs m e varName done (UnaryBinder ctor b) = do
196binderToJs m e varName done (UnaryBinder ctor b) = do
190 value <- fresh
197 value <- fresh
191 js <- binderToJs m e value done b
198 js <- binderToJs m e value done b
199+ let success = JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)
200+ if isOnlyConstructor m e ctor
201+ then
202+ return [success]
203+ else
192− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)) Nothing]
204+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor))))
205+ success
206+ Nothing]
193binderToJs m e varName done (ObjectBinder bs) = go done bs
207binderToJs m e varName done (ObjectBinder bs) = go done bs
194 where
208 where
195 go :: [JS] -> [(String, Binder)] -> Gen [JS]
209 go :: [JS] -> [(String, Binder)] -> Gen [JS]
@@ -224,6 +238,18 @@ binderToJs m e varName done (NamedBinder ident binder) = do
224 js <- binderToJs m e varName done binder
238 js <- binderToJs m e varName done binder
225 return (JSVariableIntroduction ident (Just (JSVar varName)) : js)
239 return (JSVariableIntroduction ident (Just (JSVar varName)) : js)
226
240
241+isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool
242+isOnlyConstructor m e ctor =
243+ let (ty, _) = fromMaybe (error "Data constructor not found") $ qualify m ctor `M.lookup` dataConstructors e
244+ in numConstructors ty == 1
245+ where
246+ numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e
247+ typeConstructor (TypeConstructor qual) = qualify m qual
248+ typeConstructor (ForAll _ ty) = typeConstructor ty
249+ typeConstructor (Function _ ty) = typeConstructor ty
250+ typeConstructor (TypeApp ty _) = typeConstructor ty
251+ typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
252+
227statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS
253statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS
228statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
254statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
229statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)
255statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)