@@ -25,10 +25,12 @@ import IRTS.System
2525
2626import Control.Monad
2727import Control.Monad.Trans.State
28+import Data.Foldable (foldMap)
2829import Data.List (nub)
2930import Data.Map.Strict (Map)
3031import qualified Data.Map.Strict as Map
3132import Data.Maybe (fromJust)
33+import Data.Monoid
3234import Data.Set (Set)
3335import qualified Data.Set as Set
3436import Data.Text (Text)
@@ -45,16 +47,26 @@ import Data.Generics.Uniplate.Data
4547import Data.List
4648import GHC.Generics (Generic)
4749
50+-- | Code generation stats hold information about the generated user
51+-- code. Based on that information we add additional code to make
52+-- things work.
4853data CGStats = CGStats { usedBigInt :: Bool
4954 , partialApplications :: Set Partial
5055 , hiddenClasses :: Set HiddenClass
5156 }
5257
53−emptyStats :: CGStats
54−emptyStats = CGStats { partialApplications = Set.empty
55− , hiddenClasses = Set.empty
56− , usedBigInt = False
57− }
58+-- If we generate code for two declarations we want to merge their code
59+-- generation stats.
60+instance Monoid CGStats where
61+ mempty = CGStats { partialApplications = Set.empty
62+ , hiddenClasses = Set.empty
63+ , usedBigInt = False
64+ }
65+ mappend x y = CGStats { partialApplications = partialApplications x `Set.union` partialApplications y
66+ , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
67+ , usedBigInt = usedBigInt x || usedBigInt y
68+ }
69+
5870
5971data CGConf = CGConf { header :: Text
6072 , footer :: Text
@@ -101,11 +113,9 @@ codegenJs conf ci =
101113 let defs' = Map.fromList $ liftDecls ci
102114 let defs = globlToCon defs'
103115 let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
104− if debug then
105− do
116+ when debug $ do
106117 writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"
107118 putStrLn $ "Finished calculating used"
108− else pure ()
109119
110120 let (out, stats) = doCodegen conf defs used
111121
@@ -160,20 +170,21 @@ doHiddenClasses x =
160170 JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs
161171 $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars
162172
173+
174+-- | Generate code for each declaration and collect stats.
175+-- LFunctions are turned into JS function declarations. They are
176+-- preceded by a comment that gives their name. Constructor
177+-- declarations are ignored.
163178doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)
164−doCodegen conf defs decls =
165− let xs = map (doCodegenDecl conf defs) decls
166− groupCGStats x y = CGStats { partialApplications = partialApplications x `Set.union` partialApplications y
167− , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
168− , usedBigInt = usedBigInt x || usedBigInt y
169− }
170− in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )
171−
172−doCodegenDecl :: CGConf -> Map Name LDecl -> LDecl -> (Text, CGStats)
173−doCodegenDecl conf defs (LFun _ n args def) =
174− let (ast, stats) = cgFun conf defs n args def
175− in (T.concat [jsStmt2Text (JsComment $ T.pack $ show n), "\n", jsStmt2Text ast], stats)
176−doCodegenDecl conf defs (LConstructor n i sz) = ("", emptyStats)
179+doCodegen conf defs decls = foldMap (doCodegenDecl conf defs) decls
180+ where
181+ doCodegenDecl :: CGConf -> Map Name LDecl -> LDecl -> (Text, CGStats)
182+ doCodegenDecl conf defs (LFun _ name args def) =
183+ let (ast, stats) = cgFun conf defs name args def
184+ fnComment = jsStmt2Text (JsComment $ T.pack $ show name)
185+ in (T.concat [fnComment, "\n", jsStmt2Text ast, "\n"], stats)
186+ doCodegenDecl conf defs (LConstructor n i sz) = ("", mempty)
187+
177188
178189seqJs :: [JsStmt] -> JsStmt
179190seqJs [] = JsEmpty