elm-bridge 0.1.0.0 → 0.2.1.0

raw patch · 16 files changed

+1108/−210 lines, 16 filesdep +QuickCheckdep +aesondep +containersdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, aeson, containers, text

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +7/−2
• elm-bridge.cabal +27/−7
• examples/Example1.hs +1/−1
• src/Elm/Derive.hs +103/−61
• src/Elm/Json.hs +163/−62
• src/Elm/Module.hs +93/−10
• src/Elm/TyRender.hs +19/−11
• src/Elm/TyRep.hs +71/−14
• src/Elm/Utils.hs +22/−0
• test/Elm/DeriveSpec.hs +72/−5
• test/Elm/JsonSpec.hs +166/−15
• test/Elm/ModuleSpec.hs +76/−5
• test/Elm/TestHelpers.hs +0/−9
• test/Elm/TyRenderSpec.hs +6/−8
• test/EndToEnd.hs +271/−0

@@ -0,0 +1,11 @@+# v0.2.1++## New features++ * The template Haskell derivation functions now take `aeson` `Option` type instead of a custom type.+ This change makes it easier to synchronize the Haskell and Elm code.+ * The generated Elm code can be personalized. Helpers functions assist in converting type names, and defining which type will be newtyped.++## Notes++ * The generated Elm code depends on the [bartavelle/json-helpers](http://package.elm-lang.org/packages/bartavelle/json-helpers/1.1.0/) package.

@@ -11,6 +11,8 @@  Building the bridge from [Haskell](http://haskell.org) to [Elm](http://elm-lang.org) and back. Define types once, use on both sides and enjoy easy (de)serialisation. Cheers! +Note that the [bartavelle/json-helpers](http://package.elm-lang.org/packages/bartavelle/json-helpers/latest/) package, with version >= 1.1.0, is expected by the generated Elm modules.+ ## Usage  ```haskell@@ -26,7 +28,7 @@    , f_blablub :: Int    } deriving (Show, Eq) -deriveElmDef defaultOpts ''Foo+deriveBoth defaultOptions ''Foo  main :: IO () main =@@ -44,6 +46,7 @@ import Json.Decode import Json.Decode exposing ((:=)) import Json.Encode+import Json.Helpers exposing (..)   type alias Foo  =@@ -51,11 +54,13 @@    , f_blablub: Int    } -jsonDecFoo  =+jsonDecFoo : Json.Decode.Decoder ( Foo )+jsonDecFoo =    ("f_name" := Json.Decode.string) `Json.Decode.andThen` \pf_name ->    ("f_blablub" := Json.Decode.int) `Json.Decode.andThen` \pf_blablub ->    Json.Decode.succeed {f_name = pf_name, f_blablub = pf_blablub} +jsonEncFoo : Foo -> Value jsonEncFoo  val =    Json.Encode.object    [ ("f_name", Json.Encode.string val.f_name)

@@ -1,12 +1,12 @@ name:                elm-bridge-version:             0.1.0.0+version:             0.2.1.0 synopsis:            Derive Elm types from Haskell types description:         Building the bridge from Haskell to Elm and back. Define types once,                      use on both sides and enjoy easy (de)serialisation. Cheers!-homepage:            http://github.com/agrafix/derive-elm+homepage:            http://github.com/agrafix/elm-bridge license:             BSD3 license-file:        LICENSE-author:              Alexander Thiemann <mail@athiemann.net>+author:              Alexander Thiemann <mail@athiemann.net>, Simon Marechal <bartavelle@gmail.com> maintainer:          Alexander Thiemann <mail@athiemann.net> copyright:           (c) 2015 Alexander Thiemann category:            Web, Compiler, Language@@ -15,20 +15,39 @@  extra-source-files:     README.md+    CHANGELOG.md     examples/*.hs + library   hs-source-dirs:      src+  ghc-options:         -Wall   exposed-modules:                        Elm.Derive                        Elm.Json                        Elm.Module                        Elm.TyRender                        Elm.TyRep+  other-modules:       Elm.Utils   build-depends:       base >= 4.7 && < 5,-                       template-haskell+                       template-haskell,+-- There is a known bug in aeson 0.10.0.0 that is triggered by the derivation+-- function in some cases: https://github.com/bos/aeson/issues/293+                       aeson  == 0.9.*   default-language:    Haskell2010 +test-suite end-to-end-tests+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             EndToEnd.hs+  build-depends:       base,+                       elm-bridge,+                       aeson,+                       containers,+                       QuickCheck,+                       text+  default-language:    Haskell2010+ test-suite derive-elm-tests   type:                exitcode-stdio-1.0   hs-source-dirs:      test@@ -37,14 +56,15 @@                        Elm.DeriveSpec                        Elm.TyRenderSpec                        Elm.JsonSpec-                       Elm.TestHelpers                        Elm.ModuleSpec   build-depends:                        base,                        hspec >= 2.0,-                       elm-bridge+                       elm-bridge,+                       aeson,+                       containers   default-language:    Haskell2010  source-repository head   type:     git-  location: https://github.com/agrafix/derive-elm+  location: https://github.com/agrafix/elm-bridge

@@ -11,7 +11,7 @@    , f_blablub :: Int    } deriving (Show, Eq) -deriveElmDef defaultOpts ''Foo+deriveBoth defaultOptions ''Foo  main :: IO () main =

