diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# v0.5.0 + + * Large change for sum types that used `constructorTagModifier`. The generated types are now unaffected! This is a breaking change for those who used this feature. + # v0.4.2 Drop support for `aeson < 1.` diff --git a/elm-bridge.cabal b/elm-bridge.cabal --- a/elm-bridge.cabal +++ b/elm-bridge.cabal @@ -1,5 +1,5 @@ name: elm-bridge -version: 0.4.3 +version: 0.5.0 synopsis: Derive Elm types and Json code from Haskell types, using aeson's options description: Building the bridge from Haskell to Elm and back. Define types once, and derive the aeson and elm functions at the same time, using any aeson diff --git a/src/Elm/Derive.hs b/src/Elm/Derive.hs --- a/src/Elm/Derive.hs +++ b/src/Elm/Derive.hs @@ -151,17 +151,17 @@ sumOpts = listE $ map mkOpt constrs mkOpt :: Con -> Q Exp mkOpt c = - let modifyName = A.constructorTagModifier opts . nameBase + let modifyName n = (nameBase n, A.constructorTagModifier opts (nameBase n)) in case c of NormalC name' args -> - let n = modifyName name' + let (b, n) = modifyName name' tyArgs = listE $ map (\(_, ty) -> compileType ty) args - in [|(n, Right $tyArgs)|] + in [|STC b n (Anonymous $tyArgs)|] RecC name' args -> - let n = modifyName name' + let (b, n) = modifyName name' tyArgs = listE $ map (\(nm, _, ty) -> let nm' = A.fieldLabelModifier opts $ nameBase nm in [|(nm', $(compileType ty))|]) args - in [|(n, Left $tyArgs)|] + in [|STC b n (Named $tyArgs)|] _ -> fail ("Can't derive this sum: " ++ show c) deriveSynonym :: A.Options -> Name -> [TyVarBndr] -> Type -> Q [Dec] @@ -197,4 +197,10 @@ else deriveAlias True opts name [] conFields TySynD _ vars otherTy -> deriveSynonym opts name vars otherTy + NewtypeD _ _ tyvars Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] -> + deriveSynonym opts name tyvars otherTy + NewtypeD _ _ tyvars Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] -> + if A.unwrapUnaryRecords opts + then deriveSynonym opts name tyvars otherTy + else deriveAlias True opts name tyvars conFields _ -> fail ("Oops, can only derive data and newtype, not this: " ++ show tyCon) diff --git a/src/Elm/Json.hs b/src/Elm/Json.hs --- a/src/Elm/Json.hs +++ b/src/Elm/Json.hs @@ -9,11 +9,12 @@ module Elm.Json ( jsonParserForDef , jsonSerForDef + , jsonParserForType + , jsonSerForType ) where import Data.List -import Data.Either (isLeft) import Data.Aeson.Types (SumEncoding(..)) import Elm.TyRep @@ -22,6 +23,7 @@ data MaybeHandling = Root | Leaf deriving Eq +-- | Compile a JSON parser for an Elm type jsonParserForType :: EType -> String jsonParserForType = jsonParserForType' Leaf @@ -29,7 +31,6 @@ 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 @@ -57,32 +58,33 @@ _ -> error $ "Do suitable json parser found for " ++ show ty xs -> let tupleLen = length xs - commas = replicate (tupleLen - 1) ',' - in "Json.Decode.map" ++ show tupleLen ++ " (" ++ commas ++ ") " + in "Json.Decode.map" ++ show tupleLen ++ " tuple" ++ show tupleLen ++ " " ++ unwords (zipWith (\i t' -> "(Json.Decode.index " ++ show (i :: Int) ++ " (" ++ jsonParserForType t' ++ "))") [0..] xs) parseRecords :: Maybe ETypeName -> Bool -> [(String, EType)] -> [String] -parseRecords newtyped unwrap fields = map (mkField doUnwrap) fields ++ [" Json.Decode.succeed " ++ mkNewtype ("{" ++ intercalate ", " (map (\(fldName, _) -> fixReserved fldName ++ " = p" ++ fldName) fields) ++ "}")] +parseRecords newtyped unwrap fields = + case fields of + [(_, ftype)] | unwrap -> [ succeed ++ " |> custom (" ++ jsonParserForType' (o ftype) ftype ++ ")" ] + _ -> succeed : map mkField fields where - doUnwrap = length fields == 1 && unwrap + succeed = " Json.Decode.succeed (\\" ++ unwords (map ( ('p':) . fst ) fields) ++ " -> " ++ mkNewtype ("{" ++ intercalate ", " (map (\(fldName, _) -> fixReserved fldName ++ " = p" ++ fldName) fields) ++ "}") ++ ")" mkNewtype x = case newtyped of Nothing -> x Just nm -> "(" ++ et_name nm ++ " " ++ x ++ ")" - mkField u (fldName, fldType) = - let (fldStart, fldEnd, mh) = if isOption fldType - then ("(Json.Decode.maybe ", ")", Root) - else ("", "", Leaf) - in " " ++ fldStart ++ "(" ++ (if u then "" else "\"" ++ fldName ++ "\" := ") - ++ jsonParserForType' mh fldType - ++ fldEnd - ++ ") >>= \\p" ++ fldName ++ " ->" + o fldType = if isOption fldType + then Root + else Leaf + mkField (fldName, fldType) = + " |> " ++ (if isOption fldType then "fnullable " else "required ") + ++ show fldName + ++ " (" ++ jsonParserForType' (o fldType) fldType ++ ")" -- | Checks that all the arguments to the ESum are unary values -allUnaries :: Bool -> [(String, Either [(String, EType)] [EType])] -> Maybe [String] +allUnaries :: Bool -> [SumTypeConstructor] -> Maybe [(String, String)] allUnaries False = const Nothing allUnaries True = mapM isUnary where - isUnary (x, Right args) = if null args then Just x else Nothing + isUnary (STC o c (Anonymous args)) = if null args then Just (o,c) else Nothing isUnary _ = Nothing -- | Compile a JSON parser for an Elm type definition @@ -118,24 +120,24 @@ isObjectSetName = "jsonDecObjectSet" ++ typename deriveUnaries strs = unlines [ "" - , " let " ++ dictName ++ " = Dict.fromList [" ++ intercalate ", " (map (\s -> "(" ++ show s ++ ", " ++ cap s ++ ")") strs ) ++ "]" + , " let " ++ dictName ++ " = Dict.fromList [" ++ intercalate ", " (map (\(o, s) -> "(" ++ show s ++ ", " ++ o ++ ")") strs ) ++ "]" , " in decodeSumUnaries " ++ show typename ++ " " ++ dictName ] - encodingDictionary [(oname, args)] = " " ++ mkDecoder oname args + encodingDictionary [STC cname _ args] = " " ++ mkDecoder cname args encodingDictionary os = tab 4 "let " ++ dictName ++ " = Dict.fromList\n" ++ tab 12 "[ " ++ intercalate ("\n" ++ replicate 12 ' ' ++ ", ") (map dictEntry os) ++ "\n" ++ tab 12 "]" isObjectSet = case encodingType of TaggedObject _ _ - | length opts > 1 -> "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " (map (show . fst) $ filter (isLeft . snd) opts) ++ "]") + | length opts > 1 -> "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " (map (show . _stcName) $ filter (isNamed . _stcFields) opts) ++ "]") _ -> "" - dictEntry (oname, args) = "(" ++ show oname ++ ", " ++ mkDecoder oname args ++ ")" - mkDecoder oname (Left args) = lazy $ "Json.Decode.map " - ++ cap oname + dictEntry (STC cname oname args) = "(" ++ show oname ++ ", " ++ mkDecoder cname args ++ ")" + mkDecoder cname (Named args) = lazy $ "Json.Decode.map " + ++ cname ++ " (" ++ unwords (parseRecords Nothing False args) ++ ")" - mkDecoder oname (Right args) = lazy $ unwords ( decodeFunction - : cap oname + mkDecoder cname (Anonymous args) = lazy $ unwords ( decodeFunction + : cname : zipWith (\t' i -> "(" ++ jsonParserForIndexedType t' i ++ ")") args [0..] ) where decodeFunction = case length args of @@ -169,7 +171,7 @@ 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 << List.map " ++ jsonSerForType t' ++ ")" + ETyApp (ETyCon (ETCon "List")) t' -> "(Json.Encode.list " ++ jsonSerForType t' ++ ")" ETyApp (ETyCon (ETCon "Maybe")) t' -> if omitnull then jsonSerForType t' else "(maybeEncode (" ++ jsonSerForType t' ++ "))" @@ -189,11 +191,10 @@ let tupleArgsV = zip xs ([1..] :: [Int]) tupleArgs = intercalate "," $ map (\(_, v) -> "v" ++ show v) tupleArgsV - in "(\\(" ++ tupleArgs ++ ") -> Json.Encode.list [" ++ intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType t' ++ ") v" ++ show idx) tupleArgsV) ++ "])" + in "(\\(" ++ tupleArgs ++ ") -> Json.Encode.list identity [" ++ 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 @@ -215,7 +216,7 @@ TwoElemArray -> "encodeSumTwoElementArray" TaggedObject k c -> unwords ["encodeSumTaggedObject", show k, show c] UntaggedValue -> "encodeSumUntagged" - defaultEncoding [(oname, Right args)] = unlines $ + defaultEncoding [STC _ oname (Anonymous args)] = unlines [ makeType name , fname name ++ " " ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name) @@ -225,23 +226,23 @@ defaultEncoding os = unlines ( ( makeName name False ++ " =") : " let keyval v = case v of" - : (map (replicate 12 ' ' ++) (map mkcase os)) + : map ((replicate 12 ' ' ++) . mkcase) os ++ [ " " ++ 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 + ] ++ map (\(o, n) -> replicate 8 ' ' ++ o ++ " -> 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 ++ ", encodeValue (" ++ mkEncodeList args ++ "))" - mkcase (oname, Left args) = replicate 8 ' ' ++ cap oname ++ " vs -> (" ++ show oname ++ ", " ++ mkEncodeObject args ++ ")" + mkcase :: SumTypeConstructor -> String + mkcase (STC cname oname (Anonymous args)) = replicate 8 ' ' ++ cap cname ++ " " ++ argList args ++ " -> (" ++ show oname ++ ", encodeValue (" ++ mkEncodeList args ++ "))" + mkcase (STC cname oname (Named args)) = replicate 8 ' ' ++ cap cname ++ " 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] = jsonSerForType arg ++ " v1" - mkEncodeList args = "Json.Encode.list [" ++ numargs jsonSerForType args ++ "]" + mkEncodeList args = "Json.Encode.list identity [" ++ numargs jsonSerForType args ++ "]" where 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"]) diff --git a/src/Elm/Module.hs b/src/Elm/Module.hs --- a/src/Elm/Module.hs +++ b/src/Elm/Module.hs @@ -8,7 +8,7 @@ import Data.Proxy import Data.List -import Control.Arrow (second, (+++)) +import Control.Arrow (second) import Elm.TyRep import Elm.TyRender @@ -39,8 +39,8 @@ , "import Json.Encode exposing (Value)" , "-- The following module comes from bartavelle/json-helpers" , "import Json.Helpers exposing (..)" - , "import Dict" - , "import Set" + , "import Dict exposing (Dict)" + , "import Set exposing (Set)" , "" , "" ]) ++ makeModuleContent defs @@ -79,10 +79,14 @@ 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) }) + ETypeSum s -> ETypeSum (s { es_constructors = map alterTypes (es_constructors s) }) where - f' (ETyApp a b) = f (ETyApp (f' a) (f' b)) - f' x = f x + alterTypes :: SumTypeConstructor -> SumTypeConstructor + alterTypes (STC cn dn s) = STC cn dn $ case s of + Anonymous flds -> Anonymous (map f' flds) + Named flds -> Named (map (second f') flds) + 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. @@ -101,20 +105,27 @@ * @Text@ -> @String@ * @Vector@ -> @List@ * @Double@ -> @Float@ + * @Tagged t v@ -> @v@ -} 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 "Natural") -> ETyCon (ETCon "Int") - ETyCon (ETCon "Text") -> ETyCon (ETCon "String") - ETyCon (ETCon "Vector") -> ETyCon (ETCon "List") - ETyCon (ETCon "Double") -> ETyCon (ETCon "Float") - _ -> t +defaultAlterations = recAlterType defaultTypeAlterations + +defaultTypeAlterations :: EType -> EType +defaultTypeAlterations t = case t of + ETyApp (ETyCon (ETCon "HashSet")) s -> checkSet $ defaultTypeAlterations s + ETyApp (ETyCon (ETCon "Set")) s -> checkSet $ defaultTypeAlterations s + ETyApp (ETyApp (ETyCon (ETCon "HashMap")) k) v -> checkMap (defaultTypeAlterations k) (defaultTypeAlterations v) + ETyApp (ETyApp (ETyCon (ETCon "THashMap")) k) v -> checkMap (defaultTypeAlterations k) (defaultTypeAlterations v) + ETyApp (ETyApp (ETyCon (ETCon "Map")) k) v -> checkMap (defaultTypeAlterations k) (defaultTypeAlterations v) + ETyApp (ETyApp (ETyCon (ETCon "Tagged")) _) v -> defaultTypeAlterations v + ETyApp x y -> ETyApp (defaultTypeAlterations x) (defaultTypeAlterations y) + ETyCon (ETCon "Integer") -> ETyCon (ETCon "Int") + ETyCon (ETCon "Natural") -> ETyCon (ETCon "Int") + ETyCon (ETCon "Text") -> ETyCon (ETCon "String") + ETyCon (ETCon "Vector") -> ETyCon (ETCon "List") + ETyCon (ETCon "Double") -> ETyCon (ETCon "Float") + ETyCon (ETCon "UTCTime") -> ETyCon (ETCon "Posix") + _ -> t where isString (ETyCon (ETCon "String")) = True isString _ = False diff --git a/src/Elm/TyRender.hs b/src/Elm/TyRender.hs --- a/src/Elm/TyRender.hs +++ b/src/Elm/TyRender.hs @@ -53,11 +53,11 @@ instance ElmRenderable ESum where renderElm s = "type " ++ renderElm (es_name s) ++ " =\n " - ++ intercalate "\n | " (map mkOpt (es_options s)) + ++ intercalate "\n | " (map mkOpt (es_constructors s)) ++ "\n" where - mkOpt (name, Left types) = cap name ++ " {" ++ intercalate ", " (map (\(fld, ty) -> fixReserved fld ++ ": " ++ renderElm ty) types) ++ "}" - mkOpt (name, Right types) = + mkOpt (STC name _ (Named types)) = cap name ++ " {" ++ intercalate ", " (map (\(fld, ty) -> fixReserved fld ++ ": " ++ renderElm ty) types) ++ "}" + mkOpt (STC name _ (Anonymous types)) = cap name ++ " " ++ unwords (map renderElm types) instance ElmRenderable EPrimAlias where diff --git a/src/Elm/TyRep.hs b/src/Elm/TyRep.hs --- a/src/Elm/TyRep.hs +++ b/src/Elm/TyRep.hs @@ -5,6 +5,7 @@ import Data.List import Data.Proxy +import Data.Typeable (Typeable, TyCon, TypeRep, splitTyConApp, tyConName, typeRep, typeRepTyCon) import Data.Aeson.Types (SumEncoding(..)) import Data.Monoid ((<>)) @@ -70,14 +71,32 @@ , ea_unwrap_unary :: Bool } deriving (Show, Eq, Ord) +data SumTypeFields + = Anonymous [EType] + | Named [(String, EType)] + deriving (Show, Eq, Ord) + +isNamed :: SumTypeFields -> Bool +isNamed s = + case s of + Named _ -> True + _ -> False + +data SumTypeConstructor + = STC + { _stcName :: String + , _stcEncoded :: String + , _stcFields :: SumTypeFields + } deriving (Show, Eq, Ord) + data ESum - = ESum - { 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) + = ESum + { es_name :: ETypeName + , es_constructors :: [SumTypeConstructor] + , 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. @@ -86,6 +105,7 @@ where extract :: EType -> Maybe [EType] extract ty = case ty of + ETyTuple 0 -> return [] ETyApp (ETyTuple _) t -> return [t] ETyApp app@(ETyApp _ _) t -> fmap (++ [t]) (extract app) _ -> Nothing @@ -140,3 +160,41 @@ defSumEncoding :: SumEncoding' defSumEncoding = SumEncoding' ObjectWithSingleField +-- | Get an @elm-bridge@ type representation for a Haskell type. +-- This can be used to render the type declaration via +-- 'Elm.TyRender.ElmRenderable' or the the JSON serializer/parser names via +-- 'Elm.Json.jsonSerForType' and 'Elm.Json.jsonParserForType'. +toElmType :: (Typeable a) => Proxy a -> EType +toElmType ty = toElmType' $ typeRep ty + where + toElmType' :: TypeRep -> EType + toElmType' rep + -- String (A list of Char) + | con == (typeRepTyCon $ typeRep (Proxy :: Proxy [])) && + args == [typeRep (Proxy :: Proxy Char)] = ETyCon (ETCon "String") + -- List is special because the constructor name is [] in Haskell and List in elm + | con == (typeRepTyCon $ typeRep (Proxy :: Proxy [])) = ETyApp (ETyCon $ ETCon $ "List") (toElmType' (head args)) + -- The unit type '()' is a 0-ary tuple. + | isTuple $ tyConName con = ETyTuple $ length args + | otherwise = typeApplication con args + where + (con, args) = splitTyConApp rep + + isTuple :: String -> Bool + isTuple ('(':xs) = isTuple' $ reverse xs + where + isTuple' :: String -> Bool + isTuple' (')':xs') = all (== ',') xs' + isTuple' _ = False + isTuple _ = False + + typeApplication :: TyCon -> [TypeRep] -> EType + typeApplication con args = typeApplication' (reverse args) + where + typeApplication' [] = ETyCon (ETCon $ tyConName con) + typeApplication' [x] = + ETyApp + (ETyCon $ ETCon $ tyConName con) + (toElmType' x) + typeApplication' (x:xs) = + ETyApp (typeApplication' xs) (toElmType' x) diff --git a/test/Elm/DeriveSpec.hs b/test/Elm/DeriveSpec.hs --- a/test/Elm/DeriveSpec.hs +++ b/test/Elm/DeriveSpec.hs @@ -39,12 +39,17 @@ = Okay Int | NotOkay a +data Simple + = SimpleA + | SimpleB + 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 +deriveElmDef defaultOptions { constructorTagModifier = drop 6 . map toLower} ''Simple testElm :: ETypeDef testElm = ETypeAlias $ EAlias @@ -101,10 +106,10 @@ 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_constructors = + [ STC "Baz1" "Baz1" (Named [("foo",ETyCon (ETCon {tc_name = "Int"})), ("qux",ETyVar (ETVar {tv_name = "a"}))]) + , STC "Baz2" "Baz2" (Named [("bar",ETyCon (ETCon {tc_name = "Int"})), ("str",ETyCon (ETCon {tc_name = "String"}))]) + , STC "Zob" "Zob" (Anonymous [ETyVar (ETVar {tv_name = "a"})]) ] , es_type = SumEncoding' ObjectWithSingleField , es_omit_null = False @@ -114,9 +119,9 @@ 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_constructors = + [ STC "Qux1" "Qux1" (Named [("foo",ETyCon (ETCon {tc_name = "Int"})), ("qux",ETyVar (ETVar {tv_name = "a"}))]) + , STC "Qux2" "Qux2" (Named [("bar",ETyCon (ETCon {tc_name = "Int"})), ("str",ETyCon (ETCon {tc_name = "String"}))]) ] , es_type = SumEncoding' $ TaggedObject "key" "value" , es_omit_null = False @@ -132,15 +137,24 @@ { et_name = "SomeOpts" , et_args = [ETVar {tv_name = "a"}] } - , es_options = - [ ("Okay", Right [ETyCon (ETCon {tc_name = "Int"})]) - , ("NotOkay", Right [ETyVar (ETVar {tv_name = "a"})]) + , es_constructors = + [ STC "Okay" "Okay" (Anonymous [ETyCon (ETCon {tc_name = "Int"})]) + , STC "NotOkay" "NotOkay" (Anonymous [ETyVar (ETVar {tv_name = "a"})]) ] , es_type = defSumEncoding , es_omit_null = False , es_unary_strings = True } +simpleElm :: ETypeDef +simpleElm = ETypeSum $ + ESum + { es_name = ETypeName {et_name = "Simple", et_args = []}, es_constructors = [STC "SimpleA" "a" (Anonymous []),STC "SimpleB" "b" (Anonymous [])] + , es_type = SumEncoding' ObjectWithSingleField + , es_omit_null = False + , es_unary_strings = True + } + spec :: Spec spec = describe "deriveElmRep" $ @@ -151,3 +165,4 @@ compileElmDef (Proxy :: Proxy (Baz a)) `shouldBe` bazElm compileElmDef (Proxy :: Proxy (Qux a)) `shouldBe` quxElm compileElmDef (Proxy :: Proxy (Test a)) `shouldBe` testElm + compileElmDef (Proxy :: Proxy Simple) `shouldBe` simpleElm diff --git a/test/Elm/JsonSpec.hs b/test/Elm/JsonSpec.hs --- a/test/Elm/JsonSpec.hs +++ b/test/Elm/JsonSpec.hs @@ -2,13 +2,14 @@ module Elm.JsonSpec (spec) where import Elm.Derive +import Elm.TyRender import Elm.TyRep import Elm.Json import Data.Proxy import Test.Hspec import Data.Char (toLower) -import Data.Aeson.Types (SumEncoding(..),defaultTaggedObject) +import Data.Aeson.Types (defaultTaggedObject) import qualified Data.Map.Strict as M import qualified Data.Aeson.TH as TH @@ -53,6 +54,11 @@ newtype NTC = NTC Int newtype NTD = NTD { getNtd :: Int } +newtype PhantomA a = PhantomA Int +newtype PhantomB a = PhantomB { getPhantomB :: Int } +newtype PhantomC a = PhantomC Int +newtype PhantomD a = PhantomD { getPhantomD :: Int } + $(deriveElmDef (defaultOptionsDropLower 2) ''Foo) $(deriveElmDef (defaultOptionsDropLower 2) ''Bar) $(deriveElmDef (defaultOptionsDropLower 1) ''TestComp) @@ -67,6 +73,10 @@ $(deriveElmDef defaultOptions ''NTB) $(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''NTC) $(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''NTD) +$(deriveElmDef defaultOptions ''PhantomA) +$(deriveElmDef defaultOptions ''PhantomB) +$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomC) +$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomD) fooSer :: String 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" @@ -75,9 +85,9 @@ fooParse = unlines [ "jsonDecFoo : Json.Decode.Decoder ( Foo )" , "jsonDecFoo =" - , " (\"name\" := Json.Decode.string) >>= \\pname ->" - , " (\"blablub\" := Json.Decode.int) >>= \\pblablub ->" - , " Json.Decode.succeed {name = pname, blablub = pblablub}" + , " Json.Decode.succeed (\\pname pblablub -> {name = pname, blablub = pblablub})" + , " |> required \"name\" (Json.Decode.string)" + , " |> required \"blablub\" (Json.Decode.int)" ] barSer :: String @@ -87,8 +97,8 @@ , " 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)" + , " , (\"tuple\", (\\(v1,v2) -> Json.Encode.list identity [(Json.Encode.int) v1,(Json.Encode.string) v2]) val.tuple)" + , " , (\"list\", (Json.Encode.list Json.Encode.bool) val.list)" , " ]" ] @@ -107,11 +117,11 @@ barParse = unlines [ "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )" , "jsonDecBar localDecoder_a =" - , " (\"name\" := localDecoder_a) >>= \\pname ->" - , " (\"blablub\" := Json.Decode.int) >>= \\pblablub ->" - , " (\"tuple\" := Json.Decode.map2 (,) (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string))) >>= \\ptuple ->" - , " (\"list\" := Json.Decode.list (Json.Decode.bool)) >>= \\plist ->" - , " Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist}" + , " Json.Decode.succeed (\\pname pblablub ptuple plist -> {name = pname, blablub = pblablub, tuple = ptuple, list = plist})" + , " |> required \"name\" (localDecoder_a)" + , " |> required \"blablub\" (Json.Decode.int)" + , " |> required \"tuple\" (Json.Decode.map2 tuple2 (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string)))" + , " |> required \"list\" (Json.Decode.list (Json.Decode.bool))" ] bazParse :: String @@ -119,8 +129,8 @@ [ "jsonDecBaz : Json.Decode.Decoder a -> Json.Decode.Decoder ( Baz a )" , "jsonDecBaz localDecoder_a =" , " let jsonDecDictBaz = Dict.fromList" - , " [ (\"Baz1\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz1 ( (\"foo\" := Json.Decode.int) >>= \\pfoo -> (\"qux\" := jsonDecMap (Json.Decode.int) (localDecoder_a)) >>= \\pqux -> Json.Decode.succeed {foo = pfoo, qux = pqux})))" - , " , (\"Baz2\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz2 ( (Json.Decode.maybe (\"bar\" := Json.Decode.int)) >>= \\pbar -> (\"str\" := Json.Decode.string) >>= \\pstr -> Json.Decode.succeed {bar = pbar, str = pstr})))" + , " [ (\"Baz1\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz1 ( Json.Decode.succeed (\\pfoo pqux -> {foo = pfoo, qux = pqux}) |> required \"foo\" (Json.Decode.int) |> required \"qux\" (jsonDecMap (Json.Decode.int) (localDecoder_a)))))" + , " , (\"Baz2\", Json.Decode.lazy (\\_ -> Json.Decode.map Baz2 ( Json.Decode.succeed (\\pbar pstr -> {bar = pbar, str = pstr}) |> fnullable \"bar\" (Json.Decode.int) |> required \"str\" (Json.Decode.string))))" , " , (\"Testing\", Json.Decode.lazy (\\_ -> Json.Decode.map Testing (jsonDecBaz (localDecoder_a))))" , " ]" , " in decodeSumObjectWithSingleField \"Baz\" jsonDecDictBaz" @@ -151,9 +161,9 @@ test1Parse = unlines [ "jsonDecTestComp : Json.Decode.Decoder a -> Json.Decode.Decoder ( TestComp a )" , "jsonDecTestComp localDecoder_a =" - , " (\"t1\" := jsonDecChange (Json.Decode.int)) >>= \\pt1 ->" - , " (\"t2\" := jsonDecChange (localDecoder_a)) >>= \\pt2 ->" - , " Json.Decode.succeed {t1 = pt1, t2 = pt2}" + , " Json.Decode.succeed (\\pt1 pt2 -> {t1 = pt1, t2 = pt2})" + , " |> required \"t1\" (jsonDecChange (Json.Decode.int))" + , " |> required \"t2\" (jsonDecChange (localDecoder_a))" ] unaryAParse :: String @@ -180,8 +190,8 @@ [ "jsonEncUnaryA : UnaryA -> Value" , "jsonEncUnaryA val =" , " let keyval v = case v of" - , " UnaryA1 -> (\"UnaryA1\", encodeValue (Json.Encode.list []))" - , " UnaryA2 -> (\"UnaryA2\", encodeValue (Json.Encode.list []))" + , " UnaryA1 -> (\"UnaryA1\", encodeValue (Json.Encode.list identity []))" + , " UnaryA2 -> (\"UnaryA2\", encodeValue (Json.Encode.list identity []))" , " in encodeSumObjectWithSingleField keyval val" ] @@ -243,10 +253,36 @@ ntdParse = unlines [ "jsonDecNTD : Json.Decode.Decoder ( NTD )" , "jsonDecNTD =" - , " (\"getNtd\" := Json.Decode.int) >>= \\pgetNtd ->" - , " Json.Decode.succeed (NTD {getNtd = pgetNtd})" + , " Json.Decode.succeed (\\pgetNtd -> (NTD {getNtd = pgetNtd}))" + , " |> required \"getNtd\" (Json.Decode.int)" ] +phantomAParse :: String +phantomAParse = unlines + [ "jsonDecPhantomA : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomA a )" + , "jsonDecPhantomA localDecoder_a =" + , " Json.Decode.int" + ] +phantomBParse :: String +phantomBParse = unlines + [ "jsonDecPhantomB : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomB a )" + , "jsonDecPhantomB localDecoder_a =" + , " Json.Decode.int" + ] +phantomCParse :: String +phantomCParse = unlines + [ "jsonDecPhantomC : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomC a )" + , "jsonDecPhantomC localDecoder_a =" + , " Json.Decode.int" + ] +phantomDParse :: String +phantomDParse = unlines + [ "jsonDecPhantomD : Json.Decode.Decoder a -> Json.Decode.Decoder ( PhantomD a )" + , "jsonDecPhantomD localDecoder_a =" + , " Json.Decode.succeed (\\pgetPhantomD -> (PhantomD {getPhantomD = pgetPhantomD}))" + , " |> required \"getPhantomD\" (Json.Decode.int)" + ] + spec :: Spec spec = describe "json serialisation" $ @@ -264,6 +300,10 @@ rNTB = compileElmDef (Proxy :: Proxy NTB) rNTC = compileElmDef (Proxy :: Proxy NTC) rNTD = compileElmDef (Proxy :: Proxy NTD) + rPhantomA = compileElmDef (Proxy :: Proxy (PhantomA a)) + rPhantomB = compileElmDef (Proxy :: Proxy (PhantomB a)) + rPhantomC = compileElmDef (Proxy :: Proxy (PhantomC a)) + rPhantomD = compileElmDef (Proxy :: Proxy (PhantomD a)) it "should produce the correct ser code" $ do jsonSerForDef rFoo `shouldBe` fooSer jsonSerForDef rBar `shouldBe` barSer @@ -292,3 +332,8 @@ it "should produce the correct parse code for newtypes with unwrapUnaryRecords=False" $ do jsonParserForDef rNTC `shouldBe` ntcParse jsonParserForDef rNTD `shouldBe` ntdParse + it "should produce the correct parse code for phantom newtypes" $ do + jsonParserForDef rPhantomA `shouldBe` phantomAParse + jsonParserForDef rPhantomB `shouldBe` phantomBParse + jsonParserForDef rPhantomC `shouldBe` phantomCParse + jsonParserForDef rPhantomD `shouldBe` phantomDParse diff --git a/test/Elm/ModuleSpec.hs b/test/Elm/ModuleSpec.hs --- a/test/Elm/ModuleSpec.hs +++ b/test/Elm/ModuleSpec.hs @@ -5,7 +5,6 @@ import Elm.Module import Elm.Versions - import Data.Map (Map) import Data.Proxy import Test.Hspec @@ -37,8 +36,8 @@ , "import Json.Encode exposing (Value)" , "-- The following module comes from bartavelle/json-helpers" , "import Json.Helpers exposing (..)" - , "import Dict" - , "import Set" + , "import Dict exposing (Dict)" + , "import Set exposing (Set)" , "" , "" , "type alias Bar a =" @@ -51,21 +50,21 @@ , "" , "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )" , "jsonDecBar localDecoder_a =" - , " (\"name\" := localDecoder_a) >>= \\pname ->" - , " (\"blablub\" := Json.Decode.int) >>= \\pblablub ->" - , " (\"tuple\" := Json.Decode.map2 (,) (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string))) >>= \\ptuple ->" - , " (\"list\" := Json.Decode.list (Json.Decode.bool)) >>= \\plist ->" - , " (\"list_map\" := Json.Decode.list (Json.Decode.dict (Json.Decode.bool))) >>= \\plist_map ->" - , " Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist, list_map = plist_map}" + , " Json.Decode.succeed (\\pname pblablub ptuple plist plist_map -> {name = pname, blablub = pblablub, tuple = ptuple, list = plist, list_map = plist_map})" + , " |> required \"name\" (localDecoder_a)" + , " |> required \"blablub\" (Json.Decode.int)" + , " |> required \"tuple\" (Json.Decode.map2 tuple2 (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string)))" + , " |> required \"list\" (Json.Decode.list (Json.Decode.bool))" + , " |> required \"list_map\" (Json.Decode.list (Json.Decode.dict (Json.Decode.bool)))" , "" , "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)" - , " , (\"list_map\", (Json.Encode.list << List.map (encodeMap (Json.Encode.string) (Json.Encode.bool))) val.list_map)" + , " , (\"tuple\", (\\(v1,v2) -> Json.Encode.list identity [(Json.Encode.int) v1,(Json.Encode.string) v2]) val.tuple)" + , " , (\"list\", (Json.Encode.list Json.Encode.bool) val.list)" + , " , (\"list_map\", (Json.Encode.list (encodeMap (Json.Encode.string) (Json.Encode.bool))) val.list_map)" , " ]" , "" ] @@ -78,8 +77,8 @@ , "import Json.Encode exposing (Value)" , "-- The following module comes from bartavelle/json-helpers" , "import Json.Helpers exposing (..)" - , "import Dict" - , "import Set" + , "import Dict exposing (Dict)" + , "import Set exposing (Set)" , "" , "" , "type Qux a =" @@ -90,14 +89,14 @@ , "jsonDecQux localDecoder_a =" , " let jsonDecDictQux = Dict.fromList" , " [ (\"Qux1\", Json.Decode.lazy (\\_ -> Json.Decode.map2 Qux1 (Json.Decode.index 0 (Json.Decode.int)) (Json.Decode.index 1 (Json.Decode.string))))" - , " , (\"Qux2\", Json.Decode.lazy (\\_ -> Json.Decode.map Qux2 ( (\"a\" := Json.Decode.int) >>= \\pa -> (\"test\" := localDecoder_a) >>= \\ptest -> Json.Decode.succeed {a = pa, test = ptest})))" + , " , (\"Qux2\", Json.Decode.lazy (\\_ -> Json.Decode.map Qux2 ( Json.Decode.succeed (\\pa ptest -> {a = pa, test = ptest}) |> required \"a\" (Json.Decode.int) |> required \"test\" (localDecoder_a))))" , " ]" , " 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]))" + , " Qux1 v1 v2 -> (\"Qux1\", encodeValue (Json.Encode.list identity [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" , "" diff --git a/test/Elm/TyRenderSpec.hs b/test/Elm/TyRenderSpec.hs --- a/test/Elm/TyRenderSpec.hs +++ b/test/Elm/TyRenderSpec.hs @@ -26,9 +26,29 @@ = Okay Int | NotOkay a +data Unit + = Unit + { u_unit :: () + } + +data Paa + = PA1 + | PA2 + +newtype PhantomA a = PhantomA Int +newtype PhantomB a = PhantomB { getPhantomB :: Int } +newtype PhantomC a = PhantomC Int +newtype PhantomD a = PhantomD { getPhantomD :: Int } + $(deriveElmDef (defaultOptionsDropLower 2) ''Foo) $(deriveElmDef (defaultOptionsDropLower 2) ''Bar) $(deriveElmDef defaultOptions ''SomeOpts) +$(deriveElmDef defaultOptions ''Unit) +$(deriveElmDef defaultOptions{allNullaryToStringTag = True, constructorTagModifier = drop 1} ''Paa) +$(deriveElmDef defaultOptions ''PhantomA) +$(deriveElmDef defaultOptions ''PhantomB) +$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomC) +$(deriveElmDef defaultOptions { unwrapUnaryRecords = False } ''PhantomD) fooCode :: String fooCode = "type alias Foo =\n { name: String\n , blablub: Int\n }\n" @@ -39,13 +59,44 @@ someOptsCode :: String someOptsCode = "type SomeOpts a =\n Okay Int\n | NotOkay a\n" +unitCode :: String +unitCode = "type alias Unit =\n { u_unit: ()\n }\n" + +paaCode :: String +paaCode = unlines + [ "type Paa =" + , " PA1 " + , " | PA2 " + ] + +phantomATy :: String +phantomATy = "type alias PhantomA a = Int\n" +phantomBTy :: String +phantomBTy = "type alias PhantomB a = Int\n" +phantomCTy :: String +phantomCTy = "type alias PhantomC a = Int\n" +phantomDTy :: String +phantomDTy = "type PhantomD a = PhantomD\n { getPhantomD: Int\n }\n" + spec :: Spec spec = describe "deriveElmRep" $ do let rFoo = compileElmDef (Proxy :: Proxy Foo) rBar = compileElmDef (Proxy :: Proxy (Bar a)) rSomeOpts = compileElmDef (Proxy :: Proxy (SomeOpts a)) + rUnit = compileElmDef (Proxy :: Proxy Unit) + rPaa = compileElmDef (Proxy :: Proxy Paa) + rPhA = compileElmDef (Proxy :: Proxy (PhantomA a)) + rPhB = compileElmDef (Proxy :: Proxy (PhantomB a)) + rPhC = compileElmDef (Proxy :: Proxy (PhantomC a)) + rPhD = compileElmDef (Proxy :: Proxy (PhantomD a)) it "should produce the correct code" $ do renderElm rFoo `shouldBe` fooCode renderElm rBar `shouldBe` barCode renderElm rSomeOpts `shouldBe` someOptsCode + renderElm rUnit `shouldBe` unitCode + renderElm rPaa `shouldBe` paaCode + renderElm rPhA `shouldBe` phantomATy + renderElm rPhB `shouldBe` phantomBTy + renderElm rPhC `shouldBe` phantomCTy + renderElm rPhD `shouldBe` phantomDTy diff --git a/test/EndToEnd.hs b/test/EndToEnd.hs --- a/test/EndToEnd.hs +++ b/test/EndToEnd.hs @@ -110,7 +110,7 @@ ++ [" ]"] ) where - mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equalHack " ++ encoded ++ "(Json.Encode.encode 0 (jsonEnc" ++ pred ++ num ++ "(Json.Encode.list << List.map Json.Encode.int) (" ++ pretty ++ "))))" + mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equalHack " ++ encoded ++ "(Json.Encode.encode 0 (jsonEnc" ++ pred ++ num ++ "(Json.Encode.list Json.Encode.int) (" ++ pretty ++ "))))" where pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show e encoded = show (encode e) @@ -230,21 +230,19 @@ elmModuleContent :: String elmModuleContent = unlines - [ "-- This module requires the following packages:" - , "-- * elm-community/elm-test" - , "-- * elm-community/html-test-runner" + [ "module MyTests exposing (..)" + , "-- This module requires the following packages:" , "-- * bartavelle/json-helpers" - , "module MyTests exposing (..)" + , "-- * NoRedInk/elm-json-decode-pipeline" , "" , "import Dict exposing (Dict)" + , "import Expect exposing (Expectation, equal)" , "import Set exposing (Set)" , "import Json.Decode exposing (field, Value)" , "import Json.Encode" , "import Json.Helpers exposing (..)" - , "import Test exposing (..)" - , "import Expect exposing (..)" , "import String" - , "import Test.Runner.Html" + , "import Test exposing (Test, describe, test)" , "" , "newtypeDecode : Test" , "newtypeDecode = describe \"Newtype decoding checks\"" @@ -338,8 +336,6 @@ , " let remix = Json.Decode.decodeString Json.Decode.value" , " in equal (remix a) (remix b)" , "" - , "main : Test.Runner.Html.TestProgram" - , "main = concat [newtypeDecode, newtypeEncode, recordDecode, recordEncode, sumDecode, sumEncode, simpleDecode, simpleEncode ] |> Test.Runner.Html.run" , "" , makeModuleContentWithAlterations (newtypeAliases ["Record1", "Record2", "SimpleRecord01", "SimpleRecord02", "SimpleRecord03", "SimpleRecord04"] . defaultAlterations) [ DefineElm (Proxy :: Proxy (Record1 a)) @@ -460,6 +456,6 @@ , mkDecodeTestNT "NT" "_nt" "3" extractNT3 nt3 , mkEncodeTestNT "NT" "_nt" "3" extractNT3 nt3 , dropAll "(Json.Decode.list Json.Decode.int)" (mkDecodeTest "NT" "_nt" "4" nt4) - , dropAll "(Json.Encode.list << List.map Json.Encode.int)" (mkEncodeTest "NT" "_nt" "4" nt4) + , dropAll "(Json.Encode.list Json.Encode.int)" (mkEncodeTest "NT" "_nt" "4" nt4) ]