From d66b93997f1985c4d2338c02b997e5e8387f6bcd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 26 Sep 2019 23:45:14 +0200 Subject: [PATCH] Let there be light --- .gitignore | 3 ++ ChangeLog.md | 3 ++ LICENSE | 30 +++++++++++ README.md | 1 + Setup.hs | 4 ++ app/Main.hs | 7 +++ package.yaml | 77 +++++++++++++++++++++++++++ ruby/fun.rb | 2 + ruby/test.rb | 23 +++++++++ src/Rubyhs.hs | 140 ++++++++++++++++++++++++++++++++++++++++++++++++++ stack.yaml | 8 +++ test/Spec.hs | 2 + 12 files changed, 300 insertions(+) create mode 100644 .gitignore create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 100644 package.yaml create mode 100644 ruby/fun.rb create mode 100644 ruby/test.rb create mode 100644 src/Rubyhs.hs create mode 100644 stack.yaml create mode 100644 test/Spec.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..19368cf --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +rubyhs.cabal +*~ \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..e9e0894 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for rubyhs + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..87bc158 --- /dev/null +++ b/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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..814faf1 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# rubyhs diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..00bfe1f --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..9cdce22 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Frelude +import qualified Rubyhs + +main :: IO () +main = Rubyhs.main diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..4d5a0c2 --- /dev/null +++ b/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 + +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 diff --git a/ruby/fun.rb b/ruby/fun.rb new file mode 100644 index 0000000..f4a52cd --- /dev/null +++ b/ruby/fun.rb @@ -0,0 +1,2 @@ +def f +end diff --git a/ruby/test.rb b/ruby/test.rb new file mode 100644 index 0000000..0e4a7ef --- /dev/null +++ b/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) + diff --git a/src/Rubyhs.hs b/src/Rubyhs.hs new file mode 100644 index 0000000..070395e --- /dev/null +++ b/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 + diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..2c4a108 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,8 @@ +resolver: lts-14.7 + +packages: + - . + +extra-deps: + - git: git@git.data.coop:fredefox/frelude.git + commit: 3524ffa4046b45d79192f2722a3d41b35c16f102 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"