@@ -1,62 +1,91 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-| This module should be used to derive the Elm instance alongside the+ JSON ones. The prefered usage is to convert statements such as :++> $(deriveJSON defaultOptions{fieldLabelModifier = drop 4, constructorTagModifier = map toLower} ''D)++ into:++> $(deriveBoth defaultOptions{fieldLabelModifier = drop 4, constructorTagModifier = map toLower} ''D)++ Which will derive both the @aeson@ and @elm-bridge@ instances at the same+ time.+-}+ module Elm.Derive-    ( deriveElmDef, defaultOpts, DeriveOpts(..) )+    ( -- * Options+      A.Options(..)+    , A.SumEncoding(..)+    , defaultOptions+    , defaultOptionsDropLower+      -- * Template haskell functions+    , deriveElmDef+    , deriveBoth+    ) where  import Elm.TyRep  import Control.Monad+import Data.Aeson.TH (deriveJSON, SumEncoding(..))+import qualified Data.Aeson.TH as A import Language.Haskell.TH import Language.Haskell.TH.Syntax+import Data.Char (toLower)+import Control.Applicative+import Prelude -data DeriveOpts-   = DeriveOpts-   { do_fieldModifier :: String -> String-   , do_constrModifier :: String -> String-   }+-- | Note that This default set of options is distinct from that in+-- the @aeson@ package.+defaultOptions :: A.Options+defaultOptions = A.Options { A.sumEncoding             = A.ObjectWithSingleField+                           , A.fieldLabelModifier      = id+                           , A.constructorTagModifier  = id+                           , A.allNullaryToStringTag   = True+                           , A.omitNothingFields       = False+                           } -defaultOpts :: DeriveOpts-defaultOpts =-    DeriveOpts-    { do_fieldModifier = id-    , do_constrModifier = id-    }+{-| This generates a default set of options. The parameter represents the+number of characters that must be dropped from the Haskell field names.+The first letter of the field is then converted to lowercase, ie: -isConcreteType :: Type -> Bool-isConcreteType ty =-    case ty of-      AppT l r ->-          isConcreteType l-      ListT -> True+> data Foo = Foo { _fooBarQux :: Int }+> $(deriveBoth (defaultOptionsDropLower 4) ''Foo) -conCompiler :: String -> String-conCompiler s =-    case s of-      "Double" -> "Float"-      "Text" -> "String"-      "Vector" -> "List"-      _ -> s+Will be encoded as: +> {"barQux"=12}+-}+defaultOptionsDropLower :: Int -> A.Options+defaultOptionsDropLower n = defaultOptions { A.fieldLabelModifier = lower . drop n }+    where+        lower "" = ""+        lower (x:xs) = toLower x : xs+ compileType :: Type -> Q Exp compileType ty =     case ty of       ListT -> [|ETyCon (ETCon "List")|]       TupleT i -> [|ETyTuple i|]-      ConT name ->-          let n = conCompiler $ nameBase name-          in [|ETyCon (ETCon n)|]       VarT name ->           let n = nameBase name           in [|ETyVar (ETVar n)|]-      SigT ty _ ->-          compileType ty-      AppT a b ->-          let a1 = compileType a-              b1 = compileType b-          in [|ETyApp $a1 $b1|]+      SigT ty' _ ->+          compileType ty'+      AppT a b -> [|ETyApp $(compileType a) $(compileType b)|]+      ConT name ->+          let n = nameBase name+          in  [|ETyCon (ETCon n)|]       _ -> fail $ "Unsupported type: " ++ show ty +optSumType :: SumEncoding -> Q Exp+optSumType se =+    case se of+        TwoElemArray -> [|SumEncoding' TwoElemArray|]+        ObjectWithSingleField -> [|SumEncoding' ObjectWithSingleField|]+        TaggedObject tn cn -> [|SumEncoding' (TaggedObject tn cn)|]  runDerive :: Name -> [TyVarBndr] -> (Q Exp -> Q Exp) -> Q [Dec] runDerive name vars mkBody =@@ -89,58 +118,71 @@                 PlainTV tv -> tv                 KindedTV tv _ -> tv -deriveAlias :: DeriveOpts -> Name -> [TyVarBndr] -> Con -> Q [Dec]-deriveAlias opts name vars c =-    case c of-      RecC _ conFields ->-          let fields = listE $ map mkField conFields-          in runDerive name vars $ \typeName ->-                [|ETypeAlias (EAlias $typeName $fields)|]-      _ ->-          fail "Can only derive records like C { v :: Int, w :: a }"+deriveAlias :: A.Options -> Name -> [TyVarBndr] -> [VarStrictType] -> Q [Dec]+deriveAlias opts name vars conFields =+        runDerive name vars $ \typeName ->+                [|ETypeAlias (EAlias $typeName $fields omitNothing False)|] -- default to no newtype     where+      fields = listE $ map mkField conFields+      omitNothing = A.omitNothingFields opts       mkField :: VarStrictType -> Q Exp       mkField (fname, _, ftype) =           [|(fldName, $fldType)|]           where-            fldName = do_fieldModifier opts $ nameBase fname+            fldName = A.fieldLabelModifier opts $ nameBase fname             fldType = compileType ftype -deriveSum :: DeriveOpts -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]+deriveSum :: A.Options -> Name -> [TyVarBndr] -> [Con] -> Q [Dec] deriveSum opts name vars constrs =     runDerive name vars $ \typeName ->-        [|ETypeSum (ESum $typeName $sumOpts)|]+        [|ETypeSum (ESum $typeName $sumOpts $sumEncOpts omitNothing allNullary)|]     where-      sumOpts =-          listE $ map mkOpt constrs+      allNullary = A.allNullaryToStringTag opts+      sumEncOpts = optSumType (A.sumEncoding opts)+      omitNothing = A.omitNothingFields opts+      sumOpts = listE $ map mkOpt constrs       mkOpt :: Con -> Q Exp       mkOpt c =-          case c of-            NormalC name args ->-                let n = do_constrModifier opts $ nameBase name+        let modifyName = A.constructorTagModifier opts . nameBase+        in case c of+            NormalC name' args ->+                let n = modifyName name'                     tyArgs = listE $ map (\(_, ty) -> compileType ty) args-                in [|(n, $tyArgs)|]-            _ ->-                fail "Can only derive sum types with options like C Int a"+                in [|(n, Right $tyArgs)|]+            RecC name' args ->+                let n = modifyName name'+                    tyArgs = listE $ map (\(nm, _, ty) -> let nm' = A.fieldLabelModifier opts $ nameBase nm+                                                          in  [|(nm', $(compileType ty))|]) args+                in [|(n, Left $tyArgs)|]+            _ -> fail ("Can't derive this sum: " ++ show c) -deriveSynonym :: DeriveOpts -> Name -> [TyVarBndr] -> Type -> Q [Dec]-deriveSynonym opts name vars otherT =+deriveSynonym :: A.Options -> Name -> [TyVarBndr] -> Type -> Q [Dec]+deriveSynonym _ name vars otherT =     runDerive name vars $ \typeName ->         [|ETypePrimAlias (EPrimAlias $typeName $otherType)|]     where       otherType = compileType otherT -deriveElmDef :: DeriveOpts -> Name -> Q [Dec]+-- | Equivalent to running both 'deriveJSON' and 'deriveElmDef' with the+-- same options, so as to ensure the code on the Haskell and Elm size is+-- synchronized.+deriveBoth :: A.Options -> Name -> Q [Dec]+deriveBoth o n = (++) <$> deriveElmDef o n <*> deriveJSON o n++-- | Just derive the @elm-bridge@ definitions for generating the+-- serialization/deserialization code. It must be kept synchronized with+-- the Haskell code manually.+deriveElmDef :: A.Options -> Name -> Q [Dec] deriveElmDef opts name =     do TyConI tyCon <- reify name        case tyCon of          DataD _ _ tyVars constrs _ ->              case constrs of                [] -> fail "Can not derive empty data decls"-               [x] -> deriveAlias opts name tyVars x+               [RecC _ conFields] -> deriveAlias opts name tyVars conFields                _ -> deriveSum opts name tyVars constrs-         NewtypeD _ _ tyVars constr _ ->-             deriveAlias opts name tyVars constr+         NewtypeD _ _ tyVars (RecC _ conFields) _ ->+             deriveAlias opts name tyVars conFields          TySynD _ vars otherTy ->              deriveSynonym opts name vars otherTy-         _ -> fail "Oops, can only derive data and newtype"+         _ -> fail ("Oops, can only derive data and newtype, not this: " ++ show tyCon)

@@ -1,6 +1,10 @@ {- | This module implements a generator for JSON serialisers and parsers of arbitrary elm types.-Please note: It's still very hacky and might not work for all possible elm types yet.++It is highly recommended to either only use the functions of "Elm.Module", or to use the functions in this module+after having modified the 'ETypeDef' arguments with functions such as 'defaultAlterations'.++The reason is that Elm types might have an equivalent on the Haskell side and should be converted (ie. 'Text' -> 'String', 'Vector' -> 'List'). -} module Elm.Json     ( jsonParserForDef@@ -9,13 +13,25 @@ where  import Data.List-import Data.Maybe+import Data.Either (isLeft)+import Data.Aeson.Types (SumEncoding(..))  import Elm.TyRep+import Elm.Utils --- | Compile a JSON parser for an Elm type+data MaybeHandling = Root | Leaf+                   deriving Eq+ jsonParserForType :: EType -> String-jsonParserForType ty =+jsonParserForType = jsonParserForType' Leaf++isOption :: EType -> Bool+isOption (ETyApp (ETyCon (ETCon "Maybe")) _) = True+isOption _ = False++-- | Compile a JSON parser for an Elm type+jsonParserForType' :: MaybeHandling -> EType -> String+jsonParserForType' mh ty =     case ty of       ETyVar (ETVar v) -> "localDecoder_" ++ v       ETyCon (ETCon "Int") -> "Json.Decode.int"@@ -24,7 +40,12 @@       ETyCon (ETCon "Bool") -> "Json.Decode.bool"       ETyCon (ETCon c) -> "jsonDec" ++ c       ETyApp (ETyCon (ETCon "List")) t' -> "Json.Decode.list (" ++ jsonParserForType t' ++ ")"-      ETyApp (ETyCon (ETCon "Maybe")) t' -> "Json.Decode.maybe (" ++ jsonParserForType t' ++ ")"+      ETyApp (ETyCon (ETCon "Maybe")) t' -> if mh == Root+                                                then jsonParserForType t'+                                                else "Json.Decode.maybe (" ++ jsonParserForType t' ++ ")"+      ETyApp (ETyCon (ETCon "Set")) t' -> "decodeSet (" ++ jsonParserForType t' ++ ")"+      ETyApp (ETyApp (ETyCon (ETCon "Dict")) (ETyCon (ETCon "String")) ) value -> "Json.Decode.dict (" ++ jsonParserForType value ++ ")"+      ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "decodeMap (" ++ jsonParserForType key ++ ") (" ++ jsonParserForType value ++ ")"       _ ->           case unpackTupleType ty of             [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty@@ -32,11 +53,7 @@                 case unpackToplevelConstr x of                   (y : ys) ->                       jsonParserForType y ++ " "-                      ++ unwords (catMaybes $ map (\t' ->-                                                 case t' of-                                                   ETyVar _ -> Just $ "(" ++ jsonParserForType t' ++ ")"-                                                   _ -> Nothing-                                            ) ys)+                      ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")" ) ys)                   _ -> error $ "Do suitable json parser found for " ++ show ty             xs ->                 let tupleLen = length xs@@ -44,37 +61,96 @@                 in "Json.Decode.tuple" ++ show tupleLen ++ " (" ++ commas ++ ") "                     ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")") xs) +parseRecords :: Maybe ETypeName -> [(String, EType)] -> [String]+parseRecords newtyped fields = map mkField fields ++ ["   Json.Decode.succeed " ++ mkNewtype ("{" ++ intercalate ", " (map (\(fldName, _) -> fixReserved fldName ++ " = p" ++ fldName) fields) ++ "}")]+    where+        mkNewtype x = case newtyped of+                          Nothing -> x+                          Just nm -> "(" ++ et_name nm ++ " " ++ x ++ ")"+        mkField (fldName, fldType) =+           let (fldStart, fldEnd, mh) = if isOption fldType+                                            then ("(Json.Decode.maybe ", ")", Root)+                                            else ("", "", Leaf)+           in   "   " ++ fldStart ++ "(\"" ++ fldName ++ "\" := "+                      ++ jsonParserForType' mh fldType+                      ++ fldEnd+                      ++ ") `Json.Decode.andThen` \\p" ++ fldName ++ " ->"++-- | Checks that all the arguments to the ESum are unary values+allUnaries :: Bool -> [(String, Either [(String, EType)] [EType])] -> Maybe [String]+allUnaries False = const Nothing+allUnaries True  = mapM isUnary+    where+        isUnary (x, Right args) = if null args then Just x else Nothing+        isUnary _ = Nothing+ -- | Compile a JSON parser for an Elm type definition jsonParserForDef :: ETypeDef -> String jsonParserForDef etd =     case etd of-      ETypePrimAlias (EPrimAlias name ty) ->-          makeName name ++  " = " ++ jsonParserForType ty ++ "\n"-      ETypeAlias (EAlias name fields) ->-          makeName name ++ " = \n"-          ++ intercalate "\n" (map (\(fldName, fldType) -> "   (\"" ++ fldName ++ "\" := "-                                    ++ jsonParserForType fldType-                                    ++ ") `Json.Decode.andThen` \\p" ++ fldName ++ " -> ") fields)-          ++ "\n   Json.Decode.succeed {" ++ intercalate ", " (map (\(fldName, _) -> fldName ++ " = p" ++ fldName) fields) ++ "}\n"-      ETypeSum (ESum name opts) ->-          makeName name ++ " = \n"-          ++ "   Json.Decode.oneOf \n   [ "-          ++ intercalate "\n   , " (map mkOpt opts) ++ "\n"-          ++ "   ]\n"+      ETypePrimAlias (EPrimAlias name ty) -> unlines+          [ decoderType name+          , makeName name ++  " ="+          , jsonParserForType ty+          ]+      ETypeAlias (EAlias name fields _ newtyping) -> unlines+          ( decoderType name+          : (makeName name ++ " =")+          : parseRecords (if newtyping then Just name else Nothing) fields+          )+      ETypeSum (ESum name opts (SumEncoding' encodingType) _ unarystring) ->+            decoderType name ++ "\n" +++            makeName name ++ " =" +++                case allUnaries unarystring opts of+                    Just names -> " " ++ deriveUnaries names+                    Nothing    -> "\n" ++ encodingDictionnary ++ isObjectSet ++ "\n    in  " ++ declLine ++ "\n"           where-            mkOpt (name, args) =-                let argLen = length args-                in "(\"" ++ name ++ "\" := Json.tuple" ++ show argLen ++ " " ++ name ++ " "-                   ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")") args)-                   ++ ")"+            tab n s = replicate n ' ' ++ s+            typename = et_name name+            declLine = case encodingType of+                           ObjectWithSingleField -> unwords [ "decodeSumObjectWithSingleField ", show typename, dictName]+                           TwoElemArray          -> unwords [ "decodeSumTwoElemArray ", show typename, dictName ]+                           TaggedObject tg el    -> unwords [ "decodeSumTaggedObject", show typename, show tg, show el, dictName, isObjectSetName ]+            dictName = "jsonDecDict" ++ typename+            isObjectSetName = "jsonDecObjectSet" ++ typename+            deriveUnaries strs = unlines+                [ "decodeSumUnaries " ++ show typename ++ " " ++ dictName+                , dictName ++ " = Dict.fromList [" ++ intercalate ", " (map (\s -> "(" ++ show s ++ ", " ++ cap s ++ ")") strs ) ++ "]"+                ]+            encodingDictionnary = tab 4 "let " ++ dictName ++ " = Dict.fromList\n" ++ tab 12 "[ " ++ intercalate ("\n" ++ replicate 12 ' ' ++ ", ") (map dictEntry opts) ++ "\n" ++ tab 12 "]"+            isObjectSet = case encodingType of+                              TaggedObject _ _ -> "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " (map (show . fst) $ filter (isLeft . snd) opts) ++ "]")+                              _ -> ""+            dictEntry (oname, args) = "(" ++ show oname ++ ", " ++ mkDecoder oname args ++ ")"+            mkDecoder oname (Left args)  =  "Json.Decode.map "+                                         ++ cap oname+                                         ++ " ("+                                         ++ unwords (parseRecords Nothing args)+                                         ++ ")"+            mkDecoder oname (Right args) = unwords ( decodeFunction+                                                   : cap oname+                                                   : map (\t' -> "(" ++ jsonParserForType t' ++ ")") args+                                                   )+                where decodeFunction = case length args of+                                           0 -> "Json.Decode.succeed"+                                           1 -> "Json.Decode.map"+                                           n -> "Json.Decode.tuple" ++ show n     where-      makeName name =-           "jsonDec" ++ et_name name ++ " "-           ++ unwords (map (\tv -> "localDecoder_" ++ tv_name tv) $ et_args name)+      funcname name = "jsonDec" ++ et_name name+      prependTypes str = map (\tv -> str ++ tv_name tv) . et_args+      decoderType name = funcname name ++ " : " ++ intercalate " -> " (prependTypes "Json.Decode.Decoder " name ++ [decoderTypeEnd name])+      decoderTypeEnd name = unwords ("Json.Decode.Decoder" : "(" : et_name name : map tv_name (et_args name) ++ [")"])+      makeName name = unwords (funcname name : prependTypes "localDecoder_" name) --- | Compile a JSON serializer for an Elm type+{-| Compile a JSON serializer for an Elm type.++The 'omitNothingFields' option is currently not implemented!+-} jsonSerForType :: EType -> String-jsonSerForType ty =+jsonSerForType = jsonSerForType' False++jsonSerForType' :: Bool -> EType -> String+jsonSerForType' omitnull ty =     case ty of       ETyVar (ETVar v) -> "localEncoder_" ++ v       ETyCon (ETCon "Int") -> "Json.Encode.int"@@ -82,8 +158,12 @@       ETyCon (ETCon "String") -> "Json.Encode.string"       ETyCon (ETCon "Bool") -> "Json.Encode.bool"       ETyCon (ETCon c) -> "jsonEnc" ++ c-      ETyApp (ETyCon (ETCon "List")) t' -> "(Json.Encode.list << map " ++ jsonSerForType t' ++ ")"-      ETyApp (ETyCon (ETCon "Maybe")) t' -> "(\v -> case v of Just val -> " ++ jsonSerForType t' ++ " val Nothing -> Json.Encode.null)"+      ETyApp (ETyCon (ETCon "List")) t' -> "(Json.Encode.list << List.map " ++ jsonSerForType t' ++ ")"+      ETyApp (ETyCon (ETCon "Maybe")) t' -> if omitnull+                                                then jsonSerForType t'+                                                else "(maybeEncode (" ++ jsonSerForType t' ++ "))"+      ETyApp (ETyCon (ETCon "Set")) t' -> "(encodeSet " ++ jsonSerForType t' ++ ")"+      ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "encodeMap (" ++ jsonSerForType key ++ ") (" ++ jsonSerForType value ++ ")"       _ ->           case unpackTupleType ty of             [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty@@ -91,43 +171,64 @@                 case unpackToplevelConstr x of                   (y : ys) ->                       "(" ++ jsonSerForType y ++ " "-                      ++ unwords (catMaybes $ map (\t' ->-                                                 case t' of-                                                   ETyVar _ -> Just $ "(" ++ jsonSerForType t' ++ ")"-                                                   _ -> Nothing-                                            ) ys) ++ ")"+                      ++ unwords (map (\t' -> "(" ++ jsonSerForType t' ++ ")") ys)+                      ++ ")"                   _ -> error $ "Do suitable json serialiser found for " ++ show ty             xs ->-                let tupleLen = length xs-                    tupleArgsV = zip xs [1..]+                let tupleArgsV = zip xs ([1..] :: [Int])                     tupleArgs =-                        unwords $ map (\(_, v) -> "v" ++ show v) tupleArgsV-                in "(\\" ++ tupleArgs ++ " -> [" ++  intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType t' ++ ") v" ++ show idx) tupleArgsV) ++ "]"+                        intercalate "," $ map (\(_, v) -> "v" ++ show v) tupleArgsV+                in "(\\(" ++ tupleArgs ++ ") -> Json.Encode.list [" ++  intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType t' ++ ") v" ++ show idx) tupleArgsV) ++ "])" + -- | Compile a JSON serializer for an Elm type definition+-- TODO: handle the omit null case jsonSerForDef :: ETypeDef -> String jsonSerForDef etd =     case etd of       ETypePrimAlias (EPrimAlias name ty) ->-          makeName name ++  " = " ++ jsonSerForType ty ++ " val\n"-      ETypeAlias (EAlias name fields) ->-          makeName name ++ " = \n   Json.Encode.object\n   ["-          ++ intercalate "\n   ," (map (\(fldName, fldType) -> " (\"" ++ fldName ++ "\", " ++ jsonSerForType fldType ++ " val." ++ fldName ++ ")") fields)+          makeName name False ++  " = " ++ jsonSerForType ty ++ " val\n"+      ETypeAlias (EAlias name fields _ newtyping) ->+          makeName name newtyping ++ " =\n   Json.Encode.object\n   ["+          ++ intercalate "\n   ," (map (\(fldName, fldType) -> " (\"" ++ fldName ++ "\", " ++ jsonSerForType fldType ++ " val." ++ fixReserved fldName ++ ")") fields)           ++ "\n   ]\n"-      ETypeSum (ESum name opts) ->-          makeName name ++ " = \n"-          ++ "   case val of\n   "-          ++ intercalate "\n   " (map mkOpt opts) ++ "\n"+      ETypeSum (ESum name opts (SumEncoding' se) _ unarystring) ->+        case allUnaries unarystring opts of+            Nothing -> defaultEncoding+            Just strs -> unaryEncoding strs           where-            mkOpt (name, args) =-                let namedArgs = zip args [1..]-                    argList = unwords $ map (\(_, i) -> "v" ++ show i ) namedArgs-                    mkArg :: (EType, Int) -> String-                    mkArg (arg, idx) =-                        jsonSerForType arg ++ " v" ++ show idx-                in "   " ++ name ++ " " ++ argList ++ " -> [" ++ intercalate ", " (map mkArg namedArgs) ++ "]"+              encodeFunction = case se of+                                   ObjectWithSingleField -> "encodeSumObjectWithSingleField"+                                   TwoElemArray -> "encodeSumTwoElementArray"+                                   TaggedObject k c -> unwords ["encodeSumTaggedObject", show k, show c]+              defaultEncoding = unlines (+                ( makeName name False ++ " =")+                : "    let keyval v = case v of"+                :  (map (replicate 12 ' ' ++) (map mkcase opts))+                ++ [ "    " ++ unwords ["in", encodeFunction, "keyval", "val"] ]+                )+              unaryEncoding names = unlines (+                [ makeName name False ++ " ="+                , "    case val of"+                ] ++ map (\n -> replicate 8 ' ' ++ cap n ++ " -> Json.Encode.string " ++ show n) names+                )+              mkcase :: (String, Either [(String, EType)] [EType]) -> String+              mkcase (oname, Right args) = replicate 8 ' ' ++ cap oname ++ " " ++ argList args ++ " -> (" ++ show oname ++ ", " ++ mkEncodeList args ++ ")"+              mkcase (oname, Left args) = replicate 8 ' ' ++ cap oname ++ " vs -> (" ++ show oname ++ ", " ++ mkEncodeObject args ++ ")"+              argList a = unwords $ map (\i -> "v" ++ show i ) [1 .. length a]+              numargs :: (a -> String) -> [a] -> String+              numargs f = intercalate ", " . zipWith (\n a -> f a ++ " v" ++ show n)  ([1..] :: [Int])+              mkEncodeObject args = "encodeObject [" ++ intercalate ", " (map (\(n,t) -> "(" ++ show n ++ ", " ++ jsonSerForType t ++ " vs." ++ fixReserved n ++ ")") args) ++ "]"+              mkEncodeList [arg] = "encodeValue (" ++ jsonSerForType arg ++ " v1)"+              mkEncodeList args =  "encodeValue (Json.Encode.list [" ++ numargs jsonSerForType args ++ "])"     where-      makeName name =-           "jsonEnc" ++ et_name name ++ " "+      fname name = "jsonEnc" ++ et_name name+      makeType name = fname name ++ " : " ++ intercalate " -> " (map (mkLocalEncoder . tv_name) (et_args name) ++ [unwords (et_name name : map tv_name (et_args name)) , "Value"])+      mkLocalEncoder n = "(" ++ n ++ " -> Value)"+      makeName name newtyping =+           makeType name ++ "\n"+           ++ fname name ++ " "            ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name)-           ++ " val"+           ++ if newtyping+                  then " (" ++ et_name name ++ " val)"+                  else " val"

