@@ -49,10 +49,16 @@ data CGStats = CGStats { usedWriteStr :: Bool
4949 , usedReadStr :: Bool
5050 , usedBigInt :: Bool
5151 , partialApplications :: Set Partial
52+ , hiddenClasses :: Set HiddenClass
5253 }
5354
5455emptyStats :: CGStats
55−emptyStats = CGStats {usedWriteStr = False, partialApplications = Set.empty, usedBigInt = False, usedReadStr = False}
56+emptyStats = CGStats { usedWriteStr = False
57+ , partialApplications = Set.empty
58+ , hiddenClasses = Set.empty
59+ , usedBigInt = False
60+ , usedReadStr = False
61+ }
5662
5763data CGConf = CGConf { header :: Text
5864 , footer :: Text
@@ -112,6 +118,7 @@ codegenJs conf ci =
112118 , jsbn
113119 , initialization conf stats
114120 , doPartials (partialApplications stats)
121+ , doHiddenClasses (hiddenClasses stats)
115122 , includes, "\n"
116123 , runtimeCommon, "\n"
117124 , extraRT, "\n"
@@ -133,11 +140,22 @@ doPartials x =
133140 JsFun (jsNamePartial p) vars1 $ JsReturn $
134141 jsCurryLam vars2 (jsAppN (jsName n) (map JsVar (vars1 ++ vars2)) )
135142
143+doHiddenClasses :: Set HiddenClass -> Text
144+doHiddenClasses x =
145+ T.intercalate "\n" (map f $ Set.toList x)
146+ where
147+ f p@(HiddenClass n id arity) =
148+ let vars = map dataPartName $ take arity [1..]
149+ in jsStmt2Text $
150+ JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs
151+ $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars
152+
136153doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)
137154doCodegen conf defs decls =
138155 let xs = map (doCodegenDecl conf defs) decls
139156 groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y
140157 , partialApplications = partialApplications x `Set.union` partialApplications y
158+ , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
141159 , usedBigInt = usedBigInt x || usedBigInt y
142160 , usedReadStr = usedReadStr x || usedReadStr y
143161 }
@@ -165,6 +183,7 @@ data CGBodyState = CGBodyState { defs :: Map Name LDecl
165183 , usedRead :: Bool
166184 , usedITBig :: Bool
167185 , partialApps :: Set Partial
186+ , hiddenCls :: Set HiddenClass
168187 }
169188
170189getNewCGName :: State CGBodyState Text
@@ -179,6 +198,10 @@ addPartial :: Partial -> State CGBodyState ()
179198addPartial p =
180199 modify (\s -> s {partialApps = Set.insert p (partialApps s) })
181200
201+addHiddenClass :: HiddenClass -> State CGBodyState ()
202+addHiddenClass p =
203+ modify (\s -> s {hiddenCls = Set.insert p (hiddenCls s) })
204+
182205addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()
183206addUsedArgsTailCallOptim p =
184207 modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })
@@ -226,12 +249,14 @@ cgFun cnf dfs n args def = do
226249 , usedRead = False
227250 , usedITBig = False
228251 , partialApps = Set.empty
252+ , hiddenCls = Set.empty
229253 }
230254 )
231255 let body = if isTailRec st then JsSeq (declareUsedOptimArgs $ usedArgsTailCallOptim st) (JsForever ((seqJs decs) `JsSeq` res)) else (seqJs decs) `JsSeq` res
232256 let fn = JsFun fnName argNames body
233257 let state' = CGStats { usedWriteStr = usedWrite st
234258 , partialApplications = partialApps st
259+ , hiddenClasses = hiddenCls st
235260 , usedBigInt = usedITBig st
236261 , usedReadStr = usedRead st
237262 }
@@ -281,12 +306,36 @@ cgBody rt expr =
281306 | (ff == qualifyN "Prelude.Bool" "False" &&
282307 tt == qualifyN "Prelude.Bool" "True") ->
283308 case (Map.lookup oper primDB) of
284− Just (useBigInt, pti, combinator) | pti == PTBool -> do
309+ Just (needBI, pti, c) | pti == PTBool -> do
285310 z <- mapM (cgBody GetExpBT) [x, y]
286− when useBigInt setUsedITBig
287− let res = jsPrimCoerce pti PTBool $ combinator $ map (jsStmt2Expr . snd) z
311+ when needBI setUsedITBig
312+ let res = jsPrimCoerce pti PTBool $ c $ map (jsStmt2Expr . snd) z
288313 pure $ (concat $ map fst z, addRT rt res)
289314 _ -> cgBody' rt expr
315+ (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LDefaultCase (LCon _ _ ff [])])
316+ | (ff == qualifyN "Prelude.Bool" "False" &&
317+ tt == qualifyN "Prelude.Bool" "True") -> do
318+ (d, v) <- cgBody GetExpBT e
319+ test <- formConTest n (jsStmt2Expr v)
320+ pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
321+ (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LConCase _ _ _ (LCon _ _ ff [])])
322+ | (ff == qualifyN "Prelude.Bool" "False" &&
323+ tt == qualifyN "Prelude.Bool" "True") -> do
324+ (d, v) <- cgBody GetExpBT e
325+ test <- formConTest n (jsStmt2Expr v)
326+ pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
327+ (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])
328+ | (ff == qualifyN "Prelude.Bool" "False" &&
329+ tt == qualifyN "Prelude.Bool" "True") -> do
330+ (d, v) <- cgBody GetExpBT e
331+ test <- formConTest n (jsStmt2Expr v)
332+ pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
333+ (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LConCase _ _ _ (LCon _ _ tt [])])
334+ | (ff == qualifyN "Prelude.Bool" "False" &&
335+ tt == qualifyN "Prelude.Bool" "True") -> do
336+ (d, v) <- cgBody GetExpBT e
337+ test <- formConTest n (jsStmt2Expr v)
338+ pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
290339 (LCase f e [LConCase nf ff [] alt, LConCase nt tt [] conseq])
291340 | (ff == qualifyN "Prelude.Bool" "False" &&
292341 tt == qualifyN "Prelude.Bool" "True") ->
@@ -328,8 +377,9 @@ cgBody' rt (LApp tailcall (LV (Glob fn)) args) =
328377 do
329378 argsFn <- getArgList fn
330379 case argsFn of
331− Nothing ->
332− pure (preDecs, addRT rt $ jsCurryApp (JsVar fname) argVals )
380+ Nothing -> do
381+ fn' <- cgName fn
382+ pure (preDecs, addRT rt $ jsCurryApp fn' argVals )
333383 Just agFn ->
334384 do
335385 let lenAgFn = length agFn
@@ -428,10 +478,10 @@ formCon n args = do
428478 Nothing -> do
429479 (conId, arity) <- getConsId n
430480 if (arity > 0)
431− then pure $
432− JsObj $
433− (T.pack "type", JsInt conId) :
434− zip (map (\i -> T.pack $ "$" ++ show i) [1 ..]) args
481+ then do
482+ let hc = HiddenClass n conId arity
483+ addHiddenClass hc
484+ pure $ JsNew (JsVar $ jsNameHiddenClass hc) args
435485 else pure $ JsInt conId
436486
437487formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
@@ -448,12 +498,21 @@ formProj :: Name -> JsExpr -> Int -> JsExpr
448498formProj n v i =
449499 case specialCased n of
450500 Just (ctor, test, proj) -> proj v i
451− Nothing -> JsProp v (T.pack $ "$" ++ show i)
501+ Nothing -> JsProp v (dataPartName i)
452502
453503smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
454504smartif cond conseq (Just alt) = JsIf cond conseq (Just alt)
455505smartif cond conseq Nothing = conseq
456506
507+formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr
508+formConstTest scrvar t = case t of
509+ BI _ -> do
510+ t' <- cgConst t
511+ cgOp' PTBool (LEq (ATInt ITBig)) [scrvar, t']
512+ _ -> do
513+ t' <- cgConst t
514+ pure $ JsBinOp "===" scrvar t'
515+
457516cgIfTree :: BodyResTarget
458517 -> Text
459518 -> JsExpr
@@ -463,13 +522,7 @@ cgIfTree _ _ _ [] = pure Nothing
463522cgIfTree rt resName scrvar ((LConstCase t exp):r) = do
464523 (d, v) <- cgBody (altsRT resName rt) exp
465524 alternatives <- cgIfTree rt resName scrvar r
466− test <- case t of
467− BI _ -> do
468− t' <- cgConst t
469− cgOp (LPlus (ATInt ITBig)) [scrvar, t']
470− _ -> do
471− t' <- cgConst t
472− pure $ JsBinOp "===" scrvar t'
525+ test <- formConstTest scrvar t
473526 pure $ Just $
474527 smartif test (JsSeq (seqJs d) v) alternatives
475528cgIfTree rt resName scrvar ((LDefaultCase exp):r) = do
@@ -547,24 +600,24 @@ cgConst (B64 x) =
547600cgConst x | isTypeConst x = pure $ JsInt 0
548601cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"
549602
550−jsB2I :: JsExpr -> JsExpr
551−jsB2I x = JsForeign "%0 ? 1|0 : 0|0" [x]
552−
553603cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
554−cgOp LReadStr [_] =
604+cgOp = cgOp' PTAny
605+
606+cgOp' :: JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
607+cgOp' pt LReadStr [_] =
555608 do
556609 s <- get
557610 put $ s {usedRead = True}
558611 pure $ JsForeign (readStrTemplate $ conf s) []
559−cgOp LWriteStr [_,str] =
612+cgOp' pt LWriteStr [_,str] =
560613 do
561614 s <- get
562615 put $ s {usedWrite = True}
563616 pure $ JsForeign (writeStrTemplate $ conf s) [str]
564−cgOp (LExternal name) _ | name == sUN "prim__null" = pure JsNull
565−cgOp (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r
566−cgOp op exps = case Map.lookup op primDB of
617+cgOp' pt (LExternal name) _ | name == sUN "prim__null" = pure JsNull
618+cgOp' pt (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r
619+cgOp' pt op exps = case Map.lookup op primDB of
567620 Just (useBigInt, pti, combinator) -> do
568621 when useBigInt setUsedITBig
569− pure $ jsPrimCoerce pti PTAny $ combinator exps
622+ pure $ jsPrimCoerce pti pt $ combinator exps
570623 Nothing -> error ("Operator " ++ show (op, exps) ++ " not implemented")