diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for reason-export + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,18 @@ +Copyright 2019 Andrei Barbu + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,68 @@ +# Reason Export + +[![Build Status](https://travis-ci.org/abarbu/reason-export.svg)](https://travis-ci.org/abarbu/reason-export) +reason +reason + +Create Reason classes and JSON encoders/decoders from Haskell DataTypes. +Originally build by converting [elm-export](http://hackage.haskell.org/package/elm-export) to Reason. + +More docs on [Hackage](http://hackage.haskell.org/package/reason-export). + +## Usage + +If you're using this package you almost certainly want to use [servant-reason](http://hackage.haskell.org/package/servant-reason) as well. There are tests in both packages +that show to use this library. + +Usage is trivial, derive `Generic` and `ReasonType`. + +```haskell +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Db where + +import Reason +import GHC.Generics + +data Person = Person + { id :: Int + , name :: Maybe String + } deriving (Show, Eq, Generic, ReasonType) +``` + +Then you can expose your API: + +```haskell +module Main where + +import Data.Proxy +import Reason +import Data.Text hiding (intercalate, map) +import Db + +main :: IO () +main = do + let code = defReasonImports : + toReasonTypeSource (Proxy :: Proxy Person) : + toReasonDecoderSource (Proxy :: Proxy Person) : + writeFile "client/Types.re" $ intercalate "\n\n" $ map unpack code +``` + +That's about it. Just do this for every type that you want to expose. You can make encoders as well, and configure various settings. See [Hackage](http://hackage.haskell.org/package/reason-export). + +## Reason setup + +The generated Reason code needs access to [@glennsl/bs-json](https://github.com/glennsl/bs-json). Get the latest install instructions from there, but at the time of writing these were: + +```sh +npm install --save @glennsl/bs-json +``` + +Then add `@glennsl/bs-json` to `bs-dependencies` in your `bsconfig.json`: +```js +{ + ... + "bs-dependencies": ["@glennsl/bs-json"] +} +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/reason-export.cabal b/reason-export.cabal new file mode 100644 --- /dev/null +++ b/reason-export.cabal @@ -0,0 +1,114 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 06d199b5f88dc43f668e59c63a8b8ace8d65cb76a08af2fbf3edeb41d0ba624e + +name: reason-export +version: 0.1.0.0 +synopsis: Generate Reason types from Haskell +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/abarbu/reason-export#readme +bug-reports: https://github.com/abarbu/reason-export/issues +author: Andrei Barbu +maintainer: andrei@0xab.com +copyright: 2019 Andrei Barbu +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + test/CommentDecoder.re + test/CommentDecoderWithOptions.re + test/CommentEncoder.re + test/CommentEncoderWithOptions.re + test/CommentType.re + test/CommentTypeWithOptions.re + test/FavoritePlacesType.re + test/MonstrosityDecoder.re + test/MonstrosityEncoder.re + test/MonstrosityType.re + test/PositionDecoder.re + test/PositionEncoder.re + test/PositionType.re + test/PostDecoder.re + test/PostDecoderWithOptions.re + test/PostEncoder.re + test/PostEncoderWithOptions.re + test/PostType.re + test/PostTypeWithOptions.re + test/ShadowingDecoder.re + test/ShadowingEncoder.re + test/ShadowingType.re + test/TimingDecoder.re + test/TimingEncoder.re + test/TimingType.re + test/UnitDecoder.re + test/UnitEncoder.re + test/UnitType.re + test/UselessDecoder.re + test/UselessEncoder.re + test/UselessType.re + test/WrapperDecoder.re + test/WrapperEncoder.re + test/WrapperType.re + +source-repository head + type: git + location: https://github.com/abarbu/reason-export + +library + exposed-modules: + Reason + other-modules: + Reason.Common + Reason.Decoder + Reason.Encoder + Reason.File + Reason.Record + Reason.Type + Paths_reason_export + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , directory + , formatting + , hashable + , mtl + , text + , time + , wl-pprint-text + default-language: Haskell2010 + +test-suite reason-export-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + ExportSpec + Paths_reason_export + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + Diff + , HUnit + , QuickCheck + , base >=4.7 && <5 + , bytestring + , containers + , hashable + , hspec + , hspec-core + , quickcheck-instances + , reason-export + , text + , time + default-language: Haskell2010 diff --git a/src/Reason.hs b/src/Reason.hs new file mode 100644 --- /dev/null +++ b/src/Reason.hs @@ -0,0 +1,12 @@ +{-| Generate Reason types, JSON decoders & JSON encoders from Haskell datatypes. +-} +module Reason + ( module X + ) where + +import Reason.Common as X (Options(..), defaultOptions, require) +import Reason.Decoder as X +import Reason.Encoder as X +import Reason.File as X +import Reason.Record as X +import Reason.Type as X diff --git a/src/Reason/Common.hs b/src/Reason/Common.hs new file mode 100644 --- /dev/null +++ b/src/Reason/Common.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reason.Common where + +import Control.Monad.RWS +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Char as C +import qualified Data.Text.Lazy as LT +import Formatting hiding (text) +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +data Options = Options + { fieldLabelModifier :: Text -> Text + } + +defaultOptions :: Options +defaultOptions = Options {fieldLabelModifier = id} + +cr :: Format r r +cr = now "\n" + +mintercalate + :: Monoid m + => m -> [m] -> m +mintercalate _ [] = mempty +mintercalate _ [x] = x +mintercalate seperator (x:xs) = x <> seperator <> mintercalate seperator xs + +pprinter :: Doc -> Text +pprinter = LT.toStrict . displayT . renderPretty 0.4 100 + +stext :: Data.Text.Text -> Doc +stext = text . LT.fromStrict + +stextLower :: Data.Text.Text -> Doc +stextLower = text . LT.fromStrict . (\x -> C.toLower (T.head x) `T.cons` T.tail x) + +stextLowerSuffix :: Data.Text.Text -> Data.Text.Text -> Doc +stextLowerSuffix suffix = text . LT.fromStrict . (\x -> C.toLower (T.head x) `T.cons` T.tail x `T.append` suffix) + +stextSuffix :: Data.Text.Text -> Data.Text.Text -> Doc +stextSuffix suffix = text . LT.fromStrict . (`T.append` suffix) + +spaceparens :: Doc -> Doc +spaceparens doc = "(" <+> doc <+> ")" + +-- | Parentheses of which the right parenthesis exists on a new line +newlineparens :: Doc -> Doc +newlineparens doc = "(" <> doc <$$> ")" + +-- | An empty line, regardless of current indentation +emptyline :: Doc +emptyline = nest minBound linebreak + +-- | Like <$$>, but with an empty line in between +(<$+$>) :: Doc -> Doc -> Doc +l <$+$> r = l <> emptyline <$$> r + +-- TODO Replace require / imports everywhere! + +-- +type RenderM = RWS Options (Set Text -- The set of instances + , [Text] -- Generated declarations + ) (Maybe Text) -- The type of the current module + +{-| Add an instance to the set. +-} +require :: Text -> RenderM () +require dep = tell (S.singleton dep, []) + +{-| Take the result of a RenderM computation and put it into the Writer's +declarations. +-} +collectDeclaration :: RenderM Doc -> RenderM () +collectDeclaration = + mapRWS ((\(defn, s, (imports, _)) -> ((), s, (imports, [pprinter defn])))) + +squarebracks :: Doc -> Doc +squarebracks doc = "[" <+> doc <+> "]" + +pair :: Doc -> Doc -> Doc +pair l r = spaceparens $ l <> comma <+> r + +reservedKeywords :: [T.Text] +reservedKeywords = ["and","as","assertbegin","constraint","done","downto","end" + ,"exception","external","for","fun","function","functor","in","include" + ,"inherit","initializer","let","match","method","module","mutable","of" + ,"open","or","struct","to","true","try","type","virtual","while","with"] + +maybeReserved :: T.Text -> T.Text +maybeReserved name | name `elem` reservedKeywords = name <> "_" + | otherwise = name diff --git a/src/Reason/Decoder.hs b/src/Reason/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Reason/Decoder.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Reason.Decoder + ( toReasonDecoderRef + , toReasonDecoderRefWith + , toReasonDecoderSource + , toReasonDecoderSourceWith + , renderDecoder + ) where + +import Control.Monad.RWS +import qualified Data.Text as T +import Reason.Common +import Reason.Type +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +class HasDecoder a where + render :: a -> RenderM Doc + +class HasDecoderRef a where + renderRef :: a -> RenderM Doc + +instance HasDecoder ReasonDatatype where + render d@(ReasonDatatype _ constructor) = do + fnName <- renderRef d + ctor <- render constructor + return $ "let rec" <+> fnName <+> "= json =>" <$$> indent 4 ctor + render (ReasonPrimitive primitive) = renderRef primitive + +instance HasDecoderRef ReasonDatatype where + renderRef (ReasonDatatype name _) = pure $ "decode" <> stext name + renderRef (ReasonPrimitive primitive) = renderRef primitive + +instance HasDecoder ReasonConstructor where + render (NamedConstructor name ReasonEmpty) = + return $ "json |> Json.Decode.nullAs" <> parens (stext name) + render (NamedConstructor name (ReasonPrimitiveRef RUnit)) = + return $ "json |> Json.Decode.nullAs" <> parens (stext name) + render (NamedConstructor name value) = do + (_, val) <- renderConstructorArgs 0 value + return $ (stext name <+> parens val) + render (RecordConstructor _ value) = do + dv <- render value + return $ braces (line <> indent 4 dv) + render (MultipleConstructors constrs) = do + cstrs <- mapM renderSum constrs + pure $ line + <> indent 4 + ("json |>" <+> parens + (constructorName <$$> indent 4 + ("|> Json.Decode.andThen" <$$> + parens ("(x) => switch(x)" <$$> braces ( + line <> indent 4 (foldl1 (<$$>) cstrs + <$$> "|" <+> "_ =>" <+> "failwith(\"unknown constructor\")")))))) + where + constructorName :: Doc + constructorName = "Json.Decode.field(\"type\", Json.Decode.string)" + +-- | "" -> decode +renderSumCondition :: T.Text -> Doc -> RenderM Doc +renderSumCondition name contents = + pure $ "|" <+> dquotes (stext name) <+> "=> json => " <+> stext name <> (if isEmpty contents then + empty else + parens contents) + +-- | Render a sum type constructor in context of a data type with multiple +-- constructors. +renderSum :: ReasonConstructor -> RenderM Doc +renderSum (NamedConstructor name ReasonEmpty) = renderSumCondition name mempty +renderSum (NamedConstructor name v@(Values _ _)) = do + (_, val) <- renderConstructorArgs 0 v + renderSumCondition name val +renderSum (NamedConstructor name value) = do + val <- render value + renderSumCondition name $ "json |> Json.Decode.field" <> tupled [dquotes "arg0", val] +renderSum (RecordConstructor name value) = do + val <- render value + renderSumCondition name val +renderSum (MultipleConstructors constrs) = + foldl1 (<$$>) <$> mapM renderSum constrs + +-- | Render the decoding of a constructor's arguments. Note the constructor must +-- be from a data type with multiple constructors and that it has multiple +-- constructors itself. +renderConstructorArgs :: Int -> ReasonValue -> RenderM (Int, Doc) +renderConstructorArgs i (Values l r) = do + (iL, rndrL) <- renderConstructorArgs i l + (iR, rndrR) <- renderConstructorArgs (iL + 1) r + pure (iR, rndrL <$$> rndrR) +renderConstructorArgs i val = do + rndrVal <- render val + pure (i, "json |> Json.Decode.field" <+> tupled [dquotes ("arg" <> int i), rndrVal] <> comma) + +instance HasDecoder ReasonValue where + render (ReasonRef name) = pure $ "decode" <> stext name + render (ReasonPrimitiveRef primitive) = renderRef primitive + render (Values x y) = do + dx <- render x + dy <- render y + return $ dx <$$> dy + render (ReasonField name value) = do + fieldModifier <- asks fieldLabelModifier + dv <- render value + -- return $ "|> required" <+> dquotes (stext (fieldModifier name)) <+> dv + return $ (stext (fieldModifier name)) <+> ":" <+> "json |> Json.Decode.field" <+> tupled [dquotes (stext (fieldModifier name)), dv] <> comma + render ReasonEmpty = pure (stext "") + +instance HasDecoderRef ReasonPrimitive where + renderRef (RList (ReasonPrimitive RChar)) = pure "Json.Decode.string" + renderRef (RList datatype) = do + dt <- renderRef datatype + return $ "Json.Decode.list" <> parens dt + renderRef (RMap key value) = do + k <- renderRef key + d <- renderRef value + let kname = primitiveName key + return $ "Json.Decode.map" <> tupled ["l => List.fold_left" <+> tupled ["(m,(k,v)) =>" <+> "Map_" <> stext kname <> ".add(k,v,m)" + ,"Map_" <> stext kname <> ".empty" + ,"l"] + ,"Json.Decode.list(Json.Decode.tuple2(" <> k <> "," <> d <> "))"] + renderRef (ROption datatype) = do + dt <- renderRef datatype + return $ "Json.Decode.optional" <> parens dt + renderRef (RTuple2 x y) = do + dx <- renderRef x + dy <- renderRef y + return $ "Json.Decode.tuple2" <> tupled [dx, dy] + renderRef RUnit = pure "Json.Decode.nullAs" + renderRef RTimePosix = pure "Json.Decode.date" + renderRef RInt = pure "Json.Decode.int" + renderRef RBool = pure "Json.Decode.bool" + renderRef RChar = pure "Json.Decode.char" + renderRef RFloat = pure "Json.Decode.float" + renderRef RString = pure "Json.Decode.string" + +toReasonDecoderRefWith + :: ReasonType a + => Options -> a -> T.Text +toReasonDecoderRefWith options x = + pprinter . fst $ evalRWS (renderRef (toReasonType x)) options Nothing + +toReasonDecoderRef + :: ReasonType a + => a -> T.Text +toReasonDecoderRef = toReasonDecoderRefWith defaultOptions + +toReasonDecoderSourceWith + :: ReasonType a + => Options -> a -> T.Text +toReasonDecoderSourceWith options x = + pprinter . fst $ evalRWS (render (toReasonType x)) options Nothing + +toReasonDecoderSource + :: ReasonType a + => a -> T.Text +toReasonDecoderSource = toReasonDecoderSourceWith defaultOptions + +renderDecoder + :: ReasonType a + => a -> RenderM () +renderDecoder x = do + collectDeclaration . render . toReasonType $ x diff --git a/src/Reason/Encoder.hs b/src/Reason/Encoder.hs new file mode 100644 --- /dev/null +++ b/src/Reason/Encoder.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reason.Encoder + ( toReasonEncoderRef + , toReasonEncoderRefWith + , toReasonEncoderSource + , toReasonEncoderSourceWith + , renderEncoder + ) where + +import Control.Monad.RWS +import qualified Data.Text as T +import Reason.Common +import Reason.Type +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +class HasEncoder a where + render :: a -> RenderM Doc + +class HasEncoderRef a where + renderRef :: Int -> a -> RenderM Doc + +instance HasEncoder ReasonDatatype where + render d@(ReasonDatatype name constructor) = do + fnName <- renderRef 0 d + ctor <- render constructor + return $ ("let rec" <+> fnName <+> " = (x : " <> stextLower name <> ")" <+> "=>" <$$> indent 4 ctor) + render (ReasonPrimitive primitive) = renderRef 0 primitive + +instance HasEncoderRef ReasonDatatype where + renderRef _ (ReasonDatatype name _) = pure $ "encode" <> stext name + renderRef level (ReasonPrimitive primitive) = renderRef level primitive + +instance HasEncoder ReasonConstructor where + -- Single constructor, no values: empty array + render (NamedConstructor _name ReasonEmpty) = + return $ "Json.Encode.null" + render (NamedConstructor _name (ReasonPrimitiveRef RUnit)) = + return $ "Json.Encode.null" + -- Single constructor, multiple values: create array with values + render (NamedConstructor name value@(Values _ _)) = do + pure $ "TODO!!!" + -- let ps = constructorParameters 0 value + -- (dv, _) <- renderVariable ps value + -- let cs = stext name <+> foldl1 (<+>) ps <+> "->" + -- return . nest 4 $ "TODOXcase x of" <$$> + -- (nest 4 $ cs <$$> nest 4 ("Json.Encode.list identity" <$$> "[" <+> dv <$$> "]")) + -- Single constructor, one value: skip constructor and r just the value + render (NamedConstructor name value) = do + dv <- render value + let cs = "|" <+> stext name <> parens "y0" <+> "=>" + return $ nest 4 $ "switch(x)" <+> (braces $ line <> cs <+> nest 4 (nest 4 dv <> parens "y0")) + render (RecordConstructor _ value) = do + dv <- render value + return . nest 4 $ "Json.Encode.object_" <$$> parens ("[" <+> dv <$$> "]") + render mc@(MultipleConstructors constrs) = do + let rndr = if isEnumeration mc then renderEnumeration else renderSum + dc <- mapM rndr constrs + return . nest 4 $ "switch(x)" <+> (braces $ line <> foldl1 (<$$>) dc) + +jsonEncodeObject :: Doc -> Doc -> [Doc] -> Doc +jsonEncodeObject constructor tag contents = + nest 4 $ "|" <+> constructor <$$> + nest 4 ("Json.Encode.object_" <$$> + parens (brackets (tag <> comma <> + (case contents of + [] -> empty + _ -> foldl (\x y -> x <> line <> y <> comma) empty contents)))) + +renderSum :: ReasonConstructor -> RenderM Doc +renderSum c@(NamedConstructor name ReasonEmpty) = do + dc <- render c + let cs = stext name <+> "=>" + let tag = pair (dquotes "type") ("Json.Encode.string" <> parens (dquotes (stext name))) + return $ jsonEncodeObject cs tag [] + +renderSum (NamedConstructor name value) = do + ps <- collectParameters 0 value + let cs = stext name <> tupled (map fst ps) <+> "=>" + let tag = pair (dquotes "type") ("Json.Encode.string" <> parens (dquotes (stext name))) + -- let ct = comma <+> pair (dquotes "arg0") dc' + return $ jsonEncodeObject cs tag (map (\(i,p) -> indent 4 (pair (dquotes i) p)) ps) + +renderSum (RecordConstructor name value) = do + dv <- render value + let cs = stext name <+> "=>" + let tag = pair (dquotes "type") (dquotes $ stext name) + let ct = comma <+> dv + return $ jsonEncodeObject cs tag [ct] + +renderSum (MultipleConstructors constrs) = do + dc <- mapM renderSum constrs + return $ foldl1 (<$+$>) dc + + +renderEnumeration :: ReasonConstructor -> RenderM Doc +renderEnumeration (NamedConstructor name _) = + return . nest 4 $ "|" <+> stext name <+> "=>" <+> + "Json.Encode.object_" <> parens (brackets (pair (dquotes "type") ("Json.Encode.string" <> (parens (dquotes (stext name)))))) +renderEnumeration (MultipleConstructors constrs) = do + dc <- mapM renderEnumeration constrs + return $ foldl1 (<$$>) dc +renderEnumeration c = render c + + +instance HasEncoder ReasonValue where + render (ReasonField name value) = do + fieldModifier <- asks fieldLabelModifier + valueBody <- render value + return . spaceparens $ + dquotes (stext (fieldModifier name)) <> comma <+> (valueBody <> parens ("x." <> stext (fieldModifier name))) + render (ReasonPrimitiveRef primitive) = renderRef 0 primitive + render (ReasonRef name) = pure $ "encode" <> stext name + render (Values x y) = do + dx <- render x + dy <- render y + return $ dx <$$> comma <+> dy + render _ = error "HasEncoderRef ReasonValue: should not happen" + +instance HasEncoderRef ReasonPrimitive where + renderRef _ RTimePosix = pure $ "Json.Encode.date" + renderRef _ RUnit = pure "Json.Encode.null" + renderRef _ RInt = pure "Json.Encode.int" + renderRef _ RChar = pure "Json.Encode.char" + renderRef _ RBool = pure "Json.Encode.bool" + renderRef _ RFloat = pure "Json.Encode.float" + renderRef _ RString = pure "Json.Encode.string" + renderRef _ (RList (ReasonPrimitive RChar)) = pure "Json.Encode.string" + renderRef level (RList datatype) = do + dd <- renderRef level datatype + return . parens $ "Json.Encode.list" <> parens dd + renderRef level (ROption datatype) = do + dd <- renderRef level datatype + return . parens $ "Json.Encode.nullable" <> parens dd + renderRef level (RTuple2 x y) = do + dx <- renderRef (level + 1) x + dy <- renderRef (level + 1) y + return $ "Json.Encode.tuple2" <> tupled [dx, dy] + renderRef level (RMap k v) = do + dk <- renderRef level k + dv <- renderRef level v + let kname = primitiveName k + return $ parens $ "(x) =>" <+> "Json.Encode.list" <> parens ("Json.Encode.tuple2" <> tupled [dk, dv]) + <> parens ("Map_" <> stext kname <> ".bindings(x)") + +toReasonEncoderRefWith + :: ReasonType a + => Options -> a -> T.Text +toReasonEncoderRefWith options x = + pprinter . fst $ evalRWS (renderRef 0 (toReasonType x)) options Nothing + +toReasonEncoderRef + :: ReasonType a + => a -> T.Text +toReasonEncoderRef = toReasonEncoderRefWith defaultOptions + +toReasonEncoderSourceWith + :: ReasonType a + => Options -> a -> T.Text +toReasonEncoderSourceWith options x = + pprinter . fst $ evalRWS (render (toReasonType x)) options Nothing + +toReasonEncoderSource + :: ReasonType a + => a -> T.Text +toReasonEncoderSource = toReasonEncoderSourceWith defaultOptions + +renderEncoder + :: ReasonType a + => a -> RenderM () +renderEncoder x = do + require "Json.Encode" + collectDeclaration . render . toReasonType $ x + +-- | Variable names for the members of constructors +-- Used in pattern matches +collectParameters :: Int -> ReasonValue -> RenderM [(Doc,Doc)] +collectParameters _ ReasonEmpty = pure [] +collectParameters i (Values l r) = do + left <- collectParameters i l + right <- collectParameters (length left + i) r + pure $ left ++ right +collectParameters i v = do + r <- render v + pure $ [("arg" <> int i, r <> parens ("arg" <> int i))] diff --git a/src/Reason/File.hs b/src/Reason/File.hs new file mode 100644 --- /dev/null +++ b/src/Reason/File.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reason.File + ( Spec(..) + , specsToDir + , moduleSpec + , moduleSpecWith + ) where + +import Control.Monad.RWS +import Data.List +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Reason.Common +import Formatting as F +import System.Directory + +makePath :: [Text] -> Text +makePath = T.intercalate "/" + +data Spec = Spec + { namespace :: [Text] + , declarations :: [Text] + } deriving (Eq, Show) + +pathForSpec :: FilePath -> Spec -> [Text] +pathForSpec rootDir spec = T.pack rootDir : namespace spec + +ensureDirectory :: FilePath -> Spec -> IO () +ensureDirectory rootDir spec = + let dir = makePath . Data.List.init $ pathForSpec rootDir spec + in createDirectoryIfMissing True (T.unpack dir) + +specToFile :: FilePath -> Spec -> IO () +specToFile rootDir spec = + let path = pathForSpec rootDir spec + file = makePath path <> ".rs" + namespaceText = T.intercalate "." (namespace spec) + body = + T.intercalate + "\n\n" + (sformat ("module " % F.stext % " exposing (..)") namespaceText : + declarations spec) + in do fprint ("Writing: " % F.stext % "\n") file + T.writeFile (T.unpack file) body + +specsToDir :: [Spec] -> FilePath -> IO () +specsToDir specs rootDir = mapM_ processSpec specs + where + processSpec = ensureDirectory rootDir >> specToFile rootDir + +moduleSpecWith :: Options -> [Text] -> RenderM () -> Spec +moduleSpecWith options ns m = + let (_, (imports, defns)) = execRWS m options Nothing + in Spec + { namespace = ns + , declarations = + (T.intercalate "\n" . fmap ("import " <>) . S.toAscList $ imports) : + defns + } + +moduleSpec :: [Text] -> RenderM () -> Spec +moduleSpec = moduleSpecWith defaultOptions diff --git a/src/Reason/Record.hs b/src/Reason/Record.hs new file mode 100644 --- /dev/null +++ b/src/Reason/Record.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reason.Record + ( toReasonTypeRef + , toReasonTypeRefWith + , toReasonTypeSource + , toReasonTypeSourceWith + , renderType + ) where + +import Control.Monad.RWS +import qualified Data.Text as T +import Reason.Common +import Reason.Type +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +class HasType a where + render :: a -> RenderM Doc + +class HasRecordType a where + renderRecord :: a -> RenderM Doc + +class HasTypeRef a where + renderRef :: a -> RenderM Doc + +instance HasType ReasonDatatype where + render d@(ReasonDatatype name constructor@(RecordConstructor _ _)) = do + put $ Just name + name' <- renderRef d + ctor <- render constructor + return . nest 4 $ "type" <+> name' <+> "=" <$$> ctor + render d@(ReasonDatatype name constructor) = do + put $ Just name + name' <- renderRef d + ctor <- render constructor + return . nest 4 $ "type" <+> name' <+> "=" <$$> ("|" <> space <> ctor) + render (ReasonPrimitive primitive) = renderRef primitive + +namespaceIfNeeded :: T.Text -> T.Text -> RenderM Doc +namespaceIfNeeded typeName obj = do + currentName <- get + case currentName of + Nothing -> pure (stextSuffix ("." <> obj) (typeName <> "Type")) + Just cn -> if cn == typeName then + pure "t" else + pure (stextSuffix ("." <> obj) (typeName <> "Type")) + +instance HasTypeRef ReasonDatatype where + renderRef (ReasonDatatype typeName _) = pure (stextLower typeName) -- namespaceIfNeeded typeName "t" + renderRef (ReasonPrimitive primitive) = renderRef primitive + +instance HasType ReasonConstructor where + render (RecordConstructor _ value) = do + dv <- renderRecord value + return $ "{" <+> dv <$$> "}" + render (NamedConstructor constructorName value) = do + dv <- render value + return $ stext constructorName <> (if isEmpty dv then + empty else + parens dv) + render (MultipleConstructors constructors) = + mintercalate (line <> "|" <> space) <$> sequence (render <$> constructors) + +instance HasType ReasonValue where + render (ReasonRef name) = pure (stextLower name) + render (ReasonPrimitiveRef primitive) = elmRefParens primitive <$> renderRef primitive + render ReasonEmpty = pure (text "") + render (Values x y) = do + dx <- render x + dy <- render y + return $ dx <> "," <+> dy + render (ReasonField name value) = do + fieldModifier <- asks fieldLabelModifier + dv <- renderRecord value + return $ stext (fieldModifier (maybeReserved name)) <+> ":" <+> dv + +instance HasRecordType ReasonValue where + renderRecord (ReasonPrimitiveRef primitive) = renderRef primitive + renderRecord (Values x y) = do + dx <- renderRecord x + dy <- renderRecord y + return $ dx <$$> comma <+> dy + renderRecord value = render value + +instance HasTypeRef ReasonPrimitive where + renderRef (RList (ReasonPrimitive RChar)) = renderRef RString + renderRef (RList datatype) = do + dt <- renderRef datatype + return $ "list" <+> parens dt + renderRef (RTuple2 x y) = do + dx <- renderRef x + dy <- renderRef y + return . parens $ dx <> comma <+> dy + renderRef (RTuple3 x y z) = do + dx <- renderRef x + dy <- renderRef y + dz <- renderRef z + return . parens $ dx <> comma <+> dy <+> comma <+> dz + renderRef (ROption datatype) = do + dt <- renderRef datatype + return $ "option" <+> parens dt + renderRef (RMap k v) = do + dk <- renderRef k + let kname = primitiveName k + require ("module Map_" <> kname -- displayTStrict (renderCompact dk) + <> " = Map.Make({ type t = " + <> displayTStrict (renderCompact dk) + <> "; let compare = compare });") + dv <- renderRef v + return $ "Map_" <> stext kname <> ".t" <+> parens dv + renderRef RInt = pure "int" + renderRef RInt64 = pure "int64" + renderRef RTimePosix = pure "Js.Date.t" + renderRef RBool = pure "bool" + renderRef RChar = pure "char" + renderRef RString = pure "string" + renderRef RUnit = pure "" + renderRef RFloat = pure "float" + +-- | Puts parentheses around the doc of an elm ref if it contains spaces. +elmRefParens :: ReasonPrimitive -> Doc -> Doc +elmRefParens (RList (ReasonPrimitive RChar)) = id +elmRefParens (RList _) = parens +elmRefParens (ROption _) = parens +elmRefParens (RMap _ _) = parens +elmRefParens _ = id + +toReasonTypeRefWith + :: ReasonType a + => Options -> a -> T.Text +toReasonTypeRefWith options x = + pprinter . fst $ evalRWS (renderRef (toReasonType x)) options Nothing + +toReasonTypeRef + :: ReasonType a + => a -> T.Text +toReasonTypeRef = toReasonTypeRefWith defaultOptions + +toReasonTypeSourceWith + :: ReasonType a + => Options -> a -> T.Text +toReasonTypeSourceWith options x = + pprinter . fst $ evalRWS (render (toReasonType x)) options Nothing + +toReasonTypeSource + :: ReasonType a + => a -> T.Text +toReasonTypeSource = toReasonTypeSourceWith defaultOptions + +renderType + :: ReasonType a + => a -> RenderM () +renderType = collectDeclaration . render . toReasonType diff --git a/src/Reason/Type.hs b/src/Reason/Type.hs new file mode 100644 --- /dev/null +++ b/src/Reason/Type.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Reason.Type where + +import Data.Int (Int16, Int32, Int64, Int8) +import Data.IntMap +import Data.Map +import Data.Proxy +import Data.Text hiding (all) +import Data.Time +import GHC.Generics +import Prelude +import Data.Hashable(hash) + +data ReasonDatatype + = ReasonDatatype Text ReasonConstructor + | ReasonPrimitive ReasonPrimitive + deriving (Show, Eq) + +data ReasonPrimitive + = RInt + | RInt64 + | RFloat + | RBool + | RChar + | RString + | RTimePosix + | RUnit + | RList ReasonDatatype + | ROption ReasonDatatype + | RTuple2 ReasonDatatype ReasonDatatype + | RTuple3 ReasonDatatype ReasonDatatype ReasonDatatype + | RMap ReasonPrimitive ReasonDatatype + deriving (Show, Eq) + +data ReasonConstructor + = NamedConstructor Text ReasonValue + | RecordConstructor Text ReasonValue + | MultipleConstructors [ReasonConstructor] + deriving (Show, Eq) + +data ReasonValue + = ReasonRef Text + | ReasonEmpty + | ReasonPrimitiveRef ReasonPrimitive + | Values ReasonValue ReasonValue + | ReasonField Text ReasonValue + deriving (Show, Eq) + +------------------------------------------------------------ +class ReasonType a where + toReasonType :: a -> ReasonDatatype + toReasonType = genericToReasonDatatype . from + default toReasonType :: (Generic a, GenericReasonDatatype (Rep a)) => + a -> ReasonDatatype + +------------------------------------------------------------ +class GenericReasonDatatype f where + genericToReasonDatatype :: f a -> ReasonDatatype + +instance (Datatype d, GenericReasonConstructor f) => + GenericReasonDatatype (D1 d f) where + genericToReasonDatatype datatype = + ReasonDatatype + (pack (datatypeName datatype)) + (genericToReasonConstructor (unM1 datatype)) + +------------------------------------------------------------ +class GenericReasonConstructor f where + genericToReasonConstructor :: f a -> ReasonConstructor + +instance (Constructor c, GenericReasonValue f) => + GenericReasonConstructor (C1 c f) where + genericToReasonConstructor constructor = + if conIsRecord constructor + then RecordConstructor name (genericToReasonValue (unM1 constructor)) + else NamedConstructor name (genericToReasonValue (unM1 constructor)) + where + name = pack $ conName constructor + +instance (GenericReasonConstructor f, GenericReasonConstructor g) => + GenericReasonConstructor (f :+: g) where + genericToReasonConstructor _ = + MultipleConstructors + [ genericToReasonConstructor (undefined :: f p) + , genericToReasonConstructor (undefined :: g p) + ] + +------------------------------------------------------------ +class GenericReasonValue f where + genericToReasonValue :: f a -> ReasonValue + +instance (Selector s, GenericReasonValue a) => + GenericReasonValue (S1 s a) where + genericToReasonValue selector = + case selName selector of + "" -> genericToReasonValue (undefined :: a p) + name -> ReasonField (pack name) (genericToReasonValue (undefined :: a p)) + +instance (GenericReasonValue f, GenericReasonValue g) => + GenericReasonValue (f :*: g) where + genericToReasonValue _ = + Values + (genericToReasonValue (undefined :: f p)) + (genericToReasonValue (undefined :: g p)) + +instance GenericReasonValue U1 where + genericToReasonValue _ = ReasonEmpty + +instance ReasonType a => + GenericReasonValue (Rec0 a) where + genericToReasonValue _ = + case toReasonType (Proxy :: Proxy a) of + ReasonPrimitive primitive -> ReasonPrimitiveRef primitive + ReasonDatatype name _ -> ReasonRef name + +instance ReasonType a => + ReasonType [a] where + toReasonType _ = ReasonPrimitive (RList (toReasonType (Proxy :: Proxy a))) + +instance ReasonType a => + ReasonType (Maybe a) where + toReasonType _ = ReasonPrimitive (ROption (toReasonType (Proxy :: Proxy a))) + +instance ReasonType () where + toReasonType _ = ReasonPrimitive RUnit + +instance ReasonType Text where + toReasonType _ = ReasonPrimitive RString + +instance ReasonType Day where + toReasonType _ = ReasonPrimitive RTimePosix + +instance ReasonType UTCTime where + toReasonType _ = ReasonPrimitive RTimePosix + +instance ReasonType Float where + toReasonType _ = ReasonPrimitive RFloat + +instance ReasonType Double where + toReasonType _ = ReasonPrimitive RFloat + +instance ReasonType Int8 where + toReasonType _ = ReasonPrimitive RInt + +instance ReasonType Int16 where + toReasonType _ = ReasonPrimitive RInt + +instance ReasonType Int32 where + toReasonType _ = ReasonPrimitive RInt + +instance ReasonType Int64 where + toReasonType _ = ReasonPrimitive RInt64 + +instance (ReasonType a, ReasonType b) => + ReasonType (a, b) where + toReasonType _ = + ReasonPrimitive $ + RTuple2 (toReasonType (Proxy :: Proxy a)) (toReasonType (Proxy :: Proxy b)) + +instance (ReasonType a, ReasonType b, ReasonType c) => + ReasonType (a, b, c) where + toReasonType _ = + ReasonPrimitive $ + RTuple3 (toReasonType (Proxy :: Proxy a)) (toReasonType (Proxy :: Proxy b)) (toReasonType (Proxy :: Proxy c)) + +instance (ReasonType a) => + ReasonType (Proxy a) where + toReasonType _ = toReasonType (undefined :: a) + +instance (HasReasonComparable k, ReasonType v) => + ReasonType (Map k v) where + toReasonType _ = + ReasonPrimitive $ + RMap (toReasonComparable (undefined :: k)) (toReasonType (Proxy :: Proxy v)) + +instance (ReasonType v) => + ReasonType (IntMap v) where + toReasonType _ = ReasonPrimitive $ RMap RInt (toReasonType (Proxy :: Proxy v)) + +class HasReasonComparable a where + toReasonComparable :: a -> ReasonPrimitive + +instance HasReasonComparable String where + toReasonComparable _ = RString + +instance HasReasonComparable Text where + toReasonComparable _ = RString + +instance ReasonType Int where + toReasonType _ = ReasonPrimitive RInt + +instance ReasonType Char where + toReasonType _ = ReasonPrimitive RChar + +instance ReasonType Bool where + toReasonType _ = ReasonPrimitive RBool + +-- | Whether a set of constructors is an enumeration, i.e. whether they lack +-- values. data A = A | B | C would be simple data A = A Int | B | C would not +-- be simple. +isEnumeration :: ReasonConstructor -> Bool +isEnumeration (NamedConstructor _ ReasonEmpty) = True +isEnumeration (MultipleConstructors cs) = all isEnumeration cs +isEnumeration _ = False + +primitiveName :: ReasonPrimitive -> Text +primitiveName k = pack (show (abs (hash (show k)))) diff --git a/test/CommentDecoder.re b/test/CommentDecoder.re new file mode 100644 --- /dev/null +++ b/test/CommentDecoder.re @@ -0,0 +1,20 @@ +open CommentType; + +let rec decodeComment = json => + { + postId : json |> Json.Decode.field ("postId" + ,Json.Decode.int), + text : json |> Json.Decode.field ("text" + ,Json.Decode.string), + mainCategories : json |> Json.Decode.field ("mainCategories" + ,Json.Decode.tuple2(Json.Decode.string + ,Json.Decode.string)), + published : json |> Json.Decode.field ("published" + ,Json.Decode.bool), + created : json |> Json.Decode.field ("created" + ,Json.Decode.date), + tags : json |> Json.Decode.field ("tags" + ,Json.Decode.map(l => List.fold_left ((m,(k,v)) => Map_651798451719185100.add(k,v,m) + ,Map_651798451719185100.empty + ,l) + ,Json.Decode.list(Json.Decode.tuple2(Json.Decode.string,Json.Decode.int)))),} diff --git a/test/CommentDecoderWithOptions.re b/test/CommentDecoderWithOptions.re new file mode 100644 --- /dev/null +++ b/test/CommentDecoderWithOptions.re @@ -0,0 +1,20 @@ +open CommentTypeWithOptions; + +let rec decodeComment = json => + { + commentPostId : json |> Json.Decode.field ("commentPostId" + ,Json.Decode.int), + commentText : json |> Json.Decode.field ("commentText" + ,Json.Decode.string), + commentMainCategories : json |> Json.Decode.field ("commentMainCategories" + ,Json.Decode.tuple2(Json.Decode.string + ,Json.Decode.string)), + commentPublished : json |> Json.Decode.field ("commentPublished" + ,Json.Decode.bool), + commentCreated : json |> Json.Decode.field ("commentCreated" + ,Json.Decode.date), + commentTags : json |> Json.Decode.field ("commentTags" + ,Json.Decode.map(l => List.fold_left ((m,(k,v)) => Map_651798451719185100.add(k,v,m) + ,Map_651798451719185100.empty + ,l) + ,Json.Decode.list(Json.Decode.tuple2(Json.Decode.string,Json.Decode.int)))),} diff --git a/test/CommentEncoder.re b/test/CommentEncoder.re new file mode 100644 --- /dev/null +++ b/test/CommentEncoder.re @@ -0,0 +1,13 @@ +open CommentType; + +let rec encodeComment = (x : comment) => + Json.Encode.object_ + ([ ( "postId", Json.Encode.int(x.postId) ) + , ( "text", Json.Encode.string(x.text) ) + , ( "mainCategories", Json.Encode.tuple2(Json.Encode.string + ,Json.Encode.string)(x.mainCategories) ) + , ( "published", Json.Encode.bool(x.published) ) + , ( "created", Json.Encode.date(x.created) ) + , ( "tags", ((x) => Json.Encode.list(Json.Encode.tuple2(Json.Encode.string + ,Json.Encode.int))(Map_651798451719185100.bindings(x)))(x.tags) ) + ]) diff --git a/test/CommentEncoderWithOptions.re b/test/CommentEncoderWithOptions.re new file mode 100644 --- /dev/null +++ b/test/CommentEncoderWithOptions.re @@ -0,0 +1,13 @@ +open CommentTypeWithOptions; + +let rec encodeComment = (x : comment) => + Json.Encode.object_ + ([ ( "commentPostId", Json.Encode.int(x.commentPostId) ) + , ( "commentText", Json.Encode.string(x.commentText) ) + , ( "commentMainCategories", Json.Encode.tuple2(Json.Encode.string + ,Json.Encode.string)(x.commentMainCategories) ) + , ( "commentPublished", Json.Encode.bool(x.commentPublished) ) + , ( "commentCreated", Json.Encode.date(x.commentCreated) ) + , ( "commentTags", ((x) => Json.Encode.list(Json.Encode.tuple2(Json.Encode.string + ,Json.Encode.int))(Map_651798451719185100.bindings(x)))(x.commentTags) ) + ]) diff --git a/test/CommentType.re b/test/CommentType.re new file mode 100644 --- /dev/null +++ b/test/CommentType.re @@ -0,0 +1,10 @@ +module Map_651798451719185100 = Map.Make({ type t = string; let compare = compare }); + +type comment = + { postId : int + , text : string + , mainCategories : (string, string) + , published : bool + , created : Js.Date.t + , tags : Map_651798451719185100.t (int) + } diff --git a/test/CommentTypeWithOptions.re b/test/CommentTypeWithOptions.re new file mode 100644 --- /dev/null +++ b/test/CommentTypeWithOptions.re @@ -0,0 +1,10 @@ +module Map_651798451719185100 = Map.Make({ type t = string; let compare = compare }); + +type comment = + { commentPostId : int + , commentText : string + , commentMainCategories : (string, string) + , commentPublished : bool + , commentCreated : Js.Date.t + , commentTags : Map_651798451719185100.t (int) + } diff --git a/test/ExportSpec.hs b/test/ExportSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExportSpec.hs @@ -0,0 +1,554 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module ExportSpec where + +import qualified Data.Algorithm.Diff as Diff +import qualified Data.Algorithm.DiffOutput as DiffOutput +import Data.Char +import Data.Int +import Data.IntMap +import Data.Map +import Data.Proxy +import Data.Text hiding (head, lines, unlines) +import Data.Time +import Reason +import GHC.Generics +import Test.HUnit (Assertion, assertBool) +import Test.Hspec hiding (Spec) +import Test.Hspec as Hspec +import Text.Printf + +-- Debugging hint: +-- ghci> import GHC.Generics +-- ghci> :kind! Rep Post +-- ... +data Post = Post + { id :: Int + , name :: String + , age :: Maybe Double + , comments :: [Comment] + , promoted :: Maybe Comment + , author :: Maybe String + } deriving (Generic, ReasonType) + +data Comment = Comment + { postId :: Int + , text :: Text + , mainCategories :: (String, String) + , published :: Bool + , created :: UTCTime + , tags :: Map String Int + } deriving (Generic, ReasonType) + +data Position + = Beginning + | Middle + | End + deriving (Generic, ReasonType) + +data Timing + = Start + | Continue Double + | Stop + deriving (Generic, ReasonType) + +data Monstrosity + = NotSpecial + | OkayIGuess Monstrosity + | Ridiculous Int String [Monstrosity] + deriving (Generic, ReasonType) + +newtype Useless = + Useless () + deriving (Generic, ReasonType) + +data Unit = Unit + deriving (Generic, ReasonType) + +newtype Wrapper = Wrapper Int + deriving (Generic, ReasonType) + +newtype FavoritePlaces = FavoritePlaces + { positionsByUser :: Map String [Position] + } deriving (Generic, ReasonType) + +-- | We don't actually use this type, we just need to see that it compiles. +data LotsOfInts = LotsOfInts + { intA :: Int8 + , intB :: Int16 + , intC :: Int32 + , intD :: Int64 + } deriving (Generic, ReasonType) + + +data Shadowing = Shadowing + { prop :: ( (Int, Int), ( String, String ) ) + } deriving (Generic, ReasonType) + + +spec :: Hspec.Spec +spec = do + toReasonTypeSpec + toReasonDecoderSpec + toReasonEncoderSpec + moduleSpecsSpec + +toReasonTypeSpec :: Hspec.Spec +toReasonTypeSpec = + describe "Convert to Reason types." $ do + it "toReasonTypeSource Post" $ + shouldMatchTypeSource + (unlines + ["open CommentType" + , "" + ,"%s"]) + defaultOptions + (Proxy :: Proxy Post) + "test/PostType.re" + it "toReasonTypeSource Comment" $ + shouldMatchTypeSource + (unlines + [ "module Map_651798451719185100 = Map.Make({ type t = string; let compare = compare });" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Comment) + "test/CommentType.re" + it "toReasonTypeSource Position" $ + shouldMatchTypeSource + (unlines ["%s"]) + defaultOptions + (Proxy :: Proxy Position) + "test/PositionType.re" + it "toReasonTypeSource Timing" $ + shouldMatchTypeSource + (unlines ["%s"]) + defaultOptions + (Proxy :: Proxy Timing) + "test/TimingType.re" + it "toReasonTypeSource Monstrosity" $ + shouldMatchTypeSource + (unlines ["%s"]) + defaultOptions + (Proxy :: Proxy Monstrosity) + "test/MonstrosityType.re" + it "toReasonTypeSource Useless" $ + shouldMatchTypeSource + (unlines ["%s"]) + defaultOptions + (Proxy :: Proxy Useless) + "test/UselessType.re" + it "toReasonTypeSource Unit" $ + shouldMatchTypeSource + (unlines ["%s"]) + defaultOptions + (Proxy :: Proxy Unit) + "test/UnitType.re" + it "toReasonTypeSource Wrapper" $ + shouldMatchTypeSource + (unlines ["%s"]) + defaultOptions + (Proxy :: Proxy Wrapper) + "test/WrapperType.re" + it "toReasonTypeSource FavoritePlaces" $ + shouldMatchTypeSource + (unlines + [ "open PositionType;" + , "module Map_651798451719185100 = Map.Make({ type t = string; let compare = compare });" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy FavoritePlaces) + "test/FavoritePlacesType.re" + it "toReasonTypeSourceWithOptions Post" $ + shouldMatchTypeSource + (unlines + [ "open CommentType;" + , "" + , "%s" + ]) + (defaultOptions {fieldLabelModifier = withPrefix "post"}) + (Proxy :: Proxy Post) + "test/PostTypeWithOptions.re" + it "toReasonTypeSourceWithOptions Comment" $ + shouldMatchTypeSource + (unlines + [ "module Map_651798451719185100 = Map.Make({ type t = string; let compare = compare });" + , "" + , "%s" + ]) + (defaultOptions {fieldLabelModifier = withPrefix "comment"}) + (Proxy :: Proxy Comment) + "test/CommentTypeWithOptions.re" + it "toReasonTypeSource Shadowing" $ + shouldMatchTypeSource + (unlines + [ "%s" + ]) + defaultOptions + (Proxy :: Proxy Shadowing) + "test/ShadowingType.re" + describe "Convert to Reason type references." $ do + it "toReasonTypeRef Post" $ + toReasonTypeRef (Proxy :: Proxy Post) `shouldBe` "post" + it "toReasonTypeRef [Comment]" $ + toReasonTypeRef (Proxy :: Proxy [Comment]) `shouldBe` "list (comment)" + it "toReasonTypeRef (comment, String)" $ + toReasonTypeRef (Proxy :: Proxy (Comment, String)) `shouldBe` + "(comment, string)" + it "toReasonTypeRef String" $ + toReasonTypeRef (Proxy :: Proxy String) `shouldBe` "string" + it "toReasonTypeRef (Maybe String)" $ + toReasonTypeRef (Proxy :: Proxy (Maybe String)) `shouldBe` "option (string)" + it "toReasonTypeRef [Maybe String]" $ + toReasonTypeRef (Proxy :: Proxy [Maybe String]) `shouldBe` + "list (option (string))" + it "toReasonTypeRef (Map String (Maybe String))" $ + toReasonTypeRef (Proxy :: Proxy (Map String (Maybe String))) `shouldBe` + "Map_651798451719185100.t (option (string))" + it "toReasonTypeRef (IntMap (Maybe String))" $ + toReasonTypeRef (Proxy :: Proxy (IntMap (Maybe String))) `shouldBe` + "Map_4250183808575061913.t (option (string))" + +toReasonDecoderSpec :: Hspec.Spec +toReasonDecoderSpec = + describe "Convert to Reason decoders." $ do + it "toReasonDecoderSource Comment" $ + shouldMatchDecoderSource + (unlines + [ "open CommentType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Comment) + "test/CommentDecoder.re" + it "toReasonDecoderSource Post" $ + shouldMatchDecoderSource + (unlines + [ "open PostType;" + , "open CommentDecoder;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Post) + "test/PostDecoder.re" + it "toReasonDecoderSourceWithOptions Post" $ + shouldMatchDecoderSource + (unlines + [ "open PostTypeWithOptions;" + , "open CommentDecoder;" + , "" + , "%s" + ]) + (defaultOptions {fieldLabelModifier = withPrefix "post"}) + (Proxy :: Proxy Post) + "test/PostDecoderWithOptions.re" + it "toReasonDecoderSource Position" $ + shouldMatchDecoderSource + (unlines + [ "open PositionType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Position) + "test/PositionDecoder.re" + it "toReasonDecoderSource Timing" $ + shouldMatchDecoderSource + (unlines + [ "open TimingType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Timing) + "test/TimingDecoder.re" + it "toReasonDecoderSource Monstrosity" $ + shouldMatchDecoderSource + (unlines + [ "open MonstrosityType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Monstrosity) + "test/MonstrosityDecoder.re" + it "toReasonDecoderSourceWithOptions Comment" $ + shouldMatchDecoderSource + (unlines + [ "open CommentTypeWithOptions;" + , "" + , "%s" + ]) + (defaultOptions {fieldLabelModifier = withPrefix "comment"}) + (Proxy :: Proxy Comment) + "test/CommentDecoderWithOptions.re" + it "toReasonDecoderSource Useless" $ + shouldMatchDecoderSource + (unlines + [ "open UselessType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Useless) + "test/UselessDecoder.re" + it "toReasonDecoderSource Unit" $ + shouldMatchDecoderSource + (unlines + [ "open UnitType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Unit) + "test/UnitDecoder.re" + it "toReasonDecoderSource Wrapper" $ + shouldMatchDecoderSource + (unlines + [ "open WrapperType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Wrapper) + "test/WrapperDecoder.re" + it "toReasonDecoderSource Shadowing" $ + shouldMatchDecoderSource + (unlines + [ "open ShadowingType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Shadowing) + "test/ShadowingDecoder.re" + describe "Convert to Reason decoder references." $ do + it "toReasonDecoderRef Post" $ + toReasonDecoderRef (Proxy :: Proxy Post) `shouldBe` "decodePost" + it "toReasonDecoderRef Position" $ + toReasonDecoderRef (Proxy :: Proxy Position) `shouldBe` "decodePosition" + it "toReasonDecoderRef Timing" $ + toReasonDecoderRef (Proxy :: Proxy Timing) `shouldBe` "decodeTiming" + it "toReasonDecoderRef Monstrosity" $ + toReasonDecoderRef (Proxy :: Proxy Monstrosity) `shouldBe` "decodeMonstrosity" + it "toReasonDecoderRef [Comment]" $ + toReasonDecoderRef (Proxy :: Proxy [Comment]) `shouldBe` + "Json.Decode.list(decodeComment)" + it "toReasonDecoderRef String" $ + toReasonDecoderRef (Proxy :: Proxy String) `shouldBe` "Json.Decode.string" + it "toReasonDecoderRef (Maybe String)" $ + toReasonDecoderRef (Proxy :: Proxy (Maybe String)) `shouldBe` + "Json.Decode.optional(Json.Decode.string)" + it "toReasonDecoderRef [Maybe String]" $ + toReasonDecoderRef (Proxy :: Proxy [Maybe String]) `shouldBe` + "Json.Decode.list(Json.Decode.optional(Json.Decode.string))" + it "toReasonDecoderRef (Map String (Maybe String))" $ + toReasonDecoderRef (Proxy :: Proxy (Map String (Maybe String))) `shouldBe` + "Json.Decode.map(l => List.fold_left ((m,(k,v)) => Map_651798451719185100.add(k,v,m)\n ,Map_651798451719185100.empty\n ,l)\n ,Json.Decode.list(Json.Decode.tuple2(Json.Decode.string,Json.Decode.optional(Json.Decode.string))))" + it "toReasonDecoderRef (IntMap (Maybe String))" $ + toReasonDecoderRef (Proxy :: Proxy (IntMap (Maybe String))) `shouldBe` + "Json.Decode.map(l => List.fold_left ((m,(k,v)) => Map_4250183808575061913.add(k,v,m)\n ,Map_4250183808575061913.empty\n ,l)\n ,Json.Decode.list(Json.Decode.tuple2(Json.Decode.int,Json.Decode.optional(Json.Decode.string))))" + +toReasonEncoderSpec :: Hspec.Spec +toReasonEncoderSpec = + describe "Convert to Reason encoders." $ do + it "toReasonEncoderSource Comment" $ + shouldMatchEncoderSource + (unlines + [ "open CommentType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Comment) + "test/CommentEncoder.re" + it "toReasonEncoderSource Post" $ + shouldMatchEncoderSource + (unlines + [ "open PostType;" + , "open CommentEncoder;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Post) + "test/PostEncoder.re" + it "toReasonEncoderSourceWithOptions Comment" $ + shouldMatchEncoderSource + (unlines + [ "open CommentTypeWithOptions;" + , "" + , "%s" + ]) + (defaultOptions {fieldLabelModifier = withPrefix "comment"}) + (Proxy :: Proxy Comment) + "test/CommentEncoderWithOptions.re" + it "toReasonEncoderSourceWithOptions Post" $ + shouldMatchEncoderSource + (unlines + [ "open PostTypeWithOptions;" + , "open CommentEncoder;" + , "" + , "%s" + ]) + (defaultOptions {fieldLabelModifier = withPrefix "post"}) + (Proxy :: Proxy Post) + "test/PostEncoderWithOptions.re" + it "toReasonEncoderSource Position" $ + shouldMatchEncoderSource + (unlines + [ "open PositionType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Position) + "test/PositionEncoder.re" + it "toReasonEncoderSource Position" $ + shouldMatchEncoderSource + (unlines + [ "open ShadowingType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Shadowing) + "test/ShadowingEncoder.re" + it "toReasonEncoderSourceWithOptions Timing" $ + shouldMatchEncoderSource + (unlines + [ "open TimingType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Timing) + "test/TimingEncoder.re" + it "toReasonEncoderSourceWithOptions Monstrosity" $ + shouldMatchEncoderSource + (unlines + [ "open MonstrosityType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Monstrosity) + "test/MonstrosityEncoder.re" + it "toReasonEncoderSourceWithOptions Useless" $ + shouldMatchEncoderSource + (unlines + [ "open UselessType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Useless) + "test/UselessEncoder.re" + it "toReasonEncoderSourceWithOptions Unit" $ + shouldMatchEncoderSource + (unlines + [ "open UnitType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Unit) + "test/UnitEncoder.re" + it "toReasonEncoderSourceWithOptions Wrapper" $ + shouldMatchEncoderSource + (unlines + [ "open WrapperType;" + , "" + , "%s" + ]) + defaultOptions + (Proxy :: Proxy Wrapper) + "test/WrapperEncoder.re" + describe "Convert to Reason encoder references." $ do + it "toReasonEncoderRef Post" $ + toReasonEncoderRef (Proxy :: Proxy Post) `shouldBe` "encodePost" + it "toReasonEncoderRef [Comment]" $ + toReasonEncoderRef (Proxy :: Proxy [Comment]) `shouldBe` + "(Json.Encode.list(encodeComment))" + it "toReasonEncoderRef Position" $ + toReasonEncoderRef (Proxy :: Proxy Position) `shouldBe` "encodePosition" + it "toReasonEncoderRef Timing" $ + toReasonEncoderRef (Proxy :: Proxy Timing) `shouldBe` "encodeTiming" + it "toReasonEncoderRef Monstrosity" $ + toReasonEncoderRef (Proxy :: Proxy Monstrosity) `shouldBe` "encodeMonstrosity" + it "toReasonEncoderRef String" $ + toReasonEncoderRef (Proxy :: Proxy String) `shouldBe` "Json.Encode.string" + it "toReasonEncoderRef (Maybe String)" $ + toReasonEncoderRef (Proxy :: Proxy (Maybe String)) `shouldBe` + "(Json.Encode.nullable(Json.Encode.string))" + it "toReasonEncoderRef [Maybe String]" $ + toReasonEncoderRef (Proxy :: Proxy [Maybe String]) `shouldBe` + "(Json.Encode.list((Json.Encode.nullable(Json.Encode.string))))" + it "toReasonEncoderRef (Map String (Maybe String))" $ + toReasonEncoderRef (Proxy :: Proxy (Map String (Maybe String))) `shouldBe` + "((x) => Json.Encode.list(Json.Encode.tuple2(Json.Encode.string\n ,(Json.Encode.nullable(Json.Encode.string))))(Map_651798451719185100.bindings(x)))" + it "toReasonEncoderRef (IntMap (Maybe String))" $ + toReasonEncoderRef (Proxy :: Proxy (IntMap (Maybe String))) `shouldBe` + "((x) => Json.Encode.list(Json.Encode.tuple2(Json.Encode.int\n ,(Json.Encode.nullable(Json.Encode.string))))(Map_4250183808575061913.bindings(x)))" + +moduleSpecsSpec :: Hspec.Spec +moduleSpecsSpec = + describe "Generating a module Spec" $ do + let mySpec = + moduleSpec ["My", "Module"] $ do + renderType (Proxy :: Proxy Post) + renderDecoder (Proxy :: Proxy Post) + renderType (Proxy :: Proxy Comment) + it "sets the module namespace" $ + namespace mySpec `shouldBe` ["My", "Module"] + it "inserts the correct imports" $ + head (declarations mySpec) `shouldBe` + intercalate + "\n" + [ "import module Map_651798451719185100 = Map.Make({ type t = string; let compare = compare });" ] + +shouldMatchTypeSource + :: ReasonType a + => String -> Options -> a -> FilePath -> IO () +shouldMatchTypeSource wrapping options x = + shouldMatchFile . printf wrapping $ toReasonTypeSourceWith options x + +shouldMatchDecoderSource + :: ReasonType a + => String -> Options -> a -> FilePath -> IO () +shouldMatchDecoderSource wrapping options x = + shouldMatchFile . printf wrapping $ toReasonDecoderSourceWith options x + +shouldMatchEncoderSource + :: ReasonType a + => String -> Options -> a -> FilePath -> IO () +shouldMatchEncoderSource wrapping options x = + shouldMatchFile . printf wrapping $ toReasonEncoderSourceWith options x + +shouldMatchFile :: String -> FilePath -> IO () +shouldMatchFile actual fileExpected = do + source <- readFile fileExpected + actual `shouldBeDiff` (fileExpected, source) + +shouldBeDiff :: String -> (String, String) -> Assertion +shouldBeDiff a (fpath, b) = + assertBool + ("< generated\n" <> "> " <> fpath <> "\n" <> + DiffOutput.ppDiff (Diff.getGroupedDiff (lines a) (lines b))) + (a == b) + +initCap :: Text -> Text +initCap t = + case uncons t of + Nothing -> t + Just (c, cs) -> cons (Data.Char.toUpper c) cs + +withPrefix :: Text -> Text -> Text +withPrefix prefix s = prefix <> initCap s diff --git a/test/FavoritePlacesType.re b/test/FavoritePlacesType.re new file mode 100644 --- /dev/null +++ b/test/FavoritePlacesType.re @@ -0,0 +1,6 @@ +open PositionType; +module Map_651798451719185100 = Map.Make({ type t = string; let compare = compare }); + +type favoritePlaces = + { positionsByUser : Map_651798451719185100.t (list (position)) + } diff --git a/test/MonstrosityDecoder.re b/test/MonstrosityDecoder.re new file mode 100644 --- /dev/null +++ b/test/MonstrosityDecoder.re @@ -0,0 +1,18 @@ +open MonstrosityType; + +let rec decodeMonstrosity = json => + + json |> (Json.Decode.field("type", Json.Decode.string) + |> Json.Decode.andThen + ((x) => switch(x) + { + | "NotSpecial" => json => NotSpecial + | "OkayIGuess" => json => OkayIGuess(json |> Json.Decode.field("arg0" + ,decodeMonstrosity)) + | "Ridiculous" => json => Ridiculous(json |> Json.Decode.field ("arg0" + ,Json.Decode.int), + json |> Json.Decode.field ("arg1" + ,Json.Decode.string), + json |> Json.Decode.field ("arg2" + ,Json.Decode.list(decodeMonstrosity)),) + | _ => failwith("unknown constructor")})) diff --git a/test/MonstrosityEncoder.re b/test/MonstrosityEncoder.re new file mode 100644 --- /dev/null +++ b/test/MonstrosityEncoder.re @@ -0,0 +1,18 @@ +open MonstrosityType; + +let rec encodeMonstrosity = (x : monstrosity) => + switch(x) { + | NotSpecial => + Json.Encode.object_ + ([( "type", Json.Encode.string("NotSpecial") ),]) + | OkayIGuess(arg0) => + Json.Encode.object_ + ([( "type", Json.Encode.string("OkayIGuess") ), + ( "arg0", encodeMonstrosity(arg0) ),]) + + | Ridiculous(arg0,arg1,arg2) => + Json.Encode.object_ + ([( "type", Json.Encode.string("Ridiculous") ), + ( "arg0", Json.Encode.int(arg0) ), + ( "arg1", Json.Encode.string(arg1) ), + ( "arg2", (Json.Encode.list(encodeMonstrosity))(arg2) ),])} diff --git a/test/MonstrosityType.re b/test/MonstrosityType.re new file mode 100644 --- /dev/null +++ b/test/MonstrosityType.re @@ -0,0 +1,4 @@ +type monstrosity = + | NotSpecial + | OkayIGuess(monstrosity) + | Ridiculous(int, string, (list (monstrosity))) diff --git a/test/PositionDecoder.re b/test/PositionDecoder.re new file mode 100644 --- /dev/null +++ b/test/PositionDecoder.re @@ -0,0 +1,12 @@ +open PositionType; + +let rec decodePosition = json => + + json |> (Json.Decode.field("type", Json.Decode.string) + |> Json.Decode.andThen + ((x) => switch(x) + { + | "Beginning" => json => Beginning + | "Middle" => json => Middle + | "End" => json => End + | _ => failwith("unknown constructor")})) diff --git a/test/PositionEncoder.re b/test/PositionEncoder.re new file mode 100644 --- /dev/null +++ b/test/PositionEncoder.re @@ -0,0 +1,7 @@ +open PositionType; + +let rec encodePosition = (x : position) => + switch(x) { + | Beginning => Json.Encode.object_([( "type", Json.Encode.string("Beginning") )]) + | Middle => Json.Encode.object_([( "type", Json.Encode.string("Middle") )]) + | End => Json.Encode.object_([( "type", Json.Encode.string("End") )])} diff --git a/test/PositionType.re b/test/PositionType.re new file mode 100644 --- /dev/null +++ b/test/PositionType.re @@ -0,0 +1,4 @@ +type position = + | Beginning + | Middle + | End diff --git a/test/PostDecoder.re b/test/PostDecoder.re new file mode 100644 --- /dev/null +++ b/test/PostDecoder.re @@ -0,0 +1,17 @@ +open PostType; +open CommentDecoder; + +let rec decodePost = json => + { + id : json |> Json.Decode.field ("id" + ,Json.Decode.int), + name : json |> Json.Decode.field ("name" + ,Json.Decode.string), + age : json |> Json.Decode.field ("age" + ,Json.Decode.optional(Json.Decode.float)), + comments : json |> Json.Decode.field ("comments" + ,Json.Decode.list(decodeComment)), + promoted : json |> Json.Decode.field ("promoted" + ,Json.Decode.optional(decodeComment)), + author : json |> Json.Decode.field ("author" + ,Json.Decode.optional(Json.Decode.string)),} diff --git a/test/PostDecoderWithOptions.re b/test/PostDecoderWithOptions.re new file mode 100644 --- /dev/null +++ b/test/PostDecoderWithOptions.re @@ -0,0 +1,17 @@ +open PostTypeWithOptions; +open CommentDecoder; + +let rec decodePost = json => + { + postId : json |> Json.Decode.field ("postId" + ,Json.Decode.int), + postName : json |> Json.Decode.field ("postName" + ,Json.Decode.string), + postAge : json |> Json.Decode.field ("postAge" + ,Json.Decode.optional(Json.Decode.float)), + postComments : json |> Json.Decode.field ("postComments" + ,Json.Decode.list(decodeComment)), + postPromoted : json |> Json.Decode.field ("postPromoted" + ,Json.Decode.optional(decodeComment)), + postAuthor : json |> Json.Decode.field ("postAuthor" + ,Json.Decode.optional(Json.Decode.string)),} diff --git a/test/PostEncoder.re b/test/PostEncoder.re new file mode 100644 --- /dev/null +++ b/test/PostEncoder.re @@ -0,0 +1,12 @@ +open PostType; +open CommentEncoder; + +let rec encodePost = (x : post) => + Json.Encode.object_ + ([ ( "id", Json.Encode.int(x.id) ) + , ( "name", Json.Encode.string(x.name) ) + , ( "age", (Json.Encode.nullable(Json.Encode.float))(x.age) ) + , ( "comments", (Json.Encode.list(encodeComment))(x.comments) ) + , ( "promoted", (Json.Encode.nullable(encodeComment))(x.promoted) ) + , ( "author", (Json.Encode.nullable(Json.Encode.string))(x.author) ) + ]) diff --git a/test/PostEncoderWithOptions.re b/test/PostEncoderWithOptions.re new file mode 100644 --- /dev/null +++ b/test/PostEncoderWithOptions.re @@ -0,0 +1,12 @@ +open PostTypeWithOptions; +open CommentEncoder; + +let rec encodePost = (x : post) => + Json.Encode.object_ + ([ ( "postId", Json.Encode.int(x.postId) ) + , ( "postName", Json.Encode.string(x.postName) ) + , ( "postAge", (Json.Encode.nullable(Json.Encode.float))(x.postAge) ) + , ( "postComments", (Json.Encode.list(encodeComment))(x.postComments) ) + , ( "postPromoted", (Json.Encode.nullable(encodeComment))(x.postPromoted) ) + , ( "postAuthor", (Json.Encode.nullable(Json.Encode.string))(x.postAuthor) ) + ]) diff --git a/test/PostType.re b/test/PostType.re new file mode 100644 --- /dev/null +++ b/test/PostType.re @@ -0,0 +1,10 @@ +open CommentType + +type post = + { id : int + , name : string + , age : option (float) + , comments : list (comment) + , promoted : option (comment) + , author : option (string) + } diff --git a/test/PostTypeWithOptions.re b/test/PostTypeWithOptions.re new file mode 100644 --- /dev/null +++ b/test/PostTypeWithOptions.re @@ -0,0 +1,10 @@ +open CommentType; + +type post = + { postId : int + , postName : string + , postAge : option (float) + , postComments : list (comment) + , postPromoted : option (comment) + , postAuthor : option (string) + } diff --git a/test/ShadowingDecoder.re b/test/ShadowingDecoder.re new file mode 100644 --- /dev/null +++ b/test/ShadowingDecoder.re @@ -0,0 +1,9 @@ +open ShadowingType; + +let rec decodeShadowing = json => + { + prop : json |> Json.Decode.field ("prop" + ,Json.Decode.tuple2(Json.Decode.tuple2(Json.Decode.int + ,Json.Decode.int) + ,Json.Decode.tuple2(Json.Decode.string + ,Json.Decode.string))),} diff --git a/test/ShadowingEncoder.re b/test/ShadowingEncoder.re new file mode 100644 --- /dev/null +++ b/test/ShadowingEncoder.re @@ -0,0 +1,9 @@ +open ShadowingType; + +let rec encodeShadowing = (x : shadowing) => + Json.Encode.object_ + ([ ( "prop", Json.Encode.tuple2(Json.Encode.tuple2(Json.Encode.int + ,Json.Encode.int) + ,Json.Encode.tuple2(Json.Encode.string + ,Json.Encode.string))(x.prop) ) + ]) diff --git a/test/ShadowingType.re b/test/ShadowingType.re new file mode 100644 --- /dev/null +++ b/test/ShadowingType.re @@ -0,0 +1,3 @@ +type shadowing = + { prop : ((int, int), (string, string)) + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TimingDecoder.re b/test/TimingDecoder.re new file mode 100644 --- /dev/null +++ b/test/TimingDecoder.re @@ -0,0 +1,13 @@ +open TimingType; + +let rec decodeTiming = json => + + json |> (Json.Decode.field("type", Json.Decode.string) + |> Json.Decode.andThen + ((x) => switch(x) + { + | "Start" => json => Start + | "Continue" => json => Continue(json |> Json.Decode.field("arg0" + ,Json.Decode.float)) + | "Stop" => json => Stop + | _ => failwith("unknown constructor")})) diff --git a/test/TimingEncoder.re b/test/TimingEncoder.re new file mode 100644 --- /dev/null +++ b/test/TimingEncoder.re @@ -0,0 +1,15 @@ +open TimingType; + +let rec encodeTiming = (x : timing) => + switch(x) { + | Start => + Json.Encode.object_ + ([( "type", Json.Encode.string("Start") ),]) + | Continue(arg0) => + Json.Encode.object_ + ([( "type", Json.Encode.string("Continue") ), + ( "arg0", Json.Encode.float(arg0) ),]) + + | Stop => + Json.Encode.object_ + ([( "type", Json.Encode.string("Stop") ),])} diff --git a/test/TimingType.re b/test/TimingType.re new file mode 100644 --- /dev/null +++ b/test/TimingType.re @@ -0,0 +1,4 @@ +type timing = + | Start + | Continue(float) + | Stop diff --git a/test/UnitDecoder.re b/test/UnitDecoder.re new file mode 100644 --- /dev/null +++ b/test/UnitDecoder.re @@ -0,0 +1,4 @@ +open UnitType; + +let rec decodeUnit = json => + json |> Json.Decode.nullAs(Unit) diff --git a/test/UnitEncoder.re b/test/UnitEncoder.re new file mode 100644 --- /dev/null +++ b/test/UnitEncoder.re @@ -0,0 +1,4 @@ +open UnitType; + +let rec encodeUnit = (x : unit) => + Json.Encode.null diff --git a/test/UnitType.re b/test/UnitType.re new file mode 100644 --- /dev/null +++ b/test/UnitType.re @@ -0,0 +1,2 @@ +type unit = + | Unit diff --git a/test/UselessDecoder.re b/test/UselessDecoder.re new file mode 100644 --- /dev/null +++ b/test/UselessDecoder.re @@ -0,0 +1,4 @@ +open UselessType; + +let rec decodeUseless = json => + json |> Json.Decode.nullAs(Useless) diff --git a/test/UselessEncoder.re b/test/UselessEncoder.re new file mode 100644 --- /dev/null +++ b/test/UselessEncoder.re @@ -0,0 +1,4 @@ +open UselessType; + +let rec encodeUseless = (x : useless) => + Json.Encode.null diff --git a/test/UselessType.re b/test/UselessType.re new file mode 100644 --- /dev/null +++ b/test/UselessType.re @@ -0,0 +1,2 @@ +type useless = + | Useless diff --git a/test/WrapperDecoder.re b/test/WrapperDecoder.re new file mode 100644 --- /dev/null +++ b/test/WrapperDecoder.re @@ -0,0 +1,5 @@ +open WrapperType; + +let rec decodeWrapper = json => + Wrapper (json |> Json.Decode.field ("arg0" + ,Json.Decode.int),) diff --git a/test/WrapperEncoder.re b/test/WrapperEncoder.re new file mode 100644 --- /dev/null +++ b/test/WrapperEncoder.re @@ -0,0 +1,5 @@ +open WrapperType; + +let rec encodeWrapper = (x : wrapper) => + switch(x) { + | Wrapper(y0) => Json.Encode.int(y0)} diff --git a/test/WrapperType.re b/test/WrapperType.re new file mode 100644 --- /dev/null +++ b/test/WrapperType.re @@ -0,0 +1,2 @@ +type wrapper = + | Wrapper(int)