@@ -1,9 +1,14 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-}+{-|+Functions in this module are used to generate Elm modules. Note that the generated modules depend on the @bartavelle/json-helpers@ package.++-} module Elm.Module where  import Data.Proxy import Data.List+import Control.Arrow (second, (+++))  import Elm.TyRep import Elm.TyRender@@ -13,16 +18,94 @@ data DefineElm    = forall a. IsElmDefinition a => DefineElm (Proxy a) --- | Compile an Elm module-makeElmModule :: String -> [DefineElm] -> String-makeElmModule moduleName defs =-    "module " ++ moduleName ++ " where \n\n"-    ++ "import Json.Decode\n"-    ++ "import Json.Decode exposing ((:=))\n"-    ++ "import Json.Encode\n"-    ++ "\n\n"-    ++ intercalate "\n\n" (map mkDef defs)+-- | Creates an Elm module. This will use the default type conversion rules (to+-- convert @Vector@ to @List@, @HashMap a b@ to @List (a,b)@, etc.).+makeElmModule :: String -- ^ Module name+              -> [DefineElm] -- ^ List of definitions to be included in the module+              -> String+makeElmModule moduleName defs = unlines (+    [ "module " ++ moduleName ++ " where"+    , ""+    , "import Json.Decode"+    , "import Json.Decode exposing ((:=))"+    , "import Json.Encode exposing (Value)"+    , "-- The following module comes from bartavelle/json-helpers"+    , "import Json.Helpers exposing (..)"+    , ""+    , ""+    ]) ++ makeModuleContent defs+++-- | Generates the content of a module. You will be responsible for+-- including the required Elm headers. This uses the default type+-- conversion rules.+makeModuleContent :: [DefineElm] -> String+makeModuleContent = makeModuleContentWithAlterations defaultAlterations++-- | Generates the content of a module, using custom type conversion rules.+makeModuleContentWithAlterations :: (ETypeDef -> ETypeDef) -> [DefineElm] -> String+makeModuleContentWithAlterations alt = intercalate "\n\n" . map mkDef     where       mkDef (DefineElm proxy) =-          let def = compileElmDef proxy+          let def = alt (compileElmDef proxy)           in renderElm def ++ "\n" ++ jsonParserForDef def ++ "\n" ++ jsonSerForDef def ++ "\n"++{-| A helper function that will recursively traverse type definitions and let you convert types.++> myAlteration : ETypeDef -> ETypeDef+> myAlteration = recAlterType $ \t -> case t of+>                   ETyCon (ETCon "Integer") -> ETyCon (ETCon "Int")+>                   ETyCon (ETCon "Text")    -> ETyCon (ETCon "String")+>                   _                        -> t++-}+recAlterType :: (EType -> EType) -> ETypeDef -> ETypeDef+recAlterType f td = case td of+                     ETypeAlias a -> ETypeAlias (a { ea_fields = map (second f') (ea_fields a) })+                     ETypePrimAlias (EPrimAlias n t) -> ETypePrimAlias (EPrimAlias n (f' t))+                     ETypeSum s -> ETypeSum (s { es_options = map (second (map (second f') +++ map f')) (es_options s) })+    where+        f' (ETyApp a b) = f (ETyApp (f' a) (f' b))+        f' x = f x++-- | Given a list of type names, will @newtype@ all the matching type+-- definitions.+newtypeAliases :: [String] -> ETypeDef -> ETypeDef+newtypeAliases nts (ETypeAlias e) = ETypeAlias $ if et_name (ea_name e) `elem` nts+                                                     then e { ea_newtype = True }+                                                     else e+newtypeAliases _ x = x++{-| A default set of type conversion rules:++ * @HashSet a@, @Set a@ -> if @a@ is comparable, then @Set a@, else @List a@+ * @HashMap String v@, @Map String v@ -> @Dict String v@+ * @HashMap k v@, @Map k v@ -> @List (k, v)@+ * @Integer@ -> @Int@+ * @Text@ -> @String@+ * @Vector@ -> @List@+ * @Double@ -> @Float@+-}+defaultAlterations :: ETypeDef -> ETypeDef+defaultAlterations = recAlterType $ \t -> case t of+                                  ETyApp (ETyCon (ETCon "HashSet")) s             -> checkSet s+                                  ETyApp (ETyCon (ETCon "Set")) s                 -> checkSet s+                                  ETyApp (ETyApp (ETyCon (ETCon "HashMap")) k) v  -> checkMap k v+                                  ETyApp (ETyApp (ETyCon (ETCon "THashMap")) k) v -> checkMap k v+                                  ETyApp (ETyApp (ETyCon (ETCon "Map")) k) v      -> checkMap k v+                                  ETyCon (ETCon "Integer")                        -> ETyCon (ETCon "Int")+                                  ETyCon (ETCon "Text")                           -> ETyCon (ETCon "String")+                                  ETyCon (ETCon "Vector")                         -> ETyCon (ETCon "List")+                                  ETyCon (ETCon "Double")                         -> ETyCon (ETCon "Float")+                                  _                                               -> t+    where+        isString (ETyCon (ETCon "String")) = True+        isString _ = False+        isComparable (ETyCon (ETCon n)) = n `elem` ["String", "Int"]+        isComparable _ = False -- TODO check what Elm actually uses+        tc = ETyCon . ETCon+        checkMap k v | isString k = ETyApp (ETyApp (tc "Dict") k) v+                     | otherwise  = ETyApp (tc "List") (ETyApp (ETyApp (ETyTuple 2) k) v)+        checkSet s | isComparable s = ETyApp (ETyCon (ETCon "Set")) s+                   | otherwise = ETyApp (ETyCon (ETCon "List")) s+

@@ -1,6 +1,8 @@+{-| This module should not usually be imported. -} module Elm.TyRender where  import Elm.TyRep+import Elm.Utils  import Data.List @@ -20,12 +22,14 @@           [t] -> renderSingleTy t           xs -> "(" ++ intercalate ", " (map renderSingleTy xs) ++ ")"         where-          renderSingleTy ty =-              case ty of+          renderApp (ETyApp l r) = renderApp l ++ " " ++ renderElm r+          renderApp x = renderElm x+          renderSingleTy typ =+              case typ of                 ETyVar v -> renderElm v                 ETyCon c -> renderElm c-                ETyTuple n -> error "Library Bug: This should never happen!"-                ETyApp l r -> "(" ++ renderElm l ++ " " ++ renderElm r ++ ")"+                ETyTuple _ -> error "Library Bug: This should never happen!"+                ETyApp l r -> "(" ++ renderApp l ++ " " ++ renderElm r ++ ")"  instance ElmRenderable ETCon where     renderElm = tc_name@@ -38,19 +42,23 @@         et_name tyName ++ " " ++ unwords (map renderElm $ et_args tyName)  instance ElmRenderable EAlias where-    renderElm alias =-        "type alias " ++ renderElm (ea_name alias) ++ " = \n   { "-        ++ intercalate "\n   , " (map (\(fld, ty) -> fld ++ ": " ++ renderElm ty) (ea_fields alias))-        ++ "\n   }\n"+    renderElm alias = (if ea_newtype alias then withnewtype else nonewtype) ++ body+        where+            withnewtype = "type " ++ renderElm (ea_name alias) ++ " = " ++ et_name (ea_name alias)+            nonewtype = "type alias " ++ renderElm (ea_name alias) ++ " ="+            body = "\n   { "+                ++ intercalate "\n   , " (map (\(fld, ty) -> fixReserved fld ++ ": " ++ renderElm ty) (ea_fields alias))+                ++ "\n   }\n"  instance ElmRenderable ESum where     renderElm s =-        "type " ++ renderElm (es_name s) ++ " = \n    "+        "type " ++ renderElm (es_name s) ++ " =\n    "         ++ intercalate "\n    | " (map mkOpt (es_options s))         ++ "\n"         where-          mkOpt (name, types) =-              name ++ " " ++ unwords (map renderElm types)+          mkOpt (name, Left types) = cap name ++ " {" ++ intercalate ", " (map (\(fld, ty) -> fixReserved fld ++ ": " ++ renderElm ty) types) ++ "}"+          mkOpt (name, Right types) =+              cap name ++ " " ++ unwords (map renderElm types)  instance ElmRenderable EPrimAlias where     renderElm pa =

@@ -1,17 +1,24 @@+{-| This module defines how the derived Haskell data types are represented.+- It is useful for writing type conversion rules.+-} module Elm.TyRep where  import Data.List import Data.Proxy -class IsElmDefinition a where-    compileElmDef :: Proxy a -> ETypeDef+import Data.Aeson.Types (SumEncoding(..))+import Data.Monoid ((<>))+import Data.Maybe (fromMaybe) +-- | Type definition, including constructors. data ETypeDef    = ETypeAlias EAlias    | ETypePrimAlias EPrimAlias    | ETypeSum ESum      deriving (Show, Eq) +-- | Type construction : type variables, type constructors, tuples and type+-- application. data EType    = ETyVar ETVar    | ETyCon ETCon@@ -19,16 +26,29 @@    | ETyTuple Int    deriving (Show, Eq, Ord) +{-| Type constructor:++> ETCon "Int"+-} data ETCon    = ETCon    { tc_name :: String    } deriving (Show, Eq, Ord) +{-| Type variable:++> ETVar "a"+-} data ETVar    = ETVar    { tv_name :: String    } deriving (Show, Eq, Ord) ++{-| Type name:++> ETypeName "Map" [ETVar "k", ETVar "v"]+-} data ETypeName    = ETypeName    { et_name :: String@@ -45,25 +65,29 @@    = EAlias    { ea_name :: ETypeName    , ea_fields :: [(String, EType)]+   , ea_omit_null :: Bool+   , ea_newtype   :: Bool    } deriving (Show, Eq, Ord)  data ESum    = ESum-   { es_name :: ETypeName-   , es_options :: [(String, [EType])]+   { es_name          :: ETypeName+   , es_options       :: [(String, Either [(String, EType)] [EType])]+   , es_type          :: SumEncoding'+   , es_omit_null     :: Bool+   , es_unary_strings :: Bool    } deriving (Show, Eq, Ord) +-- | Transforms tuple types in a list of types. Otherwise returns+-- a singleton list with the original type. unpackTupleType :: EType -> [EType]-unpackTupleType t =-    unfoldr (\ty ->-                 case ty of-                   Just (ETyApp (ETyApp (ETyTuple i) r) r') ->-                       Just (r, Just r')-                   Just t ->-                       Just (t, Nothing)-                   Nothing ->-                       Nothing-            ) (Just t)+unpackTupleType et = fromMaybe [et] (extract et)+    where+        extract :: EType -> Maybe [EType]+        extract ty = case ty of+                         ETyApp (ETyTuple _) t -> return [t]+                         ETyApp app@(ETyApp _ _) t -> fmap (++ [t]) (extract app)+                         _ -> Nothing  unpackToplevelConstr :: EType -> [EType] unpackToplevelConstr t =@@ -77,3 +101,36 @@                     Just (r, Just l)                 _ ->                     Just (t', Nothing)++class IsElmDefinition a where+    compileElmDef :: Proxy a -> ETypeDef++newtype SumEncoding' = SumEncoding' SumEncoding++instance Show SumEncoding' where+    show (SumEncoding' se) = case se of+                                 TaggedObject n f -> "TaggedObject " ++ show n ++ " " ++ show f+                                 ObjectWithSingleField -> "ObjectWithSingleField"+                                 TwoElemArray -> "TwoElemArray"++instance Eq SumEncoding' where+    SumEncoding' a == SumEncoding' b = case (a,b) of+                                           (TaggedObject a1 b1, TaggedObject a2 b2) -> a1 == a2 && b1 == b2+                                           (ObjectWithSingleField, ObjectWithSingleField) -> True+                                           (TwoElemArray, TwoElemArray) -> True+                                           _ -> False++instance Ord SumEncoding' where+    compare (SumEncoding' a) (SumEncoding' b) =+       case (a,b) of+          (TaggedObject a1 b1, TaggedObject a2 b2) -> compare a1 a2 <> compare b1 b2+          (TaggedObject _ _, _) -> LT+          (_, TaggedObject _ _) -> GT+          (ObjectWithSingleField, ObjectWithSingleField) -> EQ+          (ObjectWithSingleField, _) -> LT+          (_, ObjectWithSingleField) -> GT+          (TwoElemArray, TwoElemArray) -> EQ++defSumEncoding :: SumEncoding'+defSumEncoding = SumEncoding' ObjectWithSingleField+

@@ -0,0 +1,22 @@+module Elm.Utils where++import Data.Char (toUpper)++cap :: String -> String+cap "" = ""+cap (x:xs) = toUpper x : xs++fixReserved :: String -> String+fixReserved x | x `elem` reservedWords = x ++ "_"+              | otherwise = x+    where+        reservedWords = [ "if", "then", "else"+                        , "case", "of"+                        , "let", "in"+                        , "type"+                        , "module", "where"+                        , "import", "as", "hiding", "exposing"+                        , "port", "export", "foreign"+                        , "perform"+                        , "deriving"+                        ]

@@ -6,6 +6,7 @@  import Data.Proxy import Test.Hspec+import Data.Char (toLower)  data Foo    = Foo@@ -21,14 +22,45 @@    , b_list :: [Bool]    } deriving (Show, Eq) +data Change a = Change { _before :: a, _after :: a }++data Baz a = Baz1 { _fOo :: Int, _qux :: a }+           | Baz2 { _bar :: Int, _sTr :: String }+           | Zob a++data Qux a = Qux1 { _quxfoo :: Int, _quxqux :: a }+           | Qux2 { _quxbar :: Int, _quxstr :: String }++data Test a = Test { _t1 :: Change Int+                   , _t2 :: Change a+                   }+ data SomeOpts a    = Okay Int    | NotOkay a -deriveElmDef defaultOpts ''Foo-deriveElmDef defaultOpts ''Bar-deriveElmDef defaultOpts ''SomeOpts+deriveElmDef defaultOptions ''Foo+deriveElmDef defaultOptions ''Bar+deriveElmDef defaultOptions ''SomeOpts+deriveElmDef defaultOptions { fieldLabelModifier = drop 1 . map toLower } ''Baz+deriveElmDef defaultOptions { fieldLabelModifier = drop 1 . map toLower } ''Test+deriveElmDef defaultOptions { fieldLabelModifier = drop 4 . map toLower, sumEncoding = TaggedObject "key" "value" } ''Qux +testElm :: ETypeDef+testElm = ETypeAlias $ EAlias+    { ea_name =+        ETypeName+        { et_name = "Test"+        , et_args = [ETVar {tv_name = "a"}]+        }+    , ea_fields =+        [ ("t1",ETyApp (ETyCon (ETCon {tc_name = "Change"})) (ETyCon (ETCon {tc_name = "Int"})))+        , ("t2",ETyApp (ETyCon (ETCon {tc_name = "Change"})) (ETyVar (ETVar {tv_name = "a"})))+        ]+    , ea_omit_null = False+    , ea_newtype = False+    }+ fooElm :: ETypeDef fooElm =     ETypeAlias $@@ -40,6 +72,8 @@           }     , ea_fields =         [("f_name",ETyCon (ETCon {tc_name = "String"})),("f_blablub",ETyCon (ETCon {tc_name = "Int"}))]+    , ea_omit_null = False+    , ea_newtype = False     }  barElm :: ETypeDef@@ -57,8 +91,35 @@         , ("b_tuple",ETyApp (ETyApp (ETyTuple 2) (ETyCon (ETCon {tc_name = "Int"}))) (ETyCon (ETCon {tc_name = "String"})))         , ("b_list",ETyApp (ETyCon (ETCon {tc_name = "List"})) (ETyCon (ETCon {tc_name = "Bool"})))         ]+    , ea_omit_null = False+    , ea_newtype = False     } +bazElm :: ETypeDef+bazElm = ETypeSum $ ESum+    { es_name = ETypeName {et_name = "Baz", et_args = [ETVar {tv_name = "a"}]}+    , es_options =+        [ ("Baz1",Left [("foo",ETyCon (ETCon {tc_name = "Int"})), ("qux",ETyVar (ETVar {tv_name = "a"}))])+        , ("Baz2",Left [("bar",ETyCon (ETCon {tc_name = "Int"})), ("str",ETyCon (ETCon {tc_name = "String"}))])+        , ("Zob",Right [ETyVar (ETVar {tv_name = "a"})])+        ]+    , es_type = SumEncoding' ObjectWithSingleField+    , es_omit_null = False+    , es_unary_strings = True+    }++quxElm :: ETypeDef+quxElm = ETypeSum $ ESum+    { es_name = ETypeName {et_name = "Qux", et_args = [ETVar {tv_name = "a"}]}+    , es_options =+        [ ("Qux1",Left [("foo",ETyCon (ETCon {tc_name = "Int"})), ("qux",ETyVar (ETVar {tv_name = "a"}))])+        , ("Qux2",Left [("bar",ETyCon (ETCon {tc_name = "Int"})), ("str",ETyCon (ETCon {tc_name = "String"}))])+        ]+    , es_type = SumEncoding' $ TaggedObject "key" "value"+    , es_omit_null = False+    , es_unary_strings = True+    }+ someOptsElm :: ETypeDef someOptsElm =     ETypeSum $@@ -69,9 +130,12 @@           , et_args = [ETVar {tv_name = "a"}]           }     , es_options =-        [ ("Okay",[ETyCon (ETCon {tc_name = "Int"})])-        , ("NotOkay",[ETyVar (ETVar {tv_name = "a"})])+        [ ("Okay", Right [ETyCon (ETCon {tc_name = "Int"})])+        , ("NotOkay", Right [ETyVar (ETVar {tv_name = "a"})])         ]+    , es_type = defSumEncoding+    , es_omit_null = False+    , es_unary_strings = True     }  spec :: Spec@@ -81,3 +145,6 @@     do compileElmDef (Proxy :: Proxy Foo) `shouldBe` fooElm        compileElmDef (Proxy :: Proxy (Bar a)) `shouldBe` barElm        compileElmDef (Proxy :: Proxy (SomeOpts a)) `shouldBe` someOptsElm+       compileElmDef (Proxy :: Proxy (Baz a)) `shouldBe` bazElm+       compileElmDef (Proxy :: Proxy (Qux a)) `shouldBe` quxElm+       compileElmDef (Proxy :: Proxy (Test a)) `shouldBe` testElm

