@@ -12,14 +12,17 @@
1212--
1313-----------------------------------------------------------------------------
1414
15+{-# LANGUAGE DoAndIfThenElse #-}
16+
1517module Language.PureScript.CodeGen.JS (
1618 module AST,
1719 declToJs,
1820 moduleToJs
1921) where
2022
21−import Data.Maybe (mapMaybe)
23+import Data.Maybe (fromMaybe, mapMaybe)
2224import Data.List (sortBy)
25+import Data.Function (on)
2326
2427import Control.Arrow (second)
2528import Control.Monad (replicateM, forM)
@@ -184,12 +187,23 @@ binderToJs _ _ varName done (BooleanBinder False) =
184187 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
185188binderToJs _ _ varName done (VarBinder ident) =
186189 return (JSVariableIntroduction ident (Just (JSVar varName)) : done)
187−binderToJs m _ varName done (NullaryBinder ctor) =
188− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
190+binderToJs m e varName done (NullaryBinder ctor) =
191+ if isOnlyConstructor m e ctor
192+ then
193+ return done
194+ else
195+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
189196binderToJs m e varName done (UnaryBinder ctor b) = do
190197 value <- fresh
191198 js <- binderToJs m e value done b
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]
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
204+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor))))
205+ success
206+ Nothing]
193207binderToJs m e varName done (ObjectBinder bs) = go done bs
194208 where
195209 go :: [JS] -> [(String, Binder)] -> Gen [JS]
@@ -224,6 +238,18 @@ binderToJs m e varName done (NamedBinder ident binder) = do
224238 js <- binderToJs m e varName done binder
225239 return (JSVariableIntroduction ident (Just (JSVar varName)) : js)
226240
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+
227253statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS
228254statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
229255statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)