[WIP] Javascript Printer

app/Main.hs

@@ -71,6 +71,14 @@ main = do
         Left err ->
           (TIO.hPutStrLn stderr $ reportParseError filename err) >>
           exitWith (ExitFailure 1)
+    ["format-js", filename] -> do
+      contents <- TIO.readFile filename
+      case formatJS contents of
+        Right formattedCode ->
+          TIO.putStrLn formattedCode
+        Left err ->
+          (TIO.hPutStrLn stderr $ reportParseError filename err) >>
+          exitWith (ExitFailure 1)
     ["check", filename] -> do
       contents <- TIO.readFile filename
       let (printText, exitCode) =

forest-compiler.cabal

@@ -18,6 +18,7 @@ library
   hs-source-dirs:      src
   exposed-modules:     HaskellSyntax
                      , Wasm
+                     , JavaScriptSyntax
                      , Compiler
                      , Language
                      , TypeChecker
@@ -52,6 +53,7 @@ test-suite forest-compiler-test
   hs-source-dirs:      test
   main-is:             Spec.hs
   other-modules:       HaskellSyntaxSpec
+                     , JavaScriptSyntaxSpec
                      , TypeCheckerSpec
                      , WasmSpec
                      , SampleSpec

src/Compiler.hs

@@ -5,12 +5,14 @@ module Compiler
   , format
   , typeCheck
   , Result(..)
+  , formatJS
   ) where
 
 import Data.List.NonEmpty (NonEmpty)
 import Debug.Trace (trace)
 import Data.Text (Text)
 
+import qualified JavaScriptSyntax as JS
 import HaskellSyntax
 import TypeChecker
 import Wasm
@@ -35,3 +37,6 @@ compile code = printWasm . forestModuleToWasm <$> typeCheck code
 
 format :: Text -> Either ParseError' Text
 format s = printModule <$> parseModule s
+
+formatJS :: Text -> Either ParseError' Text
+formatJS s = JS.printModule <$> parseModule s

src/JavaScriptSyntax.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module JavaScriptSyntax
+  ( printModule
+  ) where
+
+import Data.List (intercalate)
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (toList)
+import Data.Semigroup
+import Data.Text (Text)
+import qualified Data.Text as T
+import Language
+
+showT :: Show a => a -> Text
+showT = T.pack . show
+
+indent :: Int -> Text -> Text
+indent level str =
+  T.intercalate "\n" $
+  map (\line -> T.replicate level " " <> line) (T.lines str)
+
+indent2 :: Text -> Text
+indent2 = indent 2
+
+printModule :: Module -> Text
+printModule (Module topLevels) =
+  (T.intercalate "\n\n" $ map printTopLevel topLevels) <> "\n"
+
+printTopLevel :: TopLevel -> Text
+printTopLevel topLevel =
+  case topLevel of
+    Function declaration -> printDeclaration declaration
+    DataType (ADT name generics ctors) ->
+      "type " <> s name <> printedGenerics <> " =" <>
+      indent 2 printedCtors
+      where printedGenerics =
+              case generics of
+                 [] -> ""
+                 _ -> "<" <> T.intercalate ", " (s <$> generics) <> ">"
+            printedCtors = T.intercalate " | " (printCtor <$> (NE.toList ctors))
+            printCtor (Constructor name maybeType) =
+              s name <> " " <> maybe "" printConstructorType maybeType
+            printConstructorType ctorType =
+              case ctorType of
+                CTConcrete i -> s i
+                CTApplied a b ->
+                  printConstructorType a <> " " <> printConstructorType b
+                CTParenthesized ct -> parens (printConstructorType ct)
+
+printDeclaration :: Declaration -> Text
+printDeclaration (Declaration _ name args expression) =
+  "function " <> s name <> printedArgs <> " {\n  return " <>
+  printExpression expression <>
+  "\n}"
+  where
+    printedArgs = parens $ T.intercalate ", " $ map printArgument args
+
+printExpression :: Expression -> Text
+printExpression expression =
+  case expression of
+    Number number -> showT number
+    Float f -> showT f
+    Identifier identifier -> s identifier
+    Infix operator a b ->
+      T.intercalate
+        " "
+        [printExpression a, printOperator operator, printExpression b]
+    String' string -> showT string
+    Apply a b -> printExpression a <> parens (printExpression b)
+    BetweenParens expression -> parens $ printExpression expression
+    Case expression branches ->
+      "switch " <> parens (printExpression expression) <> " {\n" <>
+      indent 4 (printBranches branches) <>
+      "\n  }"
+    Let declarations expr ->
+      indent
+        2
+        (T.intercalate
+           "\n"
+           ((printDeclaration <$>
+            (NE.toList declarations)) <> [printExpression expr]))
+  where
+    printBranches branches =
+      T.intercalate "\n" $ toList $ fmap printBranch branches
+    printBranch (condition, body) =
+      "case " <> printArgument condition <> ":\n" <>
+      indent2 (printExpression body)
+
+printArgument :: Argument -> Text
+printArgument a =
+  case a of
+    AIdentifier n -> s n
+    ADeconstruction name args ->
+      s name <> parens (T.intercalate ", " (printArgument <$> args))
+    ANumberLiteral i -> showT i
+
+printOperator :: OperatorExpr -> Text
+printOperator operator =
+  case operator of
+    Add -> "+"
+    Subtract -> "-"
+    Divide -> "/"
+    Multiply -> "*"
+    StringAdd -> "++"
+
+parens :: Text -> Text
+parens s = "(" <> s <> ")"