@@ -5,10 +5,11 @@ import Elm.TyRep import Elm.Json -import Elm.TestHelpers- import Data.Proxy import Test.Hspec+import Data.Char (toLower)+import Data.Aeson.Types (SumEncoding(..))+import qualified Data.Map.Strict as M  data Foo    = Foo@@ -28,39 +29,189 @@    = Okay Int    | NotOkay a -$(deriveElmDef (fieldDropOpts 2) ''Foo)-$(deriveElmDef (fieldDropOpts 2) ''Bar)-$(deriveElmDef defaultOpts ''SomeOpts)+data UnaryA = UnaryA1 | UnaryA2+data UnaryB = UnaryB1 | UnaryB2 +data Change a = Change { _before :: a, _after :: a }++data Baz a = Baz1 { _foo :: Int, _qux :: M.Map Int a }+           | Baz2 { _bar :: Maybe Int, _str :: String }+           | Testing (Baz a)++data TestComp a = TestComp { _t1 :: Change Int+                           , _t2 :: Change a+                           }++-- TODO+data Qux a = Qux1 { _quxfoo :: Int, _quxqux :: a }+           | Qux2 Int (M.Map Int a)++$(deriveElmDef (defaultOptionsDropLower 2) ''Foo)+$(deriveElmDef (defaultOptionsDropLower 2) ''Bar)+$(deriveElmDef (defaultOptionsDropLower 1) ''TestComp)+$(deriveElmDef defaultOptions ''SomeOpts)+$(deriveElmDef defaultOptions{ allNullaryToStringTag = False } ''UnaryA)+$(deriveElmDef defaultOptions{ allNullaryToStringTag = True  } ''UnaryB)+$(deriveElmDef defaultOptions { fieldLabelModifier = drop 1 . map toLower } ''Baz)+$(deriveElmDef defaultOptions { fieldLabelModifier = drop 4 . map toLower, sumEncoding = TaggedObject "tag" "value" } ''Qux)+ fooSer :: String-fooSer = "jsonEncFoo  val = \n   Json.Encode.object\n   [ (\"name\", Json.Encode.string val.name)\n   , (\"blablub\", Json.Encode.int val.blablub)\n   ]\n"+fooSer = "jsonEncFoo : Foo -> Value\njsonEncFoo  val =\n   Json.Encode.object\n   [ (\"name\", Json.Encode.string val.name)\n   , (\"blablub\", Json.Encode.int val.blablub)\n   ]\n"  fooParse :: String-fooParse = "jsonDecFoo  = \n   (\"name\" := Json.Decode.string) `Json.Decode.andThen` \\pname -> \n   (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub -> \n   Json.Decode.succeed {name = pname, blablub = pblablub}\n"+fooParse = unlines+    [ "jsonDecFoo : Json.Decode.Decoder ( Foo )"+    , "jsonDecFoo ="+    , "   (\"name\" := Json.Decode.string) `Json.Decode.andThen` \\pname ->"+    , "   (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub ->"+    , "   Json.Decode.succeed {name = pname, blablub = pblablub}"+    ]  barSer :: String-barSer = "jsonEncBar localEncoder_a val = \n   Json.Encode.object\n   [ (\"name\", localEncoder_a val.name)\n   , (\"blablub\", Json.Encode.int val.blablub)\n   , (\"tuple\", (\\v1 v2 -> [(Json.Encode.int) v1,(Json.Encode.string) v2] val.tuple)\n   , (\"list\", (Json.Encode.list << map Json.Encode.bool) val.list)\n   ]\n"+barSer = unlines+    [ "jsonEncBar : (a -> Value) -> Bar a -> Value"+    , "jsonEncBar localEncoder_a val ="+    , "   Json.Encode.object"+    , "   [ (\"name\", localEncoder_a val.name)"+    , "   , (\"blablub\", Json.Encode.int val.blablub)"+    , "   , (\"tuple\", (\\(v1,v2) -> Json.Encode.list [(Json.Encode.int) v1,(Json.Encode.string) v2]) val.tuple)"+    , "   , (\"list\", (Json.Encode.list << List.map Json.Encode.bool) val.list)"+    , "   ]"+    ] +bazSer :: String+bazSer = unlines+    [ "jsonEncBaz : (a -> Value) -> Baz a -> Value"+    , "jsonEncBaz localEncoder_a val ="+    , "    let keyval v = case v of"+    , "                    Baz1 vs -> (\"Baz1\", encodeObject [(\"foo\", Json.Encode.int vs.foo), (\"qux\", (jsonEncMap (Json.Encode.int) (localEncoder_a)) vs.qux)])"+    , "                    Baz2 vs -> (\"Baz2\", encodeObject [(\"bar\", (maybeEncode (Json.Encode.int)) vs.bar), (\"str\", Json.Encode.string vs.str)])"+    , "                    Testing v1 -> (\"Testing\", encodeValue ((jsonEncBaz (localEncoder_a)) v1))"+    , "    in encodeSumObjectWithSingleField keyval val"+    ]+ barParse :: String-barParse = "jsonDecBar localDecoder_a = \n   (\"name\" := localDecoder_a) `Json.Decode.andThen` \\pname -> \n   (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub -> \n   (\"tuple\" := Json.Decode.tuple2 (,) (Json.Decode.int) (Json.Decode.string)) `Json.Decode.andThen` \\ptuple -> \n   (\"list\" := Json.Decode.list (Json.Decode.bool)) `Json.Decode.andThen` \\plist -> \n   Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist}\n"+barParse = unlines+    [ "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )"+    , "jsonDecBar localDecoder_a ="+    , "   (\"name\" := localDecoder_a) `Json.Decode.andThen` \\pname ->"+    , "   (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub ->"+    , "   (\"tuple\" := Json.Decode.tuple2 (,) (Json.Decode.int) (Json.Decode.string)) `Json.Decode.andThen` \\ptuple ->"+    , "   (\"list\" := Json.Decode.list (Json.Decode.bool)) `Json.Decode.andThen` \\plist ->"+    , "   Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist}"+    ] +bazParse :: String+bazParse = unlines+    [ "jsonDecBaz : Json.Decode.Decoder a -> Json.Decode.Decoder ( Baz a )"+    , "jsonDecBaz localDecoder_a ="+    , "    let jsonDecDictBaz = Dict.fromList"+    , "            [ (\"Baz1\", Json.Decode.map Baz1 (   (\"foo\" := Json.Decode.int) `Json.Decode.andThen` \\pfoo ->    (\"qux\" := jsonDecMap (Json.Decode.int) (localDecoder_a)) `Json.Decode.andThen` \\pqux ->    Json.Decode.succeed {foo = pfoo, qux = pqux}))"+    , "            , (\"Baz2\", Json.Decode.map Baz2 (   (Json.Decode.maybe (\"bar\" := Json.Decode.int)) `Json.Decode.andThen` \\pbar ->    (\"str\" := Json.Decode.string) `Json.Decode.andThen` \\pstr ->    Json.Decode.succeed {bar = pbar, str = pstr}))"+    , "            , (\"Testing\", Json.Decode.map Testing (jsonDecBaz (localDecoder_a)))"+    , "            ]"+    , "    in  decodeSumObjectWithSingleField  \"Baz\" jsonDecDictBaz"+    ]++quxParse :: String+quxParse = unlines+    [ "jsonDecQux localDecoder_a ="+    , "   "+    ]+ someOptsParse :: String-someOptsParse = "jsonDecSomeOpts localDecoder_a = \n   Json.Decode.oneOf \n   [ (\"Okay\" := Json.tuple1 Okay (Json.Decode.int))\n   , (\"NotOkay\" := Json.tuple1 NotOkay (localDecoder_a))\n   ]\n"+someOptsParse = unlines+    [ "jsonDecSomeOpts : Json.Decode.Decoder a -> Json.Decode.Decoder ( SomeOpts a )"+    , "jsonDecSomeOpts localDecoder_a ="+    , "    let jsonDecDictSomeOpts = Dict.fromList"+    , "            [ (\"Okay\", Json.Decode.map Okay (Json.Decode.int))"+    , "            , (\"NotOkay\", Json.Decode.map NotOkay (localDecoder_a))"+    , "            ]"+    , "    in  decodeSumObjectWithSingleField  \"SomeOpts\" jsonDecDictSomeOpts"+    ]  someOptsSer :: String-someOptsSer = "jsonEncSomeOpts localEncoder_a val = \n   case val of\n      Okay v1 -> [Json.Encode.int v1]\n      NotOkay v1 -> [localEncoder_a v1]\n"+someOptsSer = unlines+    [ "jsonEncSomeOpts : (a -> Value) -> SomeOpts a -> Value"+    , "jsonEncSomeOpts localEncoder_a val ="+    , "    let keyval v = case v of"+    , "                    Okay v1 -> (\"Okay\", encodeValue (Json.Encode.int v1))"+    , "                    NotOkay v1 -> (\"NotOkay\", encodeValue (localEncoder_a v1))"+    , "    in encodeSumObjectWithSingleField keyval val"+    ] +test1Parse :: String+test1Parse = unlines+    [ "jsonDecTestComp : Json.Decode.Decoder a -> Json.Decode.Decoder ( TestComp a )"+    , "jsonDecTestComp localDecoder_a ="+    , "   (\"t1\" := jsonDecChange (Json.Decode.int)) `Json.Decode.andThen` \\pt1 ->"+    , "   (\"t2\" := jsonDecChange (localDecoder_a)) `Json.Decode.andThen` \\pt2 ->"+    , "   Json.Decode.succeed {t1 = pt1, t2 = pt2}"+    ]++unaryAParse :: String+unaryAParse = unlines+    [ "jsonDecUnaryA : Json.Decode.Decoder ( UnaryA )"+    , "jsonDecUnaryA ="+    , "    let jsonDecDictUnaryA = Dict.fromList"+    , "            [ (\"UnaryA1\", Json.Decode.succeed UnaryA1)"+    , "            , (\"UnaryA2\", Json.Decode.succeed UnaryA2)"+    , "            ]"+    , "    in  decodeSumObjectWithSingleField  \"UnaryA\" jsonDecDictUnaryA"+    ]++unaryBParse :: String+unaryBParse = unlines+    [ "jsonDecUnaryB : Json.Decode.Decoder ( UnaryB )"+    , "jsonDecUnaryB = decodeSumUnaries \"UnaryB\" jsonDecDictUnaryB"+    , "jsonDecDictUnaryB = Dict.fromList [(\"UnaryB1\", UnaryB1), (\"UnaryB2\", UnaryB2)]"+    ]++unaryASer :: String+unaryASer = unlines+    [ "jsonEncUnaryA : UnaryA -> Value"+    , "jsonEncUnaryA  val ="+    , "    let keyval v = case v of"+    , "                    UnaryA1  -> (\"UnaryA1\", encodeValue (Json.Encode.list []))"+    , "                    UnaryA2  -> (\"UnaryA2\", encodeValue (Json.Encode.list []))"+    , "    in encodeSumObjectWithSingleField keyval val"+    ]++unaryBSer :: String+unaryBSer = unlines+    [ "jsonEncUnaryB : UnaryB -> Value"+    , "jsonEncUnaryB  val ="+    , "    case val of"+    , "        UnaryB1 -> Json.Encode.string \"UnaryB1\""+    , "        UnaryB2 -> Json.Encode.string \"UnaryB2\""+    ]+ spec :: Spec spec =     describe "json serialisation" $     do let rFoo = compileElmDef (Proxy :: Proxy Foo)            rBar = compileElmDef (Proxy :: Proxy (Bar a))+           rBaz = compileElmDef (Proxy :: Proxy (Baz a))+           rQux = compileElmDef (Proxy :: Proxy (Qux a))+           rTest1 = compileElmDef (Proxy :: Proxy (TestComp a))            rSomeOpts = compileElmDef (Proxy :: Proxy (SomeOpts a))-       it "should produce the correct ser code" $-          do jsonSerForDef rFoo `shouldBe` fooSer+           rUnaryA = compileElmDef (Proxy :: Proxy UnaryA)+           rUnaryB = compileElmDef (Proxy :: Proxy UnaryB)+       it "should produce the correct ser code" $ do+             jsonSerForDef rFoo `shouldBe` fooSer              jsonSerForDef rBar `shouldBe` barSer              jsonSerForDef rSomeOpts `shouldBe` someOptsSer-       it "should produce the correct parse code" $-          do jsonParserForDef rFoo `shouldBe` fooParse+             jsonSerForDef rBaz `shouldBe` bazSer+       it "should produce the correct ser code for unary unions" $ do+             jsonSerForDef rUnaryA `shouldBe` unaryASer+             jsonSerForDef rUnaryB `shouldBe` unaryBSer+       it "should produce the correct parse code for aliases" $ do+             jsonParserForDef rFoo `shouldBe` fooParse              jsonParserForDef rBar `shouldBe` barParse+       it "should produce the correct parse code generic sum types" $ do+             jsonParserForDef rBaz `shouldBe` bazParse              jsonParserForDef rSomeOpts `shouldBe` someOptsParse+             jsonParserForDef rTest1 `shouldBe` test1Parse+       it "should produce the correct parse code for unary unions" $ do+             jsonParserForDef rUnaryA `shouldBe` unaryAParse+             jsonParserForDef rUnaryB `shouldBe` unaryBParse

