Clean up and simplify main interface for Stack2JS.hs

Author: ssoelvsten

compiler/app/Main.hs

@@ -14,10 +14,9 @@ import qualified IR as CCIR
 import qualified IROpt
 -- import qualified RetRewrite as Rewrite
 import qualified CPSOpt as CPSOpt
-import qualified IR2JS
 import qualified IR2Raw
--- import qualified Stack 
 import qualified Raw2Stack
+import qualified Stack
 import qualified Stack2JS
 import qualified RawOpt
 -- import System.IO (isEOF)
@@ -77,6 +76,7 @@ process flags fname input = do
 
   let verbose = Verbose `elem` flags
       noRawOpt = NoRawOpt `elem` flags
+      debugJS = Debug `elem` flags
 
   case ast of
     Left err -> do
@@ -161,7 +161,9 @@ process flags fname input = do
       when verbose $ writeFileD "out/out.stack" (show stack)
 
       ----- JAVASCRIPT -------------------------------------
-      let stackjs = Stack2JS.irProg2JSString compileMode (Debug `elem` flags) stack
+      let stackjs = Stack2JS.stack2JSString compileMode
+                                            debugJS
+                                            (Stack.ProgramStackUnit stack)
       writeFile outPath stackjs
 
       case exports of
@@ -208,7 +210,7 @@ printHr = putStrLn (replicate hrWidth '-')
 --------------------------------------------------------------------------------
 ----- DESERIALIZATION FOR INTERACTIVE MODES ------------------------------------
 
-fromStdinIR putFormattedLn = do
+fromStdinIR putStrLn format = do
   eof <- isEOF
   if eof then exitSuccess else do
     input <- BS.getLine
@@ -220,19 +222,27 @@ fromStdinIR putFormattedLn = do
       case decode input of
         Right bs ->
            case CCIR.deserialize bs
-              of Right x -> do putFormattedLn x
+              of Right x -> do (putStrLn . format . ir2Stack) x
                  Left s -> do putStrLn "ERROR in deserialization"
                               debugOut $ "deserialization error" ++ s
         Left s -> do putStrLn "ERROR in B64 decoding"
                      debugOut $ "decoding error" ++s
     putStrLn "" -- magic marker to be recognized by the JS runtime; 2018-03-04; aa
     hFlush stdout
-    fromStdinIR putFormattedLn
+    fromStdinIR putStrLn format
   -- AA: 2018-07-15: consider timestamping these entries
   where debugOut s = appendFile "/tmp/debug" (s ++ "\n")
 
-fromStdinTextIR = fromStdinIR (putStrLn . IR2JS.irToJSString)
-fromStdinJsonIR = fromStdinIR (BSLazyChar8.putStrLn . IR2JS.irToJSON)
+        ir2Stack = Raw2Stack.raw2Stack . RawOpt.rawopt . IR2Raw.ir2raw
+
+fromStdinTextIR =
+  let format = Stack2JS.stack2JSString CompileMode.Normal False
+  in fromStdinIR putStrLn format
+
+fromStdinJsonIR =
+  let putStrLn = BSLazyChar8.putStrLn
+      format   = Stack2JS.stack2JSON CompileMode.Normal False
+  in fromStdinIR putStrLn format
 
 --------------------------------------------------------------------------------
 ----- MAIN ---------------------------------------------------------------------

compiler/src/IR2JS.hs

@@ -91,7 +91,8 @@ data TheState = TheState { freshCounter :: Integer
 
 type RetKontText = PP.Doc
 
-type W = RWS Bool  ([LibAccess], [Basics.AtomName], [RetKontText]) TheState
+type WData = ([LibAccess], [Basics.AtomName], [RetKontText])
+type W = RWS Bool WData TheState
 
 
 initState = TheState { freshCounter = 0
@@ -136,37 +137,48 @@ instance Identifier Raw.Assignable where
 class ToJS a where
    toJS :: a -> W PP.Doc
 
-irProg2JSString :: CompileMode -> Bool -> StackProgram -> String
-irProg2JSString compileMode debugMode ir =
-  let (fns, _, (_,_,konts)) = runRWS (toJS ir) debugMode initState
-      inner = vcat (fns:konts)
-      outer = vcat $
-        [ "function" <+> text "Top" <+> text "(rt) {"
-        , nest 2 inner
-        , text "}"
-        , "module.exports = Top"
+stack2PPDoc :: CompileMode -> Bool -> StackUnit -> (PP.Doc, WData)
+
+stack2PPDoc compileMode debugMode (ProgramStackUnit sp) =
+  let (fns, _, w@(libs, atoms, konts)) = runRWS (toJS sp) debugMode initState
+      inner = vcat $
+        [ jsLoadLibs
+        , addLibs libs
         ]
-  in PP.render $ case compileMode of Normal -> outer
-                                     Export -> inner
+        ++ (fns:konts) ++
+        [ ]
+
+      outer = ("function Top (rt)" <+> PP.lbrace)
+        $$+ inner
+        $$ PP.rbrace
+        $$ PP.text "module.exports = Top"
+
+      ppDoc = case compileMode of CompileMode.Export     -> inner
+                                  CompileMode.Normal     -> outer
+  in (ppDoc, w)
 
+stack2PPDoc _           debugMode su =
+  let (inner, _, w@(libs, _, konts)) = runRWS (toJS su) debugMode initState
+      ppDoc = vcat $ [ addLibs libs ] ++ (inner:konts)
+  in (ppDoc, w)
 
-stack2JSString :: StackUnit -> String
-stack2JSString x =
-  let (inner, _, (libs, atoms, konts)) = runRWS (toJS x) False initState
-  in PP.render (addLibs libs $$ (vcat (inner:konts)))
 
+stack2JSString :: CompileMode -> Bool -> StackUnit -> String
+stack2JSString compileMode debugMode su =
+  let (ppDoc, _) = stack2PPDoc compileMode debugMode su
+  in PP.render ppDoc
 
 
-stack2JSON :: StackUnit -> ByteString
-stack2JSON (ProgramStackUnit _) = error "needs to be ported"
-stack2JSON x = 
-  let (inner, _, (libs, atoms, konts)) = runRWS (toJS x) False initState
+stack2JSON :: CompileMode -> Bool -> StackUnit -> ByteString
+stack2JSON compileMode debugMode su =
+  let (ppDoc, (libs, atoms, konts)) = stack2PPDoc compileMode debugMode su
+      fname = case su of FunStackUnit (FunDef (HFN n) _ _ _ _) -> Just n
+                         AtomStackUnit _                       -> Nothing
   in Aeson.encode $ JSOutput { libs = libs
-                             , fname = case x of FunStackUnit (FunDef (HFN n)_ _ _ _) -> Just n
-                                                 _ -> Nothing
-                             , atoms = atoms                              
-                             , code = PP.render (addLibs libs $$ (vcat (inner:konts))) 
-                             } 
+                             , fname = fname
+                             , atoms = atoms
+                             , code = PP.render ppDoc
+                             }
 
 
 instance ToJS StackUnit where
@@ -185,15 +197,8 @@ instance ToJS IR.VarAccess where
 instance ToJS StackProgram where
   toJS (StackProgram atoms funs) = do
      jjA <- toJS atoms
-     (jjF, (libsF, atoms', _)) <- listen $ mapM toJS funs
-     
-     return $
-          vcat $ [ jsLoadLibs
-                 , addLibs libsF
-                 , jjA
-                 ] ++ jjF
-
-          
+     jjF <- mapM toJS funs
+     return $ vcat $ [jjA] ++ jjF
 
 
 instance ToJS C.Atoms where