diff --git a/reason-export.cabal b/reason-export.cabal --- a/reason-export.cabal +++ b/reason-export.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 7015fd5b78c9fc1af9039309e0fac1f7ab108a7c6f2ecbf73a88bd98fd64fb61 +-- hash: 301ed4c6277166825ece93357a0ba2513d50ae09b76e02dbaaa0b76195df45b2 name: reason-export -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Generate Reason types from Haskell description: Please see the README on GitHub at category: Web diff --git a/src/Reason/Decoder.hs b/src/Reason/Decoder.hs --- a/src/Reason/Decoder.hs +++ b/src/Reason/Decoder.hs @@ -43,57 +43,56 @@ (_, tyargs) <- renderConstructorArgs' 0 value pure $ case tyargs of [] -> stext name - [(r0,a0)] -> stext name <> parens (stext "json |> " <> r0) + [(r0,_)] -> stext name <> parens (stext "json |> " <> r0) [(r0,a0), (r1,a1)] -> parens (parens (tupled [a0, a1]) <+> "=>" <+> stext name <> tupled [a0, a1]) <> parens (stext "json |> Json.Decode.tuple2" <> tupled [r0, r1]) [(r0,a0), (r1,a1), (r2,a2)] -> parens (parens (tupled [a0, a1]) <+> "=>" <+> stext name <> tupled [a0, a1, a2]) - <> parens (stext "json |> Json.Decode.tuple2" <> tupled [r0, r1, r2]) + <> parens (stext "json |> Json.Decode.tuple3" <> tupled [r0, r1, r2]) [(r0,a0), (r1,a1), (r2,a2) , (r3,a3)] -> parens (parens (tupled [a0, a1]) <+> "=>" <+> stext name <> tupled [a0, a1, a2, a3]) - <> parens (stext "json |> Json.Decode.tuple2" <> tupled [r0, r1, r2, r3]) + <> parens (stext "json |> Json.Decode.tuple4" <> tupled [r0, r1, r2, r3]) _ -> error "Bare constructors with more than 4 arguments are not supported, use records" render (NamedConstructor name value) = do - (n, val) <- renderConstructorArgs 0 value + (_, 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 + render mc@(MultipleConstructors constrs) = do + cstrs <- mapM renderSum constrs + pure $ line <> indent 4 ("json |>" <+> parens - (constructorName <$$> indent 4 + ((if isEnumeration mc then + "Json.Decode.string" else + "Json.Decode.field(\"tag\", Json.Decode.string)") + <$$> 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) + pure $ "|" <+> dquotes (stext name) <+> "=> json =>" <+> 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 ReasonEmpty) = do + renderSumCondition name (stext name) +renderSum n@(NamedConstructor name (Values _ _)) = do + r <- render n + renderSumCondition name r renderSum (NamedConstructor name value) = do - val <- render value - renderSumCondition name $ "json |> Json.Decode.field" <> tupled [dquotes "arg0", val] + r <- render value + renderSumCondition name (stext name <> parens ("json |> Json.Decode.field(\"contents\", " <> r <> ")")) renderSum (RecordConstructor name value) = do val <- render value - renderSumCondition name val + renderSumCondition name (stext name <> indent 0 (parens ("{" <> val <> "}"))) renderSum (MultipleConstructors constrs) = foldl1 (<$$>) <$> mapM renderSum constrs @@ -152,6 +151,11 @@ dx <- renderRef x dy <- renderRef y return $ "Json.Decode.tuple2" <> tupled [dx, dy] + renderRef (RTuple3 x y z) = do + dx <- renderRef x + dy <- renderRef y + dz <- renderRef z + return $ "Json.Decode.tuple3" <> tupled [dx, dy, dz] renderRef RUnit = pure "Json.Decode.nullAs" renderRef RTimePosix = pure "Json.Decode.date" renderRef RInt = pure "Json.Decode.int" diff --git a/src/Reason/Encoder.hs b/src/Reason/Encoder.hs --- a/src/Reason/Encoder.hs +++ b/src/Reason/Encoder.hs @@ -58,35 +58,41 @@ dc <- mapM rndr constrs return . nest 4 $ "switch(x)" <+> (braces $ line <> foldl1 (<$$>) dc) -jsonEncodeObject :: Doc -> Doc -> [Doc] -> Doc -jsonEncodeObject constructor tag contents = +jsonEncodeObject :: Doc -> Doc -> Either [(Doc,Doc)] Doc -> Doc +jsonEncodeObject constructor tag (Left []) = + nest 4 $ "|" <+> constructor <$$> nest 4 ("Json.Encode.object_" <$$> parens (brackets (tag))) +jsonEncodeObject constructor tag (Left 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)))) + [(v,a)] -> line <> indent 2 (parens ("\"contents\"" <> comma <+> v <> parens a)) + _ -> line <> indent 2 (parens ("\"contents\"" <> comma <+> "Json.Encode.jsonArray([|" + <$$> indent 2 (vcat (punctuate "," (map (\(r,a) -> r <> parens a) contents))) + <$$> "|])")))))) +jsonEncodeObject constructor tag (Right contents) = + nest 4 $ "|" <+> constructor <$$> + nest 4 ("Json.Encode.object_" <$$> + parens (brackets (tag <> comma <> contents))) renderSum :: ReasonConstructor -> RenderM Doc -renderSum c@(NamedConstructor name ReasonEmpty) = do - dc <- render c +renderSum (NamedConstructor name ReasonEmpty) = do let cs = stext name <+> "=>" let tag = pair (dquotes "tag") ("Json.Encode.string" <> parens (dquotes (stext name))) - return $ jsonEncodeObject cs tag [] - + return $ jsonEncodeObject cs tag (Left []) renderSum (NamedConstructor name value) = do - ps <- collectParameters 0 value - let cs = stext name <> tupled (map fst ps) <+> "=>" + ps <- collectParameters' 0 value + let cs = stext name <> tupled (map snd ps) <+> "=>" let tag = pair (dquotes "tag") ("Json.Encode.string" <> parens (dquotes (stext name))) - return $ jsonEncodeObject cs tag (map (\(i,p) -> indent 4 (pair (dquotes i) p)) ps) - + return $ jsonEncodeObject cs tag (Left ps) renderSum (RecordConstructor name value) = do - dv <- render value - let cs = stext name <+> "=>" + -- dv <- render value + -- let ct = comma <+> dv + ct <- renderFields value + let cs = stext name <> parens (encloseSep "{" "}" "," (map (\(n,_,_) -> n) ct)) <+> "=>" let tag = pair (dquotes "tag") (dquotes $ stext name) - let ct = comma <+> dv - return $ jsonEncodeObject cs tag [ct] - + return $ jsonEncodeObject cs tag (Right (line <> indent 2 (vcat (punctuate "," (map (\(_,a,r) -> parens (dquotes a <> comma <+> r)) ct))))) renderSum (MultipleConstructors constrs) = do dc <- mapM renderSum constrs return $ foldl1 (<$+$>) dc @@ -94,14 +100,24 @@ renderEnumeration :: ReasonConstructor -> RenderM Doc renderEnumeration (NamedConstructor name _) = - return . nest 4 $ "|" <+> stext name <+> "=>" <+> - "Json.Encode.object_" <> parens (brackets (pair (dquotes "tag") ("Json.Encode.string" <> (parens (dquotes (stext name)))))) + return . nest 4 $ "|" <+> stext name <+> "=>" <+> "Json.Encode.string" <> (parens (dquotes (stext name))) renderEnumeration (MultipleConstructors constrs) = do dc <- mapM renderEnumeration constrs return $ foldl1 (<$$>) dc renderEnumeration c = render c +renderFields :: ReasonValue -> RenderM [(Doc, Doc, Doc)] +renderFields (ReasonField name value) = do + fieldModifier <- asks fieldLabelModifier + valueBody <- render value + pure $ [(stext name, stext (fieldModifier name), valueBody <> parens (stext name))] +renderFields (Values x y) = do + dx <- renderFields x + dy <- renderFields y + pure $ dx ++ dy +renderFields _ = error "renderFields ReasonValue: should not happen" + instance HasEncoder ReasonValue where render (ReasonField name value) = do fieldModifier <- asks fieldLabelModifier @@ -120,6 +136,7 @@ renderRef _ RTimePosix = pure $ "Json.Encode.date" renderRef _ RUnit = pure "Json.Encode.null" renderRef _ RInt = pure "Json.Encode.int" + renderRef _ RInt64 = pure "Json.Encode.int" renderRef _ RChar = pure "Json.Encode.char" renderRef _ RBool = pure "Json.Encode.bool" renderRef _ RFloat = pure "Json.Encode.float" @@ -135,6 +152,11 @@ dx <- renderRef (level + 1) x dy <- renderRef (level + 1) y return $ "Json.Encode.tuple2" <> tupled [dx, dy] + renderRef level (RTuple3 x y z) = do + dx <- renderRef (level + 1) x + dy <- renderRef (level + 1) y + dz <- renderRef (level + 1) z + return $ "Json.Encode.tuple3" <> tupled [dx, dy, dz] renderRef level (RMap k v) = do dk <- renderRef level k dv <- renderRef level v @@ -170,18 +192,6 @@ 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))] collectParameters' :: Int -> ReasonValue -> RenderM [(Doc,Doc)] collectParameters' _ ReasonEmpty = pure [] diff --git a/src/Reason/Record.hs b/src/Reason/Record.hs --- a/src/Reason/Record.hs +++ b/src/Reason/Record.hs @@ -59,7 +59,13 @@ empty else parens dv) render (MultipleConstructors constructors) = - mintercalate (line <> "|" <> space) <$> sequence (render <$> constructors) + mintercalate (line <> "|" <> space) + <$> (mapM (\c -> case c of + RecordConstructor n _ -> do + r <- render c + pure $ stext n <+> indent 0 r + _ -> render c) + constructors) instance HasType ReasonValue where render (ReasonRef name) = pure (stextLower name) diff --git a/test/ExportSpec.hs b/test/ExportSpec.hs --- a/test/ExportSpec.hs +++ b/test/ExportSpec.hs @@ -51,6 +51,8 @@ data Timing = Start | Continue Double + | Continue2 Double Double + | Continue3 { c3a :: Double, c3b :: Double } | Stop deriving (Generic, ReasonType) diff --git a/test/MonstrosityDecoder.re b/test/MonstrosityDecoder.re --- a/test/MonstrosityDecoder.re +++ b/test/MonstrosityDecoder.re @@ -2,17 +2,16 @@ let rec decodeMonstrosity = json => - json |> (Json.Decode.field("type", Json.Decode.string) + json |> (Json.Decode.field("tag", 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)),) + | "NotSpecial" => json => NotSpecial + | "OkayIGuess" => json => OkayIGuess(json |> Json.Decode.field("contents", decodeMonstrosity)) + | "Ridiculous" => json => (((arg0 + ,arg1)) => Ridiculous(arg0 + ,arg1 + ,arg2))(json |> Json.Decode.tuple3(Json.Decode.int + ,Json.Decode.string + ,Json.Decode.list(decodeMonstrosity))) | _ => failwith("unknown constructor")})) diff --git a/test/MonstrosityEncoder.re b/test/MonstrosityEncoder.re --- a/test/MonstrosityEncoder.re +++ b/test/MonstrosityEncoder.re @@ -4,15 +4,17 @@ switch(x) { | NotSpecial => Json.Encode.object_ - ([( "tag", Json.Encode.string("NotSpecial") ),]) + ([( "tag", Json.Encode.string("NotSpecial") )]) | OkayIGuess(arg0) => Json.Encode.object_ ([( "tag", Json.Encode.string("OkayIGuess") ), - ( "arg0", encodeMonstrosity(arg0) ),]) + ("contents", encodeMonstrosity(arg0))]) | Ridiculous(arg0,arg1,arg2) => Json.Encode.object_ ([( "tag", Json.Encode.string("Ridiculous") ), - ( "arg0", Json.Encode.int(arg0) ), - ( "arg1", Json.Encode.string(arg1) ), - ( "arg2", (Json.Encode.list(encodeMonstrosity))(arg2) ),])} + ("contents", Json.Encode.jsonArray([| + Json.Encode.int(arg0), + Json.Encode.string(arg1), + (Json.Encode.list(encodeMonstrosity))(arg2) + |]))])} diff --git a/test/PositionDecoder.re b/test/PositionDecoder.re --- a/test/PositionDecoder.re +++ b/test/PositionDecoder.re @@ -2,11 +2,11 @@ let rec decodePosition = json => - json |> (Json.Decode.field("type", Json.Decode.string) + json |> (Json.Decode.string |> Json.Decode.andThen ((x) => switch(x) { - | "Beginning" => json => Beginning - | "Middle" => json => Middle - | "End" => json => End + | "Beginning" => json => Beginning + | "Middle" => json => Middle + | "End" => json => End | _ => failwith("unknown constructor")})) diff --git a/test/PositionEncoder.re b/test/PositionEncoder.re --- a/test/PositionEncoder.re +++ b/test/PositionEncoder.re @@ -2,6 +2,6 @@ let rec encodePosition = (x : position) => switch(x) { - | Beginning => Json.Encode.object_([( "tag", Json.Encode.string("Beginning") )]) - | Middle => Json.Encode.object_([( "tag", Json.Encode.string("Middle") )]) - | End => Json.Encode.object_([( "tag", Json.Encode.string("End") )])} + | Beginning => Json.Encode.string("Beginning") + | Middle => Json.Encode.string("Middle") + | End => Json.Encode.string("End")} diff --git a/test/TimingDecoder.re b/test/TimingDecoder.re --- a/test/TimingDecoder.re +++ b/test/TimingDecoder.re @@ -2,12 +2,19 @@ let rec decodeTiming = json => - json |> (Json.Decode.field("type", Json.Decode.string) + json |> (Json.Decode.field("tag", 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 + | "Start" => json => Start + | "Continue" => json => Continue(json |> Json.Decode.field("contents", Json.Decode.float)) + | "Continue2" => json => (((arg0 + ,arg1)) => Continue2(arg0 + ,arg1))(json |> Json.Decode.tuple2(Json.Decode.float + ,Json.Decode.float)) + | "Continue3" => json => Continue3({c3a : json |> Json.Decode.field ("c3a" + ,Json.Decode.float), + c3b : json |> Json.Decode.field ("c3b" + ,Json.Decode.float),}) + | "Stop" => json => Stop | _ => failwith("unknown constructor")})) diff --git a/test/TimingEncoder.re b/test/TimingEncoder.re --- a/test/TimingEncoder.re +++ b/test/TimingEncoder.re @@ -4,12 +4,26 @@ switch(x) { | Start => Json.Encode.object_ - ([( "tag", Json.Encode.string("Start") ),]) + ([( "tag", Json.Encode.string("Start") )]) + | Continue(arg0) => Json.Encode.object_ ([( "tag", Json.Encode.string("Continue") ), - ( "arg0", Json.Encode.float(arg0) ),]) + ("contents", Json.Encode.float(arg0))]) + | Continue2(arg0,arg1) => + Json.Encode.object_ + ([( "tag", Json.Encode.string("Continue2") ), + ("contents", Json.Encode.jsonArray([| + Json.Encode.float(arg0), + Json.Encode.float(arg1) + |]))]) + | Continue3({c3a,c3b}) => + Json.Encode.object_ + ([( "tag", "Continue3" ), + ("c3a", Json.Encode.float(c3a)), + ("c3b", Json.Encode.float(c3b))]) + | Stop => Json.Encode.object_ - ([( "tag", Json.Encode.string("Stop") ),])} + ([( "tag", Json.Encode.string("Stop") )])} diff --git a/test/TimingType.re b/test/TimingType.re --- a/test/TimingType.re +++ b/test/TimingType.re @@ -1,4 +1,8 @@ type timing = | Start | Continue(float) + | Continue2(float, float) + | Continue3 { c3a : float + , c3b : float + } | Stop