@@ -4,7 +4,6 @@ import Elm.Derive import Elm.Module -import Elm.TestHelpers  import Data.Proxy import Test.Hspec@@ -17,15 +16,87 @@    , b_list :: [Bool]    } deriving (Show, Eq) -$(deriveElmDef (fieldDropOpts 2) ''Bar)+data Qux a = Qux1 Int String+           | Qux2 { _qux2a :: Int, _qux2test :: a }+           deriving (Show, Eq) +$(deriveElmDef (defaultOptionsDropLower 2) ''Bar)+$(deriveElmDef (defaultOptionsDropLower 5) ''Qux)+ moduleCode :: String-moduleCode = "module Foo where \n\nimport Json.Decode\nimport Json.Decode exposing ((:=))\nimport Json.Encode\n\n\ntype alias Bar a = \n   { name: a\n   , blablub: Int\n   , tuple: (Int, String)\n   , list: (List Bool)\n   }\n\njsonDecBar localDecoder_a = \n   (\"name\" := localDecoder_a) `Json.Decode.andThen` \\pname -> \n   (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub -> \n   (\"tuple\" := Json.Decode.tuple2 (,) (Json.Decode.int) (Json.Decode.string)) `Json.Decode.andThen` \\ptuple -> \n   (\"list\" := Json.Decode.list (Json.Decode.bool)) `Json.Decode.andThen` \\plist -> \n   Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist}\n\njsonEncBar localEncoder_a val = \n   Json.Encode.object\n   [ (\"name\", localEncoder_a val.name)\n   , (\"blablub\", Json.Encode.int val.blablub)\n   , (\"tuple\", (\\v1 v2 -> [(Json.Encode.int) v1,(Json.Encode.string) v2] val.tuple)\n   , (\"list\", (Json.Encode.list << map Json.Encode.bool) val.list)\n   ]\n\n"+moduleCode = unlines+    [ "module Foo where"+    , ""+    , "import Json.Decode"+    , "import Json.Decode exposing ((:=))"+    , "import Json.Encode exposing (Value)"+    , "-- The following module comes from bartavelle/json-helpers"+    , "import Json.Helpers exposing (..)"+    , ""+    , ""+    , "type alias Bar a ="+    , "   { name: a"+    , "   , blablub: Int"+    , "   , tuple: (Int, String)"+    , "   , list: (List Bool)"+    , "   }"+    , ""+    , "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )"+    , "jsonDecBar localDecoder_a ="+    , "   (\"name\" := localDecoder_a) `Json.Decode.andThen` \\pname ->"+    , "   (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub ->"+    , "   (\"tuple\" := Json.Decode.tuple2 (,) (Json.Decode.int) (Json.Decode.string)) `Json.Decode.andThen` \\ptuple ->"+    , "   (\"list\" := Json.Decode.list (Json.Decode.bool)) `Json.Decode.andThen` \\plist ->"+    , "   Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist}"+    , ""+    , "jsonEncBar : (a -> Value) -> Bar a -> Value"+    , "jsonEncBar localEncoder_a val ="+    , "   Json.Encode.object"+    , "   [ (\"name\", localEncoder_a val.name)"+    , "   , (\"blablub\", Json.Encode.int val.blablub)"+    , "   , (\"tuple\", (\\(v1,v2) -> Json.Encode.list [(Json.Encode.int) v1,(Json.Encode.string) v2]) val.tuple)"+    , "   , (\"list\", (Json.Encode.list << List.map Json.Encode.bool) val.list)"+    , "   ]"+    , ""+    ] +moduleCode' :: String+moduleCode' = unlines+    [ "module Qux where"+    , ""+    , "import Json.Decode"+    , "import Json.Decode exposing ((:=))"+    , "import Json.Encode exposing (Value)"+    , "-- The following module comes from bartavelle/json-helpers"+    , "import Json.Helpers exposing (..)"+    , ""+    , ""+    , "type Qux a ="+    , "    Qux1 Int String"+    , "    | Qux2 {a: Int, test: a}"+    , ""+    , "jsonDecQux : Json.Decode.Decoder a -> Json.Decode.Decoder ( Qux a )"+    , "jsonDecQux localDecoder_a ="+    , "    let jsonDecDictQux = Dict.fromList"+    , "            [ (\"Qux1\", Json.Decode.tuple2 Qux1 (Json.Decode.int) (Json.Decode.string))"+    , "            , (\"Qux2\", Json.Decode.map Qux2 (   (\"a\" := Json.Decode.int) `Json.Decode.andThen` \\pa ->    (\"test\" := localDecoder_a) `Json.Decode.andThen` \\ptest ->    Json.Decode.succeed {a = pa, test = ptest}))"+    , "            ]"+    , "    in  decodeSumObjectWithSingleField  \"Qux\" jsonDecDictQux"+    , ""+    , "jsonEncQux : (a -> Value) -> Qux a -> Value"+    , "jsonEncQux localEncoder_a val ="+    , "    let keyval v = case v of"+    , "                    Qux1 v1 v2 -> (\"Qux1\", encodeValue (Json.Encode.list [Json.Encode.int v1, Json.Encode.string v2]))"+    , "                    Qux2 vs -> (\"Qux2\", encodeObject [(\"a\", Json.Encode.int vs.a), (\"test\", localEncoder_a vs.test)])"+    , "    in encodeSumObjectWithSingleField keyval val"+    , ""+    ]+ spec :: Spec spec =     describe "makeElmModule" $     it "should produce the correct code" $-       do let modu =-                 makeElmModule "Foo" [DefineElm (Proxy :: Proxy (Bar a))]+       do let modu = makeElmModule "Foo" [DefineElm (Proxy :: Proxy (Bar a))]+          let modu' = makeElmModule "Qux" [DefineElm (Proxy :: Proxy (Qux a))]           modu `shouldBe` moduleCode+          modu' `shouldBe` moduleCode'

