Let there be light

.gitignore

@@ -0,0 +1,3 @@
+.stack-work/
+rubyhs.cabal
+*~

ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for rubyhs
+
+## Unreleased changes

LICENSE

@@ -0,0 +1,30 @@
+Copyright Frederik Hanghøj Iversen (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Frederik Hanghøj Iversen nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1 @@
+# rubyhs

Setup.hs

@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain

app/Main.hs

@@ -0,0 +1,7 @@
+module Main where
+
+import Frelude
+import qualified Rubyhs
+
+main :: IO ()
+main = Rubyhs.main

package.yaml

@@ -0,0 +1,77 @@
+name:                rubyhs
+version:             0.1.0.0
+github:              "fredefox/rubyhs"
+license:             BSD3
+author:              "Frederik Hanghøj Iversen"
+maintainer:          "fhi.1990@gmail.com"
+copyright:           "2019 Frederik Hanghøj Iversen"
+
+extra-source-files:
+  - README.md
+  - ChangeLog.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:
+  Please see the README on GitHub at <https://github.com/fredefox/rubyhs#readme>
+
+dependencies:
+  - base >= 4.7 && < 5
+  - process
+  - aeson
+  - vector
+  - bytestring
+  - frelude
+
+default-extensions:
+  - ConstraintKinds
+  - DeriveGeneric
+  - FlexibleContexts
+  - FlexibleInstances
+  - GADTs
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - NamedWildCards
+  - OverloadedStrings
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TupleSections
+  - TypeApplications
+  - TypeFamilies
+  - TypeSynonymInstances
+  - UnicodeSyntax
+  - ViewPatterns
+  - DerivingStrategies
+  - EmptyCase
+  - NoImplicitPrelude
+  - DeriveAnyClass
+
+library:
+  source-dirs: src
+
+executables:
+  rubyhs:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+    dependencies:
+      - rubyhs
+
+tests:
+  test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+    dependencies:
+      - rubyhs

ruby/fun.rb

@@ -0,0 +1,2 @@
+def f
+end

ruby/test.rb

@@ -0,0 +1,23 @@
+module M
+  def f
+  end
+
+  def g
+    
+    f(2)
+    h(2, a: 'a')
+    h(2, a: :a)
+
+  end
+end
+
+# class C
+# end
+
+module K
+end
+
+f(2)
+h(2, a: 'a')
+h(2, a: :a)
+

src/Rubyhs.hs

@@ -0,0 +1,140 @@
+{-# LANGUAGE DuplicateRecordFields, OverloadedLists #-}
+{-# OPTIONS_GHC -Wall #-}
+module Rubyhs (main) where
+
+import Frelude
+import System.Process
+import System.Environment
+import Data.Foldable (traverse_)
+import Data.Aeson (parseJSON, Value(String), withArray, eitherDecode, encode)
+import Data.Aeson.Types
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as ByteString
+import Control.Monad.Fail (MonadFail)
+import qualified Data.Vector as Vector
+
+main :: IO ()
+main = getArgs >>= traverse_ run
+
+kebabCase :: String -> String
+kebabCase = camelTo2 '-'
+
+newtype Block = Block [Definition]
+
+opts :: Options
+opts = defaultOptions { sumEncoding = ObjectWithSingleField, constructorTagModifier = kebabCase }
+
+deriving stock instance Show Block
+deriving stock instance Generic Block
+instance ToJSON Block where
+  toEncoding = genericToEncoding opts
+
+instance FromJSON Block where
+  parseJSON = withArray "Block" $ \as -> case Vector.toList as of
+    (String "begin":xs) -> Block <$> traverse parseJSON xs
+    _ -> Block . pure <$> parseJSON (Array as)
+
+data Definition = DefModule Module | DefFunction Function | DefSend Send
+
+deriving stock instance Show Definition
+deriving stock instance Generic Definition
+instance ToJSON Definition where
+  toEncoding = genericToEncoding ( opts { constructorTagModifier = go })
+    where
+    go = \case
+      "DefModule" -> "module"
+      "DefFunction" -> "function"
+      "DefSend" -> "send"
+      x -> x
+
+instance FromJSON Definition where
+  parseJSON val
+    =   (DefModule <$> parseJSON val)
+    <|> (DefFunction <$> parseJSON val)
+    <|> (DefSend <$> parseJSON val)
+
+data Send = Send
+  { args :: Args
+  , name :: Name
+  }
+
+
+deriving stock instance Show Send
+deriving stock instance Generic Send
+instance ToJSON Send where
+  toEncoding = genericToEncoding opts
+
+instance FromJSON Send where
+  parseJSON = withArray "Send" $ \ as -> case Vector.toList as of
+    (String "send" : _ : name : args) -> Send <$> parseJSON (Array $ Vector.fromList args) <*> parseJSON name
+    _ -> empty
+
+data Module = Module
+  { name :: Name
+  , block :: Block
+  }
+
+deriving stock instance Show Module
+deriving stock instance Generic Module
+instance ToJSON Module where
+  toEncoding = genericToEncoding opts
+
+instance FromJSON Module where
+  parseJSON = withArray "Module" $ \case
+    [String "module", name, block] -> Module <$> parseJSON name <*> parseMaybeBlock block
+    _ -> empty
+
+parseMaybeBlock :: Value -> Parser Block
+parseMaybeBlock = \case
+  Null -> pure (Block mempty)
+  x -> parseJSON x
+
+data Function = Function
+  { name :: Name
+  , args :: Args
+  , block :: Block
+  }
+
+deriving stock instance Show Function
+deriving stock instance Generic Function
+instance ToJSON Function where
+  toEncoding = genericToEncoding opts
+
+newtype Args = Args Value
+
+deriving stock instance Show Args
+deriving stock instance Generic Args
+instance ToJSON Args where
+  toEncoding = genericToEncoding opts
+
+instance FromJSON Args where
+  parseJSON = pure . Args
+
+instance FromJSON Function where
+  parseJSON = withArray "Function" $ \case
+    [String "def", name, args, block] -> Function <$> parseJSON name <*> parseJSON args <*> parseMaybeBlock block
+    _ -> empty
+
+newtype Name = Name Value
+
+deriving stock instance Show Name
+deriving newtype instance ToJSON Name
+deriving newtype instance FromJSON Name
+
+run :: FilePath -> IO ()
+run p = do
+  json <- runParser p
+  block <- decodeFail @_ @Block $ ByteString.pack json
+  ByteString.putStrLn $ encode block
+
+decodeFail :: MonadFail m => FromJSON a => ByteString -> m a
+decodeFail s = case eitherDecode s of
+  Left err -> fail err
+  Right a -> pure a
+
+runParser :: FilePath -> IO String
+runParser p = sh "ruby-parse" ["--emit-json", "--25", p]
+
+sh :: String -> [String] -> IO String
+sh cmd args = readProcess cmd args mempty
+

stack.yaml

@@ -0,0 +1,8 @@
+resolver: lts-14.7
+
+packages:
+  - .
+
+extra-deps:
+  - git: git@git.data.coop:fredefox/frelude.git
+    commit: 3524ffa4046b45d79192f2722a3d41b35c16f102

test/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"