test/JavaScriptSyntaxSpec.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module JavaScriptSyntaxSpec
+  ( javaScriptSyntaxSpecs
+  ) where
+
+import Control.Monad
+import qualified Data.List.NonEmpty as NE
+import System.Exit
+import System.IO.Temp
+import System.Process
+import Test.Hspec
+import Test.QuickCheck
+
+import Arbitrary
+
+import Compiler
+import JavaScriptSyntax
+import Language
+
+javaScriptSyntaxSpecs :: SpecWith ()
+javaScriptSyntaxSpecs =
+  describe "Forest JavaScript syntax" $ do
+    it "prints a simple program" $ do
+      expected <- readFixture "js/simple"
+      let code =
+            Module [Function $ Declaration Nothing (ne "test") [] (Number 1)]
+       in printModule code `shouldBe` expected
+    it "prints a function with many arguments" $ do
+      expected <- readFixture "js/arguments"
+      let code =
+            Module
+              [ Function $
+                Declaration
+                  Nothing
+                  (ne "test")
+                  [ne "a", ne "b"]
+                  (Infix Add (Identifier (ne "a")) (Identifier (ne "b")))
+              ]
+       in printModule code `shouldBe` expected
+    it "prints a function that returns a string" $ do
+      expected <- readFixture "js/string"
+      let code =
+            Module
+              [Function $ Declaration Nothing (ne "test") [] (String' "hey")]
+       in printModule code `shouldBe` expected
+    it "prints a function call with arguments" $ do
+      expected <- readFixture "js/call-with-arguments"
+      let code =
+            Module
+              [ Function $
+                Declaration
+                  Nothing
+                  (ne "test")
+                  [ne "a", ne "b"]
+                  (Call
+                     (ne "func")
+                     [(Identifier (ne "a")), (Identifier (ne "b"))])
+              ]
+       in printModule code `shouldBe` expected
+    it "prints a function with an expression inside of parens" $ do
+      expected <- readFixture "js/parens"
+      let code =
+            Module
+              [ Function $
+                Declaration Nothing (ne "test") [] (BetweenParens (Number 1))
+              ]
+       in printModule code `shouldBe` expected
+    it "prints a function with a case" $ do
+      expected <- readFixture "js/case"
+      let code =
+            Module
+              [ Function $
+                Declaration
+                  Nothing
+                  (ne "test")
+                  [ne "a"]
+                  (Case
+                     (Identifier (ne "a"))
+                     [ (String' "Foo", String' "Bar")
+                     , (String' "Ahh", String' "Woo")
+                     ])
+              ]
+       in printModule code `shouldBe` expected
+
+ne :: String -> Ident
+ne = Ident . NonEmptyString . NE.fromList
+
+readFixture :: String -> IO String
+readFixture name = readFile ("test/fixtures/" ++ name ++ ".tree")

test/Spec.hs

@@ -28,3 +28,4 @@ main = do
     iSampleSpecs
     wasmSpecs
     haskellSyntaxSpecs
+    javaScriptSyntaxSpecs

test/fixtures/js/arguments.tree

@@ -0,0 +1,3 @@
+function test(a, b) {
+  return a + b
+}

test/fixtures/js/call-with-arguments.tree

@@ -0,0 +1,3 @@
+function test(a, b) {
+  return func(a, b)
+}

test/fixtures/js/case.tree

@@ -0,0 +1,8 @@
+function test(a) {
+  return switch (a) {
+    case "Foo":
+      "Bar"
+    case "Ahh":
+      "Woo"
+  }
+}

test/fixtures/js/parens.tree

@@ -0,0 +1,3 @@
+function test() {
+  return (1)
+}

test/fixtures/js/simple.tree

@@ -0,0 +1,3 @@
+function test() {
+  return 1
+}

test/fixtures/js/string.tree

@@ -0,0 +1,3 @@
+function test() {
+  return "hey"
+}