@@ -1,9 +0,0 @@-module Elm.TestHelpers where--import Elm.Derive--fieldDropOpts :: Int -> DeriveOpts-fieldDropOpts i =-    defaultOpts-    { do_fieldModifier = drop i-    }

@@ -5,8 +5,6 @@ import Elm.TyRep import Elm.TyRender -import Elm.TestHelpers- import Data.Proxy import Test.Hspec @@ -28,18 +26,18 @@    = Okay Int    | NotOkay a -$(deriveElmDef (fieldDropOpts 2) ''Foo)-$(deriveElmDef (fieldDropOpts 2) ''Bar)-$(deriveElmDef defaultOpts ''SomeOpts)+$(deriveElmDef (defaultOptionsDropLower 2) ''Foo)+$(deriveElmDef (defaultOptionsDropLower 2) ''Bar)+$(deriveElmDef defaultOptions ''SomeOpts)  fooCode :: String-fooCode = "type alias Foo  = \n   { name: String\n   , blablub: Int\n   }\n"+fooCode = "type alias Foo  =\n   { name: String\n   , blablub: Int\n   }\n"  barCode :: String-barCode = "type alias Bar a = \n   { name: a\n   , blablub: Int\n   , tuple: (Int, String)\n   , list: (List Bool)\n   }\n"+barCode = "type alias Bar a =\n   { name: a\n   , blablub: Int\n   , tuple: (Int, String)\n   , list: (List Bool)\n   }\n"  someOptsCode :: String-someOptsCode = "type SomeOpts a = \n    Okay Int\n    | NotOkay a\n"+someOptsCode = "type SomeOpts a =\n    Okay Int\n    | NotOkay a\n"  spec :: Spec spec =

@@ -0,0 +1,271 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Elm.Derive+import Elm.Module+import Data.Proxy+import Data.Aeson hiding (defaultOptions)+import Data.Aeson.Types (SumEncoding(..))+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen (sample', oneof, Gen)+import qualified Data.Text as T+import Control.Applicative+import System.Environment+import Data.Char (toLower)+import Prelude++data Record1 a = Record1 { _r1foo :: Int, _r1bar :: Maybe Int, _r1baz :: a, _r1qux :: Maybe a } deriving Show+data Record2 a = Record2 { _r2foo :: Int, _r2bar :: Maybe Int, _r2baz :: a, _r2qux :: Maybe a } deriving Show++data Sum01 a = Sum01A a | Sum01B (Maybe a) | Sum01C a a | Sum01D { _s01foo :: a } | Sum01E { _s01bar :: Int, _s01baz :: Int } deriving Show+data Sum02 a = Sum02A a | Sum02B (Maybe a) | Sum02C a a | Sum02D { _s02foo :: a } | Sum02E { _s02bar :: Int, _s02baz :: Int } deriving Show+data Sum03 a = Sum03A a | Sum03B (Maybe a) | Sum03C a a | Sum03D { _s03foo :: a } | Sum03E { _s03bar :: Int, _s03baz :: Int } deriving Show+data Sum04 a = Sum04A a | Sum04B (Maybe a) | Sum04C a a | Sum04D { _s04foo :: a } | Sum04E { _s04bar :: Int, _s04baz :: Int } deriving Show+data Sum05 a = Sum05A a | Sum05B (Maybe a) | Sum05C a a | Sum05D { _s05foo :: a } | Sum05E { _s05bar :: Int, _s05baz :: Int } deriving Show+data Sum06 a = Sum06A a | Sum06B (Maybe a) | Sum06C a a | Sum06D { _s06foo :: a } | Sum06E { _s06bar :: Int, _s06baz :: Int } deriving Show+data Sum07 a = Sum07A a | Sum07B (Maybe a) | Sum07C a a | Sum07D { _s07foo :: a } | Sum07E { _s07bar :: Int, _s07baz :: Int } deriving Show+data Sum08 a = Sum08A a | Sum08B (Maybe a) | Sum08C a a | Sum08D { _s08foo :: a } | Sum08E { _s08bar :: Int, _s08baz :: Int } deriving Show+data Sum09 a = Sum09A a | Sum09B (Maybe a) | Sum09C a a | Sum09D { _s09foo :: a } | Sum09E { _s09bar :: Int, _s09baz :: Int } deriving Show+data Sum10 a = Sum10A a | Sum10B (Maybe a) | Sum10C a a | Sum10D { _s10foo :: a } | Sum10E { _s10bar :: Int, _s10baz :: Int } deriving Show+data Sum11 a = Sum11A a | Sum11B (Maybe a) | Sum11C a a | Sum11D { _s11foo :: a } | Sum11E { _s11bar :: Int, _s11baz :: Int } deriving Show+data Sum12 a = Sum12A a | Sum12B (Maybe a) | Sum12C a a | Sum12D { _s12foo :: a } | Sum12E { _s12bar :: Int, _s12baz :: Int } deriving Show++$(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = False } ''Record1)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = True  } ''Record2)++$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = False, sumEncoding = TaggedObject "tag" "content" } ''Sum01)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = False, sumEncoding = TaggedObject "tag" "content" } ''Sum02)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = True , sumEncoding = TaggedObject "tag" "content" } ''Sum03)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = True , sumEncoding = TaggedObject "tag" "content" } ''Sum04)++$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = False, sumEncoding = ObjectWithSingleField } ''Sum05)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = False, sumEncoding = ObjectWithSingleField } ''Sum06)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = True , sumEncoding = ObjectWithSingleField } ''Sum07)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = True , sumEncoding = ObjectWithSingleField } ''Sum08)++$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = False, sumEncoding = TwoElemArray } ''Sum09)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = False, sumEncoding = TwoElemArray } ''Sum10)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = False, allNullaryToStringTag = True , sumEncoding = TwoElemArray } ''Sum11)+$(deriveBoth defaultOptions{ fieldLabelModifier = drop 4, omitNothingFields = True , allNullaryToStringTag = True , sumEncoding = TwoElemArray } ''Sum12)++instance Arbitrary a => Arbitrary (Record1 a) where+    arbitrary = Record1 <$> arbitrary <*> fmap Just arbitrary <*> arbitrary <*> fmap Just arbitrary+instance Arbitrary a => Arbitrary (Record2 a) where+    arbitrary = Record2 <$> arbitrary <*> fmap Just arbitrary <*> arbitrary <*> fmap Just arbitrary++arb :: Arbitrary a => (a -> b) -> (Maybe a -> b) -> (a -> a -> b) -> (a -> b) -> (Int -> Int -> b) -> Gen b+arb c1 c2 c3 c4 c5 = oneof+    [ c1 <$> arbitrary+    , c2 . Just <$> arbitrary+    , c3 <$> arbitrary <*> arbitrary+    , c4 <$> arbitrary+    , c5 <$> arbitrary <*> arbitrary+    ]++instance Arbitrary a => Arbitrary (Sum01 a) where arbitrary = arb Sum01A Sum01B Sum01C Sum01D Sum01E+instance Arbitrary a => Arbitrary (Sum02 a) where arbitrary = arb Sum02A Sum02B Sum02C Sum02D Sum02E+instance Arbitrary a => Arbitrary (Sum03 a) where arbitrary = arb Sum03A Sum03B Sum03C Sum03D Sum03E+instance Arbitrary a => Arbitrary (Sum04 a) where arbitrary = arb Sum04A Sum04B Sum04C Sum04D Sum04E+instance Arbitrary a => Arbitrary (Sum05 a) where arbitrary = arb Sum05A Sum05B Sum05C Sum05D Sum05E+instance Arbitrary a => Arbitrary (Sum06 a) where arbitrary = arb Sum06A Sum06B Sum06C Sum06D Sum06E+instance Arbitrary a => Arbitrary (Sum07 a) where arbitrary = arb Sum07A Sum07B Sum07C Sum07D Sum07E+instance Arbitrary a => Arbitrary (Sum08 a) where arbitrary = arb Sum08A Sum08B Sum08C Sum08D Sum08E+instance Arbitrary a => Arbitrary (Sum09 a) where arbitrary = arb Sum09A Sum09B Sum09C Sum09D Sum09E+instance Arbitrary a => Arbitrary (Sum10 a) where arbitrary = arb Sum10A Sum10B Sum10C Sum10D Sum10E+instance Arbitrary a => Arbitrary (Sum11 a) where arbitrary = arb Sum11A Sum11B Sum11C Sum11D Sum11E+instance Arbitrary a => Arbitrary (Sum12 a) where arbitrary = arb Sum12A Sum12B Sum12C Sum12D Sum12E++elmModuleContent :: String+elmModuleContent = unlines+    [ "-- This module requires the following packages:"+    , "-- * deadfoxygrandpa/elm-test"+    , "-- * bartavelle/json-helpers"+    , "module MyTests where"+    , ""+    , "import Dict exposing (Dict)"+    , "import Set exposing (Set)"+    , "import Json.Decode exposing ((:=), Value)"+    , "import Json.Encode"+    , "import Json.Helpers exposing (..)"+    , "import ElmTest exposing (..)"+    , "import Graphics.Element exposing (Element)"+    , "import String"+    , ""+    , "main : Element"+    , "main = elementRunner <| suite \"Testing\" [ sumEncode, sumDecode, recordDecode, recordEncode ]"+    , ""+    , "recordDecode : Test"+    , "recordDecode = suite \"Record decoding checks\""+    , "              [ recordDecode1"+    , "              , recordDecode2"+    , "              ]"+    , ""+    , "recordEncode : Test"+    , "recordEncode = suite \"Record encoding checks\""+    , "              [ recordEncode1"+    , "              , recordEncode2"+    , "              ]"+    , ""+    , "sumDecode : Test"+    , "sumDecode = suite \"Sum decoding checks\""+    , "              [ sumDecode01"+    , "              , sumDecode02"+    , "              , sumDecode03"+    , "              , sumDecode04"+    , "              , sumDecode05"+    , "              , sumDecode06"+    , "              , sumDecode07"+    , "              , sumDecode08"+    , "              , sumDecode09"+    , "              , sumDecode10"+    , "              , sumDecode11"+    , "              , sumDecode12"+    , "              ]"+    , ""+    , "sumEncode : Test"+    , "sumEncode = suite \"Sum encoding checks\""+    , "              [ sumEncode01"+    , "              , sumEncode02"+    , "              , sumEncode03"+    , "              , sumEncode04"+    , "              , sumEncode05"+    , "              , sumEncode06"+    , "              , sumEncode07"+    , "              , sumEncode08"+    , "              , sumEncode09"+    , "              , sumEncode10"+    , "              , sumEncode11"+    , "              , sumEncode12"+    , "              ]"+    , ""+    , "-- this is done to prevent artificial differences due to object ordering, this won't work with Maybe's though :("+    , "assertEqualHack : String -> String -> Assertion"+    , "assertEqualHack a b ="+    , "    let remix = Json.Decode.decodeString Json.Decode.value"+    , "    in assertEqual (remix a) (remix b)"+    , ""+    , makeModuleContentWithAlterations (newtypeAliases ["Record1", "Record2"] . defaultAlterations)+        [ DefineElm (Proxy :: Proxy (Record1 a))+        , DefineElm (Proxy :: Proxy (Record2 a))+        , DefineElm (Proxy :: Proxy (Sum01 a))+        , DefineElm (Proxy :: Proxy (Sum02 a))+        , DefineElm (Proxy :: Proxy (Sum03 a))+        , DefineElm (Proxy :: Proxy (Sum04 a))+        , DefineElm (Proxy :: Proxy (Sum05 a))+        , DefineElm (Proxy :: Proxy (Sum06 a))+        , DefineElm (Proxy :: Proxy (Sum07 a))+        , DefineElm (Proxy :: Proxy (Sum08 a))+        , DefineElm (Proxy :: Proxy (Sum09 a))+        , DefineElm (Proxy :: Proxy (Sum10 a))+        , DefineElm (Proxy :: Proxy (Sum11 a))+        , DefineElm (Proxy :: Proxy (Sum12 a))+        ]+    ]++mkDecodeTest :: (Show a, ToJSON a) => String -> String -> String -> [a] -> String+mkDecodeTest pred prefix num elems = unlines (+    [ map toLower pred ++ "Decode" ++ num ++ " : Test"+    , map toLower pred ++ "Decode" ++ num ++ " = suite \"" ++ pred ++ " decode " ++ num ++ "\""+    ]+    ++ map mktest (zip ([1..] :: [Int]) elems)+    ++ ["  ]"]+    )+  where+      mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (assertEqual (Json.Decode.decodeString (jsonDec" ++ pred ++ num ++ " Json.Decode.int) " ++ encoded ++ ") (Ok (" ++ pretty ++ ")))"+        where+            pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show e+            encoded = show (encode e)+            pfix = if n == 1 then "  [ " else "  , "++mkSumDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkSumDecodeTest = mkDecodeTest "Sum" "_s"++mkRecordDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkRecordDecodeTest = mkDecodeTest "Record" "_r"++mkEncodeTest :: (Show a, ToJSON a) => String -> String -> String -> [a] -> String+mkEncodeTest pred prefix num elems = unlines (+    [ map toLower pred ++ "Encode" ++ num ++ " : Test"+    , map toLower pred ++ "Encode" ++ num ++ " = suite \"" ++ pred ++ " encode " ++ num ++ "\""+    ]+    ++ map mktest (zip ([1..] :: [Int]) elems)+    ++ ["  ]"]+    )+  where+      mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (assertEqualHack (Json.Encode.encode 0 (jsonEnc" ++ pred ++ num ++ " Json.Encode.int (" ++ pretty ++ "))) " ++ encoded ++ ")"+        where+            pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show e+            encoded = show (encode e)+            pfix = if n == 1 then "  [ " else "  , "++mkSumEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkSumEncodeTest = mkEncodeTest "Sum" "_s"++mkRecordEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String+mkRecordEncodeTest = mkEncodeTest "Record" "_r"+{-+mkSumEncodeTest num elems = unlines (+    [ "sumEncode" ++ num ++ " : Test"+    , "sumEncode" ++ num ++ " = suite \"sum encode " ++ num ++ "\""+    ]+    ++ map mktest (zip ([1..] :: [Int]) elems)+    ++ ["  ]"]+    )+  where+      mktest (n,e) = prefix ++ "test \"" ++ show n ++ "\" (assertEqualHack (Json.Encode.encode 0 (jsonEncSum" ++ num ++ " Json.Encode.int (" ++ pretty ++ "))) " ++ encoded ++ ")"+        where+            pretty = T.unpack $ T.replace (T.pack ("_s" ++ num)) T.empty $ T.pack $ show e+            encoded = show (encode e)+            prefix = if n == 1 then "  [ " else "  , "+-}+main :: IO ()+main = do+    ss01 <- sample' arbitrary :: IO [Sum01 Int]+    ss02 <- sample' arbitrary :: IO [Sum02 Int]+    ss03 <- sample' arbitrary :: IO [Sum03 Int]+    ss04 <- sample' arbitrary :: IO [Sum04 Int]+    ss05 <- sample' arbitrary :: IO [Sum05 Int]+    ss06 <- sample' arbitrary :: IO [Sum06 Int]+    ss07 <- sample' arbitrary :: IO [Sum07 Int]+    ss08 <- sample' arbitrary :: IO [Sum08 Int]+    ss09 <- sample' arbitrary :: IO [Sum09 Int]+    ss10 <- sample' arbitrary :: IO [Sum10 Int]+    ss11 <- sample' arbitrary :: IO [Sum11 Int]+    ss12 <- sample' arbitrary :: IO [Sum12 Int]+    re01 <- sample' arbitrary :: IO [Record1 Int]+    re02 <- sample' arbitrary :: IO [Record2 Int]+    args <- getArgs+    case args of+        [] -> return ()+        (x:_) -> writeFile x $+               unlines [ elmModuleContent+                       , mkSumEncodeTest "01" ss01+                       , mkSumEncodeTest "02" ss02+                       , mkSumEncodeTest "03" ss03+                       , mkSumEncodeTest "04" ss04+                       , mkSumEncodeTest "05" ss05+                       , mkSumEncodeTest "06" ss06+                       , mkSumEncodeTest "07" ss07+                       , mkSumEncodeTest "08" ss08+                       , mkSumEncodeTest "09" ss09+                       , mkSumEncodeTest "10" ss10+                       , mkSumEncodeTest "11" ss11+                       , mkSumEncodeTest "12" ss12+                       , mkSumDecodeTest "01" ss01+                       , mkSumDecodeTest "02" ss02+                       , mkSumDecodeTest "03" ss03+                       , mkSumDecodeTest "04" ss04+                       , mkSumDecodeTest "05" ss05+                       , mkSumDecodeTest "06" ss06+                       , mkSumDecodeTest "07" ss07+                       , mkSumDecodeTest "08" ss08+                       , mkSumDecodeTest "09" ss09+                       , mkSumDecodeTest "10" ss10+                       , mkSumDecodeTest "11" ss11+                       , mkSumDecodeTest "12" ss12+                       , mkRecordDecodeTest "1" re01+                       , mkRecordDecodeTest "2" re02+                       , mkRecordEncodeTest "1" re01+                       , mkRecordEncodeTest "2" re02+                       ]+