elm-bridge-0.8.4/examples/0000755000000000000000000000000013132671410013534 5ustar0000000000000000elm-bridge-0.8.4/src/0000755000000000000000000000000014570567116012523 5ustar0000000000000000elm-bridge-0.8.4/src/Elm/0000755000000000000000000000000014675275064013244 5ustar0000000000000000elm-bridge-0.8.4/test/0000755000000000000000000000000014332132216012674 5ustar0000000000000000elm-bridge-0.8.4/test/Elm/0000755000000000000000000000000013661441475013427 5ustar0000000000000000elm-bridge-0.8.4/src/Elm/Derive.hs0000644000000000000000000001735014675275012015015 0ustar0000000000000000{-# 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 ( -- * Options A.Options(..) , A.SumEncoding(..) , defaultOptions , defaultOptionsDropLower -- * Template haskell functions , deriveElmDef , deriveBoth ) where import Elm.TyRep import Control.Applicative import Control.Monad import Data.Aeson.TH (SumEncoding (..), deriveJSON, tagSingleConstructors) import qualified Data.Aeson.TH as A import Data.Char (toLower) import Language.Haskell.TH import Language.Haskell.TH.Syntax import Prelude -- | Note that This default set of options is distinct from that in -- the @aeson@ package. defaultOptions :: A.Options defaultOptions = A.defaultOptions { A.sumEncoding = A.ObjectWithSingleField , A.fieldLabelModifier = id , A.constructorTagModifier = id , A.allNullaryToStringTag = True , A.omitNothingFields = False , A.unwrapUnaryRecords = True } unwrapUnaryRecords :: A.Options -> Bool unwrapUnaryRecords = A.unwrapUnaryRecords {-| 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: > data Foo = Foo { _fooBarQux :: Int } > $(deriveBoth (defaultOptionsDropLower 4) ''Foo) 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|] VarT name -> let n = nameBase name in [|ETyVar (ETVar n)|] 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)|] UntaggedValue -> [|SumEncoding' UntaggedValue|] runDerive :: Name -> [TyVarBndr a] -> (Q Exp -> Q Exp) -> Q [Dec] runDerive name vars mkBody = liftM (:[]) elmDefInst where elmDefInst = instanceD (cxt []) (classType `appT` instanceType) [ funD 'compileElmDef [ clause [ return WildP ] (normalB body) [] ] ] classType = conT ''IsElmDefinition instanceType = foldl appT (conT name) $ map varT argNames body = mkBody [|ETypeName { et_name = nameStr, et_args = $args }|] nameStr = nameBase name args = listE $ map mkTVar argNames mkTVar :: Name -> Q Exp mkTVar n = let str = nameBase n in [|ETVar str|] argNames = flip map vars $ \v -> case v of PlainTV tv _ -> tv KindedTV tv _ _ -> tv deriveAlias :: Bool -> A.Options -> Name -> [TyVarBndr a] -> [VarStrictType] -> Q [Dec] deriveAlias isNewtype opts name vars conFields = runDerive name vars $ \typeName -> [|ETypeAlias (EAlias $typeName $fields omitNothing isNewtype unwrapUnary)|] -- default to no newtype where unwrapUnary = unwrapUnaryRecords opts fields = listE $ map mkField conFields omitNothing = A.omitNothingFields opts mkField :: VarStrictType -> Q Exp mkField (fname, _, ftype) = [|(fldName, $fldType)|] where fldName = A.fieldLabelModifier opts $ nameBase fname fldType = compileType ftype deriveSum :: A.Options -> Name -> [TyVarBndr a] -> [Con] -> Q [Dec] deriveSum opts name vars constrs = runDerive name vars $ \typeName -> [|ETypeSum (ESum $typeName $sumOpts $sumEncOpts omitNothing allNullary)|] where allNullary = A.allNullaryToStringTag opts sumEncOpts = optSumType (A.sumEncoding opts) omitNothing = A.omitNothingFields opts sumOpts = listE $ map mkOpt constrs mkOpt :: Con -> Q Exp mkOpt c = let modifyName n = (nameBase n, A.constructorTagModifier opts (nameBase n)) in case c of NormalC name' args -> let (b, n) = modifyName name' tyArgs = listE $ map (\(_, ty) -> compileType ty) args in [|STC b n (Anonymous $tyArgs)|] RecC name' args -> let (b, n) = modifyName name' tyArgs = listE $ map (\(nm, _, ty) -> let nm' = A.fieldLabelModifier opts $ nameBase nm in [|(nm', $(compileType ty))|]) args in [|STC b n (Named $tyArgs)|] _ -> fail ("Can't derive this sum: " ++ show c) deriveSynonym :: A.Options -> Name -> [TyVarBndr a] -> Type -> Q [Dec] deriveSynonym _ name vars otherT = runDerive name vars $ \typeName -> [|ETypePrimAlias (EPrimAlias $typeName $otherType)|] where otherType = compileType otherT -- | 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" [RecC _ conFields] | not (tagSingleConstructors opts) -> deriveAlias False opts name tyVars conFields _ -> deriveSum opts name tyVars constrs NewtypeD [] _ [] Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] -> deriveSynonym opts name [] otherTy NewtypeD [] _ [] Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] -> if A.unwrapUnaryRecords opts then deriveSynonym opts name [] otherTy 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) elm-bridge-0.8.4/src/Elm/Json.hs0000644000000000000000000004326414332132216014477 0ustar0000000000000000{- | This module implements a generator for JSON serialisers and parsers of arbitrary elm types. 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 , jsonSerForDef , jsonParserForType , jsonSerForType , stringSerForSimpleAdt , stringParserForSimpleAdt ) where import Data.Aeson.Types (SumEncoding (..)) import Data.List import Elm.TyRep import Elm.Utils data MaybeHandling = Root | Leaf deriving Eq -- | Compile a JSON parser for an Elm type jsonParserForType :: EType -> String jsonParserForType = jsonParserForType' Leaf isOption :: EType -> Bool isOption (ETyApp (ETyCon (ETCon "Maybe")) _) = True isOption _ = False jsonParserForType' :: MaybeHandling -> EType -> String jsonParserForType' mh ty = case ty of ETyVar (ETVar v) -> "localDecoder_" ++ v ETyCon (ETCon "Int") -> "Json.Decode.int" ETyCon (ETCon "Float") -> "Json.Decode.float" ETyCon (ETCon "String") -> "Json.Decode.string" 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' -> 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 [x] -> case unpackToplevelConstr x of (y : ys) -> jsonParserForType y ++ " " ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")" ) ys) _ -> error $ "Do suitable json parser found for " ++ show ty xs -> let tupleLen = length xs 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 = case fields of [(_, ftype)] | unwrap -> [ succeed ++ " |> custom (" ++ jsonParserForType' (o ftype) ftype ++ ")" ] _ -> succeed : map mkField fields where 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 ++ ")" 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 -> [SumTypeConstructor] -> Maybe [(String, String)] allUnaries False = const Nothing allUnaries True = mapM isUnary where 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 jsonParserForDef :: ETypeDef -> String jsonParserForDef etd = case etd of ETypePrimAlias (EPrimAlias name ty) -> unlines [ decoderType name , makeName name ++ " =" , " " ++ jsonParserForType ty ] ETypeAlias (EAlias name fields _ newtyping unwrap) -> unlines ( decoderType name : (makeName name ++ " =") : parseRecords (if newtyping then Just name else Nothing) unwrap fields ) ETypeSum (ESum name opts (SumEncoding' encodingType) _ unarystring) -> decoderType name ++ "\n" ++ makeName name ++ " =" ++ case allUnaries unarystring opts of Just names -> " " ++ deriveUnaries names Nothing -> "\n" ++ encodingDictionary opts ++ isObjectSet ++ "\n" ++ declLine opts ++ "\n" where tab n s = replicate n ' ' ++ s typename = et_name name declLine [_] = "" declLine _ = " in " ++ 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 ] UntaggedValue -> "Json.Decode.oneOf (Dict.values " ++ dictName ++ ")" dictName = "jsonDecDict" ++ typename isObjectSetName = "jsonDecObjectSet" ++ typename deriveUnaries strs = unlines [ "" , " let " ++ dictName ++ " = Dict.fromList [" ++ intercalate ", " (map (\(o, s) -> "(" ++ show s ++ ", " ++ o ++ ")") strs ) ++ "]" , " in decodeSumUnaries " ++ show typename ++ " " ++ dictName ] 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 ", " objectSet ++ "]") where objectSet = (map (show . _stcName) $ filter (isNamed . _stcFields) opts) ++ -- if field is empty, it do not have content, so add to objectSet. (map (show . _stcName) $ filter (isEmpty . _stcFields) opts) _ -> "" 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 cname (Anonymous args) = lazy $ unwords ( decodeFunction : cname : zipWith (\t' i -> "(" ++ jsonParserForIndexedType t' i ++ ")") args [0..] ) where decodeFunction = case length args of 0 -> "Json.Decode.succeed" 1 -> "Json.Decode.map" n -> "Json.Decode.map" ++ show n jsonParserForIndexedType :: EType -> Int -> String jsonParserForIndexedType t' i | length args <= 1 = jsonParserForType t' | otherwise = "Json.Decode.index " ++ show i ++ " (" ++ jsonParserForType t' ++ ")" where 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) lazy decoder = "Json.Decode.lazy (\\_ -> " ++ decoder ++ ")" {-| Compile a JSON serializer for an Elm type. The 'omitNothingFields' option is currently not implemented! -} jsonSerForType :: EType -> String jsonSerForType = jsonSerForType' False [1..] jsonSerForType' :: Bool -> [Int] -> EType -> String jsonSerForType' omitnull ns ty = case ty of ETyVar (ETVar v) -> "localEncoder_" ++ v ETyCon (ETCon "Int") -> "Json.Encode.int" ETyCon (ETCon "Float") -> "Json.Encode.float" 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 " ++ jsonSerForType' omitnull ns t' ++ ")" ETyApp (ETyCon (ETCon "Maybe")) t' -> if omitnull then jsonSerForType' omitnull ns t' else "(maybeEncode (" ++ jsonSerForType' omitnull ns t' ++ "))" ETyApp (ETyCon (ETCon "Set")) t' -> "(encodeSet " ++ jsonSerForType' omitnull ns t' ++ ")" ETyApp (ETyApp (ETyCon (ETCon "Dict")) (ETyCon (ETCon "String"))) value -> "(Json.Encode.dict identity (" ++ jsonSerForType' omitnull ns value ++ "))" ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "(encodeMap (" ++ jsonSerForType' omitnull ns key ++ ") (" ++ jsonSerForType' omitnull ns value ++ "))" _ -> case unpackTupleType ty of [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty [x] -> case unpackToplevelConstr x of (y : ys) -> "(" ++ jsonSerForType' omitnull ns y ++ " " ++ unwords (map (\t' -> "(" ++ jsonSerForType' omitnull ns t' ++ ")") ys) ++ ")" _ -> error $ "Do suitable json serialiser found for " ++ show ty xs -> let (ns', rest) = splitAt (length xs) ns tupleArgsV = zip xs ns' tupleArgs = intercalate "," $ map (\(_, v) -> "t" ++ show v) tupleArgsV in "(\\(" ++ tupleArgs ++ ") -> Json.Encode.list identity [" ++ intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType' omitnull rest t' ++ ") t" ++ show idx) tupleArgsV) ++ "])" -- | Compile a JSON serializer for an Elm type definition jsonSerForDef :: ETypeDef -> String jsonSerForDef etd = case etd of ETypePrimAlias (EPrimAlias name ty) -> makeName name False ++ " = " ++ jsonSerForType ty ++ " val\n" ETypeAlias (EAlias name [(fldName, fldType)] _ newtyping True) -> makeName name newtyping ++ " =\n " ++ jsonSerForType fldType ++ " val." ++ fixReserved fldName 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 (SumEncoding' se) _ unarystring) -> case allUnaries unarystring opts of Nothing -> defaultEncoding opts Just strs -> unaryEncoding strs where encodeFunction = case se of ObjectWithSingleField -> "encodeSumObjectWithSingleField" TwoElemArray -> "encodeSumTwoElementArray" TaggedObject k c -> unwords ["encodeSumTaggedObject", show k, show c] UntaggedValue -> "encodeSumUntagged" defaultEncoding [STC _ oname (Anonymous args)] = unlines [ makeType name , fname name ++ " " ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name) ++ "(" ++ cap oname ++ " " ++ argList args ++ ") =" , " " ++ mkEncodeList args ] defaultEncoding os = unlines ( ( makeName name False ++ " =") : " let keyval v = case v of" : map ((replicate 12 ' ' ++) . mkcase) os ++ [ " " ++ unwords ["in", encodeFunction, "keyval", "val"] ] ) unaryEncoding names = unlines ( [ makeName name False ++ " =" , " case val of" ] ++ map (\(o, n) -> replicate 8 ' ' ++ o ++ " -> Json.Encode.string " ++ show n) names ) 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 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"]) mkLocalEncoder n = "(" ++ n ++ " -> Value)" makeName name newtyping = makeType name ++ "\n" ++ fname name ++ " " ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name) ++ if newtyping then " (" ++ et_name name ++ " val)" else " val" -- | Serialize a type like 'type Color = Red | Green | Blue' in a function like -- -- > stringEncColor : Color -> String -- > stringEncColor x = -- > case x of -- > Red -> "red" -- > ... -- -- This is mainly useful for types which are used as part of query parameters and url captures. stringSerForSimpleAdt :: ETypeDef -> String stringSerForSimpleAdt etd = case etd of ETypeSum (ESum name opts (SumEncoding' _se) _ _unarystring) -> defaultEncoding opts where defaultEncoding os = unlines ((makeName name False ++ " =") : " case val of" : map mkcase os) mkcase :: SumTypeConstructor -> String mkcase (STC cname oname (Anonymous args)) = replicate 8 ' ' ++ cap cname ++ " " ++ argList args ++ " -> " ++ show oname mkcase _ = error "stringSerForSimpleAdt.mkcase: Expecting an Anonymous case" argList a = unwords $ map (\i -> "v" ++ show i) [1 .. length a] _ -> error "stringSerForSimpleAdt only works with ETypeSum" where fname name = "stringEnc" ++ et_name name makeType name = fname name ++ " : " ++ intercalate " -> " ([unwords (et_name name : map tv_name (et_args name))] ++ ["String"]) makeName name newtyping = makeType name ++ "\n" ++ fname name ++ " " ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name) ++ if newtyping then " (" ++ et_name name ++ " val)" else " val" -- | Parse a String into a maybe-value for simple ADT types. See 'stringSerForSimpleAdt' for motivation stringParserForSimpleAdt :: ETypeDef -> String stringParserForSimpleAdt etd = case etd of ETypeSum (ESum name opts (SumEncoding' _encodingType) _ _unarystring) -> decoderType name ++ "\n" ++ makeName name ++ " s =\n" ++ encodingDictionary opts ++ "\n" where tab n s = replicate n ' ' ++ s encodingDictionary [STC cname _ args] = " " ++ mkDecoder cname args encodingDictionary os = " case s of\n" ++ tab 8 "" ++ intercalate ("\n" ++ replicate 8 ' ') (map dictEntry os) ++ "\n" ++ tab 8 "_ -> Nothing" dictEntry (STC cname oname _args) = show oname ++ " -> Just " ++ cname mkDecoder _cname _ = error "impossible!" _ -> error "impossible" where funcname name = "stringDec" ++ et_name name prependTypes str = map (\tv -> str ++ tv_name tv) . et_args decoderType name = funcname name ++ " : " ++ intercalate " -> " (["String"] ++ [decoderTypeEnd name]) decoderTypeEnd name = unwords ("Maybe" : et_name name : map tv_name (et_args name)) makeName name = unwords (funcname name : prependTypes "localDecoder_" name) elm-bridge-0.8.4/src/Elm/Module.hs0000644000000000000000000001552214547161515015023 0ustar0000000000000000{-# 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 Control.Arrow (second) import Data.List import Data.Proxy import Elm.Json import Elm.TyRender import Elm.TyRep import Elm.Versions -- | Existential quantification wrapper for lists of type definitions data DefineElm = forall a. IsElmDefinition a => DefineElm (Proxy a) -- | The module header line for this version of Elm moduleHeader :: ElmVersion -> String -> String moduleHeader _ moduleName = "module " ++ moduleName ++ " exposing(..)" -- | Creates an Elm module for the given version. This will use the default -- type conversion rules (to -- convert @Vector@ to @List@, @HashMap a b@ -- to @List (a,b)@, etc.). makeElmModuleWithVersion :: ElmVersion -> String -- ^ Module name -> [DefineElm] -- ^ List of definitions to be included in the module -> String makeElmModuleWithVersion elmVersion moduleName defs = unlines [ moduleHeader elmVersion moduleName , "" , "import Json.Decode" , "import Json.Encode exposing (Value)" , "-- The following module comes from bartavelle/json-helpers" , "import Json.Helpers exposing (..)" , "import Dict exposing (Dict)" , "import Set exposing (Set)" , "" , "" ] ++ makeModuleContent 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.). -- -- default to 0.19 makeElmModule :: String -- ^ Module name -> [DefineElm] -- ^ List of definitions to be included in the module -> String makeElmModule = makeElmModuleWithVersion Elm0p19 -- | 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 = 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_constructors = map alterTypes (es_constructors s) }) where 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. 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@ * @Tagged t v@ -> @v@ -} defaultAlterations :: ETypeDef -> ETypeDef 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 (ETyCon (ETCon "IntMap")) v -> checkMap int (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") -> int ETyCon (ETCon "Natural") -> int ETyCon (ETCon "Int32") -> int ETyCon (ETCon "Int64") -> int ETyCon (ETCon "Text") -> tc "String" ETyCon (ETCon "Vector") -> tc "List" ETyCon (ETCon "Double") -> tc "Float" ETyCon (ETCon "UTCTime") -> tc "Posix" _ -> t where int = tc "Int" isComparable (ETyCon (ETCon n)) = n `elem` ["String", "Int", "Float", "Posix", "Char"] isComparable _ = False -- TODO Lists and Tuples of comparable types tc = ETyCon . ETCon checkMap k v | isComparable k = ETyApp (ETyApp (tc "Dict") k) v | otherwise = ETyApp (tc "List") (ETyApp (ETyApp (ETyTuple 2) k) v) checkSet s | isComparable s = ETyApp (tc "Set") s | otherwise = ETyApp (tc "List") s elm-bridge-0.8.4/src/Elm/TyRender.hs0000644000000000000000000000456214332132216015320 0ustar0000000000000000{-| This module should not usually be imported. -} module Elm.TyRender where import Elm.TyRep import Elm.Utils import Data.List class ElmRenderable a where renderElm :: a -> String instance ElmRenderable ETypeDef where renderElm td = case td of ETypeAlias alias -> renderElm alias ETypeSum s -> renderElm s ETypePrimAlias pa -> renderElm pa instance ElmRenderable EType where renderElm ty = case unpackTupleType ty of [t] -> renderSingleTy t xs -> "(" ++ intercalate ", " (map renderElm xs) ++ ")" where 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 _ -> error "Library Bug: This should never happen!" ETyApp l r -> "(" ++ renderApp l ++ " " ++ renderElm r ++ ")" instance ElmRenderable ETCon where renderElm = tc_name instance ElmRenderable ETVar where renderElm = tv_name instance ElmRenderable ETypeName where renderElm tyName = et_name tyName ++ " " ++ unwords (map renderElm $ et_args tyName) instance ElmRenderable EAlias where 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 " ++ intercalate "\n | " (map mkOpt (es_constructors s)) ++ "\n" where 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 renderElm pa = "type alias " ++ renderElm (epa_name pa) ++ " = " ++ renderElm (epa_type pa) ++ "\n" elm-bridge-0.8.4/src/Elm/TyRep.hs0000644000000000000000000001510414675275012014635 0ustar0000000000000000{-| This module defines how the derived Haskell data types are represented. - It is useful for writing type conversion rules. -} module Elm.TyRep where import qualified Data.Char as Char import Data.List import Data.Proxy import Data.Typeable (TyCon, TypeRep, Typeable, splitTyConApp, tyConName, typeRep, typeRepTyCon) import Data.Aeson.Types (SumEncoding (..)) 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 | ETyApp EType EType | ETyTuple Int deriving (Show, Eq, Ord) {-| Type constructor: > ETCon "Int" -} newtype ETCon = ETCon { tc_name :: String } deriving (Show, Eq, Ord) {-| Type variable: > ETVar "a" -} newtype ETVar = ETVar { tv_name :: String } deriving (Show, Eq, Ord) {-| Type name: > ETypeName "Map" [ETVar "k", ETVar "v"] -} data ETypeName = ETypeName { et_name :: String , et_args :: [ETVar] } deriving (Show, Eq, Ord) data EPrimAlias = EPrimAlias { epa_name :: ETypeName , epa_type :: EType } deriving (Show, Eq, Ord) data EAlias = EAlias { ea_name :: ETypeName , ea_fields :: [(String, EType)] , ea_omit_null :: Bool , ea_newtype :: Bool , 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 isEmpty :: SumTypeFields -> Bool isEmpty (Anonymous []) = True isEmpty (Named []) = True isEmpty _ = False data SumTypeConstructor = STC { _stcName :: String , _stcEncoded :: String , _stcFields :: SumTypeFields } deriving (Show, Eq, Ord) data ESum = 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. unpackTupleType :: EType -> [EType] unpackTupleType et = fromMaybe [et] (extract et) 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 unpackToplevelConstr :: EType -> [EType] unpackToplevelConstr t = reverse $ flip unfoldr (Just t) $ \mT -> case mT of Nothing -> Nothing Just t' -> case t' of ETyApp l r -> 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" UntaggedValue -> "UntaggedValue" 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 (UntaggedValue, UntaggedValue) -> 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 (ObjectWithSingleField, ObjectWithSingleField) -> EQ (TwoElemArray, TwoElemArray) -> EQ (UntaggedValue, UntaggedValue) -> EQ (TaggedObject _ _, _) -> LT (_, TaggedObject _ _) -> GT (ObjectWithSingleField, _) -> LT (_, ObjectWithSingleField) -> GT (UntaggedValue, _) -> LT (_, UntaggedValue) -> GT 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 = foldl ETyApp (ETyTuple $ length args) $ map toElmType' args | otherwise = typeApplication con args where (con, args) = splitTyConApp rep isTuple :: String -> Bool isTuple "Unit" = True isTuple ('T': 'u' : 'p': 'l' : 'e' : ds) = all Char.isDigit ds isTuple ('(':xs) = isTuple' $ reverse xs -- base <= 4.17 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) elm-bridge-0.8.4/src/Elm/Versions.hs0000644000000000000000000000026213645631036015377 0ustar0000000000000000{-| A type to represent versions of Elm for produced code to work against. This module only supports Elm 0.19.x !!! -} module Elm.Versions where data ElmVersion = Elm0p19 elm-bridge-0.8.4/src/Elm/Utils.hs0000644000000000000000000000123613645631036014671 0ustar0000000000000000module 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" ] elm-bridge-0.8.4/test/Spec.hs0000644000000000000000000000072413521613651014133 0ustar0000000000000000module Main where import qualified Elm.DeriveSpec import qualified Elm.TyRenderSpec import qualified Elm.JsonSpec import qualified Elm.ModuleSpec import qualified Elm.TyRepSpec import Test.Hspec main :: IO () main = hspec $ do describe "Elm.DeriveSpec" Elm.DeriveSpec.spec describe "Elm.TyRenderSpec" Elm.TyRenderSpec.spec describe "Elm.JsonSpec" Elm.JsonSpec.spec describe "Elm.ModuleSpec" Elm.ModuleSpec.spec describe "Elm.TyRepSpec" Elm.TyRepSpec.spec elm-bridge-0.8.4/test/Elm/DeriveSpec.hs0000644000000000000000000001217713337171655016024 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Elm.DeriveSpec (spec) where import Elm.Derive import Elm.TyRep import Data.Proxy import Test.Hspec import Data.Char (toLower) data Foo = Foo { f_name :: String , f_blablub :: Int } deriving (Show, Eq) data Bar a = Bar { b_name :: a , b_blablub :: Int , b_tuple :: (Int, String) , 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 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 { 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 , ea_unwrap_unary = True } fooElm :: ETypeDef fooElm = ETypeAlias $ EAlias { ea_name = ETypeName { et_name = "Foo" , et_args = [] } , ea_fields = [("f_name",ETyCon (ETCon {tc_name = "String"})),("f_blablub",ETyCon (ETCon {tc_name = "Int"}))] , ea_omit_null = False , ea_newtype = False , ea_unwrap_unary = True } barElm :: ETypeDef barElm = ETypeAlias $ EAlias { ea_name = ETypeName { et_name = "Bar" , et_args = [ETVar {tv_name = "a"}] } , ea_fields = [ ("b_name",ETyVar (ETVar {tv_name = "a"})) , ("b_blablub",ETyCon (ETCon {tc_name = "Int"})) , ("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 , ea_unwrap_unary = True } bazElm :: ETypeDef bazElm = ETypeSum $ ESum { es_name = ETypeName {et_name = "Baz", et_args = [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 , es_unary_strings = True } quxElm :: ETypeDef quxElm = ETypeSum $ ESum { es_name = ETypeName {et_name = "Qux", et_args = [ETVar {tv_name = "a"}]} , 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 , es_unary_strings = True } someOptsElm :: ETypeDef someOptsElm = ETypeSum $ ESum { es_name = ETypeName { et_name = "SomeOpts" , et_args = [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" $ it "should produce the correct types" $ 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 compileElmDef (Proxy :: Proxy Simple) `shouldBe` simpleElm elm-bridge-0.8.4/test/Elm/TyRenderSpec.hs0000644000000000000000000000576513337173145016343 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Elm.TyRenderSpec (spec) where import Elm.Derive import Elm.TyRep import Elm.TyRender import Data.Proxy import Test.Hspec data Foo = Foo { f_name :: String , f_blablub :: Int } deriving (Show, Eq) data Bar a = Bar { b_name :: a , b_blablub :: Int , b_tuple :: (Int, String) , b_list :: [Bool] } deriving (Show, Eq) data SomeOpts a = 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" barCode :: String 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" 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 elm-bridge-0.8.4/test/Elm/JsonSpec.hs0000644000000000000000000003506113661417756015521 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Elm.JsonSpec (spec) where import Elm.Derive import Elm.Json import Elm.TyRender import Elm.TyRep import qualified Data.Aeson.TH as TH import Data.Aeson.Types (defaultTaggedObject) import Data.Char (toLower) import qualified Data.Map.Strict as M import Data.Proxy import Test.Hspec data Foo = Foo { f_name :: String , f_blablub :: Int } deriving (Show, Eq) data Bar a = Bar { b_name :: a , b_blablub :: Int , b_tuple :: (Int, String) , b_list :: [Bool] } deriving (Show, Eq) data SomeOpts a = Okay Int | NotOkay a 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 } data DoneState = Done | NotDone deriving (Eq, Show) data Id = Id String deriving (Show, Eq) data EditDone = EditDone Id DoneState DoneState deriving (Show, Eq) newtype NTA = NTA Int newtype NTB = NTB { getNtb :: Int } 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) $(deriveElmDef defaultOptions ''SomeOpts) $(deriveElmDef defaultOptions{ allNullaryToStringTag = False } ''UnaryA) $(deriveElmDef defaultOptions{ allNullaryToStringTag = True } ''UnaryB) $(deriveElmDef defaultOptions { fieldLabelModifier = drop 1 . map toLower } ''Baz) $(deriveElmDef (defaultOptions { sumEncoding = defaultTaggedObject }) ''DoneState) $(deriveElmDef (TH.defaultOptions { sumEncoding = TH.defaultTaggedObject }) ''Id) $(deriveElmDef (TH.defaultOptions { sumEncoding = TH.defaultTaggedObject }) ''EditDone) $(deriveElmDef defaultOptions ''NTA) $(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" fooParse :: String fooParse = unlines [ "jsonDecFoo : Json.Decode.Decoder ( Foo )" , "jsonDecFoo =" , " Json.Decode.succeed (\\pname pblablub -> {name = pname, blablub = pblablub})" , " |> required \"name\" (Json.Decode.string)" , " |> required \"blablub\" (Json.Decode.int)" ] barSer :: String 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\", (\\(t1,t2) -> Json.Encode.list identity [(Json.Encode.int) t1,(Json.Encode.string) t2]) val.tuple)" , " , (\"list\", (Json.Encode.list 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 = unlines [ "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )" , "jsonDecBar localDecoder_a =" , " 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 bazParse = unlines [ "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 ( 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" ] someOptsParse :: String someOptsParse = unlines [ "jsonDecSomeOpts : Json.Decode.Decoder a -> Json.Decode.Decoder ( SomeOpts a )" , "jsonDecSomeOpts localDecoder_a =" , " let jsonDecDictSomeOpts = Dict.fromList" , " [ (\"Okay\", Json.Decode.lazy (\\_ -> Json.Decode.map Okay (Json.Decode.int)))" , " , (\"NotOkay\", Json.Decode.lazy (\\_ -> Json.Decode.map NotOkay (localDecoder_a)))" , " ]" , " in decodeSumObjectWithSingleField \"SomeOpts\" jsonDecDictSomeOpts" ] someOptsSer :: String 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 =" , " Json.Decode.succeed (\\pt1 pt2 -> {t1 = pt1, t2 = pt2})" , " |> required \"t1\" (jsonDecChange (Json.Decode.int))" , " |> required \"t2\" (jsonDecChange (localDecoder_a))" ] unaryAParse :: String unaryAParse = unlines [ "jsonDecUnaryA : Json.Decode.Decoder ( UnaryA )" , "jsonDecUnaryA =" , " let jsonDecDictUnaryA = Dict.fromList" , " [ (\"UnaryA1\", Json.Decode.lazy (\\_ -> Json.Decode.succeed UnaryA1))" , " , (\"UnaryA2\", Json.Decode.lazy (\\_ -> Json.Decode.succeed UnaryA2))" , " ]" , " in decodeSumObjectWithSingleField \"UnaryA\" jsonDecDictUnaryA" ] unaryAStringParser :: String unaryAStringParser = unlines [ "stringDecUnaryA : String -> Maybe UnaryA" , "stringDecUnaryA s =" , " case s of" , " \"UnaryA1\" -> Just UnaryA1" , " \"UnaryA2\" -> Just UnaryA2" , " _ -> Nothing" ] unaryBParse :: String unaryBParse = unlines [ "jsonDecUnaryB : Json.Decode.Decoder ( UnaryB )" , "jsonDecUnaryB = " , " let jsonDecDictUnaryB = Dict.fromList [(\"UnaryB1\", UnaryB1), (\"UnaryB2\", UnaryB2)]" , " in decodeSumUnaries \"UnaryB\" jsonDecDictUnaryB" ] unaryASer :: String unaryASer = unlines [ "jsonEncUnaryA : UnaryA -> Value" , "jsonEncUnaryA val =" , " let keyval v = case v of" , " UnaryA1 -> (\"UnaryA1\", encodeValue (Json.Encode.list identity []))" , " UnaryA2 -> (\"UnaryA2\", encodeValue (Json.Encode.list identity []))" , " in encodeSumObjectWithSingleField keyval val" ] unaryAStringSer :: String unaryAStringSer = unlines [ "stringEncUnaryA : UnaryA -> String" , "stringEncUnaryA val =" , " case val of" , " UnaryA1 -> \"UnaryA1\"" , " UnaryA2 -> \"UnaryA2\"" ] unaryBSer :: String unaryBSer = unlines [ "jsonEncUnaryB : UnaryB -> Value" , "jsonEncUnaryB val =" , " case val of" , " UnaryB1 -> Json.Encode.string \"UnaryB1\"" , " UnaryB2 -> Json.Encode.string \"UnaryB2\"" ] doneParse :: String doneParse = unlines [ "jsonDecDoneState : Json.Decode.Decoder ( DoneState )" , "jsonDecDoneState = " , " let jsonDecDictDoneState = Dict.fromList [(\"Done\", Done), (\"NotDone\", NotDone)]" , " in decodeSumUnaries \"DoneState\" jsonDecDictDoneState" ] editDoneParse :: String editDoneParse = unlines [ "jsonDecEditDone : Json.Decode.Decoder ( EditDone )" , "jsonDecEditDone =" , " Json.Decode.lazy (\\_ -> Json.Decode.map3 EditDone (Json.Decode.index 0 (jsonDecId)) (Json.Decode.index 1 (jsonDecDoneState)) (Json.Decode.index 2 (jsonDecDoneState)))" , "" ] idParse :: String idParse = unlines [ "jsonDecId : Json.Decode.Decoder ( Id )" , "jsonDecId =" , " Json.Decode.lazy (\\_ -> Json.Decode.map Id (Json.Decode.string))" , "" ] ntaParse :: String ntaParse = unlines [ "jsonDecNTA : Json.Decode.Decoder ( NTA )" , "jsonDecNTA =" , " Json.Decode.int" ] ntbParse :: String ntbParse = unlines [ "jsonDecNTB : Json.Decode.Decoder ( NTB )" , "jsonDecNTB =" , " Json.Decode.int" ] ntcParse :: String ntcParse = unlines [ "jsonDecNTC : Json.Decode.Decoder ( NTC )" , "jsonDecNTC =" , " Json.Decode.int" ] ntdParse :: String ntdParse = unlines [ "jsonDecNTD : Json.Decode.Decoder ( NTD )" , "jsonDecNTD =" , " 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" $ do let rFoo = compileElmDef (Proxy :: Proxy Foo) rBar = compileElmDef (Proxy :: Proxy (Bar a)) rBaz = compileElmDef (Proxy :: Proxy (Baz a)) rTest1 = compileElmDef (Proxy :: Proxy (TestComp a)) rSomeOpts = compileElmDef (Proxy :: Proxy (SomeOpts a)) rUnaryA = compileElmDef (Proxy :: Proxy UnaryA) rUnaryB = compileElmDef (Proxy :: Proxy UnaryB) rDoneState = compileElmDef (Proxy :: Proxy DoneState) rId = compileElmDef (Proxy :: Proxy Id) rEditDone = compileElmDef (Proxy :: Proxy EditDone) rNTA = compileElmDef (Proxy :: Proxy NTA) 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 jsonSerForDef rSomeOpts `shouldBe` someOptsSer 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 stringSerForSimpleAdt code" $ do stringSerForSimpleAdt rUnaryA `shouldBe` unaryAStringSer it "should produce the correct stringParserForDef code" $ do stringParserForSimpleAdt rUnaryA `shouldBe` unaryAStringParser 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 it "should produce the correct parse code for issue #18" $ do jsonParserForDef rDoneState `shouldBe` doneParse jsonParserForDef rId `shouldBe` idParse jsonParserForDef rEditDone `shouldBe` editDoneParse it "should produce the correct parse code for newtypes with unwrapUnaryRecords=True" $ do jsonParserForDef rNTA `shouldBe` ntaParse jsonParserForDef rNTB `shouldBe` ntbParse 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 elm-bridge-0.8.4/test/Elm/ModuleSpec.hs0000644000000000000000000001156513661423657016035 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Elm.ModuleSpec (spec) where import Elm.Derive import Elm.Module import Elm.Versions import Data.Map (Map) import Data.Proxy import Test.Hspec data Bar a = Bar { b_name :: a , b_blablub :: Int , b_tuple :: (Int, String) , b_list :: [Bool] , b_list_map :: [Map String Bool] } deriving (Show, Eq) data Qux a = Qux1 Int String | Qux2 { _qux2a :: Int, _qux2test :: a } deriving (Show, Eq) $(deriveElmDef (defaultOptionsDropLower 2) ''Bar) $(deriveElmDef (defaultOptionsDropLower 5) ''Qux) moduleHeader' :: ElmVersion -> String -> String moduleHeader' Elm0p19 name = "module " ++ name ++ " exposing(..)" moduleCode :: ElmVersion -> String moduleCode elmVersion = unlines [ moduleHeader' elmVersion "Foo" , "" , "import Json.Decode" , "import Json.Encode exposing (Value)" , "-- The following module comes from bartavelle/json-helpers" , "import Json.Helpers exposing (..)" , "import Dict exposing (Dict)" , "import Set exposing (Set)" , "" , "" , "type alias Bar a =" , " { name: a" , " , blablub: Int" , " , tuple: (Int, String)" , " , list: (List Bool)" , " , list_map: (List (Dict String Bool))" , " }" , "" , "jsonDecBar : Json.Decode.Decoder a -> Json.Decode.Decoder ( Bar a )" , "jsonDecBar localDecoder_a =" , " 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\", (\\(t1,t2) -> Json.Encode.list identity [(Json.Encode.int) t1,(Json.Encode.string) t2]) val.tuple)" , " , (\"list\", (Json.Encode.list Json.Encode.bool) val.list)" , " , (\"list_map\", (Json.Encode.list (Json.Encode.dict identity (Json.Encode.bool))) val.list_map)" , " ]" , "" ] moduleCode' :: ElmVersion -> String moduleCode' elmVersion = unlines [ moduleHeader' elmVersion "Qux" , "" , "import Json.Decode" , "import Json.Encode exposing (Value)" , "-- The following module comes from bartavelle/json-helpers" , "import Json.Helpers exposing (..)" , "import Dict exposing (Dict)" , "import Set exposing (Set)" , "" , "" , "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.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 ( 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 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" , "" ] spec :: Spec spec = do makeElmModuleSpec version0p19Spec makeElmModuleSpec :: Spec makeElmModuleSpec = describe "makeElmModule" $ it "should produce the correct code" $ do let modu = makeElmModule "Foo" [DefineElm (Proxy :: Proxy (Bar a))] let modu' = makeElmModule "Qux" [DefineElm (Proxy :: Proxy (Qux a))] modu `shouldBe` moduleCode Elm0p19 modu' `shouldBe` moduleCode' Elm0p19 version0p19Spec :: Spec version0p19Spec = describe "makeElmModuleWithVersion Elm0p19" $ it "should produce the correct code" $ do let modu = makeElmModuleWithVersion Elm0p19 "Foo" [DefineElm (Proxy :: Proxy (Bar a))] let modu' = makeElmModuleWithVersion Elm0p19 "Qux" [DefineElm (Proxy :: Proxy (Qux a))] modu `shouldBe` moduleCode Elm0p19 modu' `shouldBe` moduleCode' Elm0p19 elm-bridge-0.8.4/test/Elm/TyRepSpec.hs0000644000000000000000000000217713521613651015640 0ustar0000000000000000module Elm.TyRepSpec (spec) where import Elm.TyRep import Data.Proxy import Test.Hspec spec :: Spec spec = describe "toElmType" $ it "should produce the correct code" $ do toElmType (Proxy :: Proxy Int) `shouldBe` ETyCon (ETCon "Int") toElmType (Proxy :: Proxy Float) `shouldBe` ETyCon (ETCon "Float") toElmType (Proxy :: Proxy String) `shouldBe` ETyCon (ETCon "String") toElmType (Proxy :: Proxy Bool) `shouldBe` ETyCon (ETCon "Bool") toElmType (Proxy :: Proxy Char) `shouldBe` ETyCon (ETCon "Char") toElmType (Proxy :: Proxy [Int]) `shouldBe` ETyApp (ETyCon $ ETCon "List") (ETyCon $ ETCon "Int") toElmType (Proxy :: Proxy (Maybe Int)) `shouldBe` ETyApp (ETyCon $ ETCon "Maybe") (ETyCon $ ETCon "Int") toElmType (Proxy :: Proxy ()) `shouldBe` ETyTuple 0 toElmType (Proxy :: Proxy (Int, Bool)) `shouldBe` ETyApp (ETyApp (ETyTuple 2) (ETyCon $ ETCon "Int")) (ETyCon $ ETCon "Bool") toElmType (Proxy :: Proxy (Int, Bool, String)) `shouldBe` ETyApp (ETyApp (ETyApp (ETyTuple 3) (ETyCon $ ETCon "Int")) (ETyCon $ ETCon "Bool")) (ETyCon $ ETCon "String") elm-bridge-0.8.4/test/EndToEnd.hs0000644000000000000000000006217614332132216014704 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Main where import Control.Applicative import Data.Aeson hiding (defaultOptions) import Data.Aeson.Types (SumEncoding (..)) import Data.Char (toLower) import Data.List (stripPrefix) import qualified Data.Map.Strict as M import Data.Proxy import qualified Data.Text as T import Elm.Derive import Elm.Module import Prelude import System.Environment import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen (Gen, oneof, sample') data Record1 a = Record1 { _r1foo :: Int, _r1bar :: Maybe Int, _r1baz :: a, _r1qux :: Maybe a, _r1jmap :: M.Map String Int } deriving Show data Record2 a = Record2 { _r2foo :: Int, _r2bar :: Maybe Int, _r2baz :: a, _r2qux :: Maybe a } deriving Show data RecordNestTuple a = RecordNestTuple (a, (a, 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 data Simple01 a = Simple01 a deriving Show data Simple02 a = Simple02 a deriving Show data Simple03 a = Simple03 a deriving Show data Simple04 a = Simple04 a deriving Show data SimpleRecord01 a = SimpleRecord01 { _s01qux :: a } deriving Show data SimpleRecord02 a = SimpleRecord02 { _s02qux :: a } deriving Show data SimpleRecord03 a = SimpleRecord03 { _s03qux :: a } deriving Show data SimpleRecord04 a = SimpleRecord04 { _s04qux :: a } deriving Show data SumUntagged a = SMInt Int | SMList a deriving Show -- | It include unit, and non single field. data SumIncludeUnit a = SumIncludeUnitZero | SumIncludeUnitOne a | SumIncludeUnitTwo a a deriving Show newtype NT1 = NT1 [Int] deriving Show newtype NT2 = NT2 { _nt2foo :: [Int] } deriving Show newtype NT3 = NT3 [Int] deriving Show newtype NT4 = NT4 { _nt4foo :: [Int] } deriving Show extractNT1 :: NT1 -> [Int] extractNT1 (NT1 x) =x extractNT2 :: NT2 -> [Int] extractNT2 (NT2 x) =x extractNT3 :: NT3 -> [Int] extractNT3 (NT3 x) =x dropAll :: String -> String -> String dropAll needle haystack = case stripPrefix needle haystack of Just nxt -> dropAll needle nxt Nothing -> case haystack of [] -> [] (x:xs) -> x : dropAll needle xs 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 ++ " = describe \"" ++ pred ++ " decode " ++ num ++ "\"" ] ++ map mktest (zip ([1..] :: [Int]) elems) ++ [" ]"] ) where mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equal (Ok (" ++ pretty ++ ")) (Json.Decode.decodeString (jsonDec" ++ pred ++ num ++ " (Json.Decode.list Json.Decode.int)) " ++ 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 " , " mkDecodeTestNT :: ToJSON n => String -> String -> String -> (n -> [Int]) -> [n] -> String mkDecodeTestNT pred prefix num extract elems = unlines ( [ map toLower pred ++ "Decode" ++ num ++ " : Test" , map toLower pred ++ "Decode" ++ num ++ " = describe \"" ++ pred ++ " decode " ++ num ++ "\"" ] ++ map mktest (zip ([1..] :: [Int]) elems) ++ [" ]"] ) where mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equal (Ok (" ++ pretty ++ ")) (Json.Decode.decodeString jsonDec" ++ pred ++ num ++ " " ++ encoded ++ "))" where pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show (extract 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 ++ " = describe \"" ++ pred ++ " encode " ++ num ++ "\"" ] ++ map mktest (zip ([1..] :: [Int]) elems) ++ [" ]"] ) where 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) pfix = if n == 1 then " [ " else " , " mkEncodeTestNT :: (Show a, ToJSON n) => String -> String -> String -> (n -> a) -> [n] -> String mkEncodeTestNT pred prefix num extract elems = unlines ( [ map toLower pred ++ "Encode" ++ num ++ " : Test" , map toLower pred ++ "Encode" ++ num ++ " = describe \"" ++ pred ++ " encode " ++ num ++ "\"" ] ++ map mktest (zip ([1..] :: [Int]) elems) ++ [" ]"] ) where mktest (n,e) = pfix ++ "test \"" ++ show n ++ "\" (\\_ -> equalHack " ++ encoded ++ "(Json.Encode.encode 0 (jsonEnc" ++ pred ++ num ++ " (" ++ pretty ++ "))))" where pretty = T.unpack $ T.replace (T.pack (prefix ++ num)) T.empty $ T.pack $ show (extract 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" mkSimpleRecordDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String mkSimpleRecordDecodeTest = mkDecodeTest "SimpleRecord" "_s" mkSimpleRecordEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String mkSimpleRecordEncodeTest = mkEncodeTest "SimpleRecord" "_s" mkSimpleDecodeTest :: (Show a, ToJSON a) => String -> [a] -> String mkSimpleDecodeTest = mkDecodeTest "Simple" "_s" mkSimpleEncodeTest :: (Show a, ToJSON a) => String -> [a] -> String mkSimpleEncodeTest = mkEncodeTest "Simple" "_s" $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = False } ''Record1) $(deriveBoth defaultOptions{ fieldLabelModifier = drop 3, omitNothingFields = True } ''Record2) $(deriveBoth defaultOptions ''RecordNestTuple) $(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) $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = False } ''Simple01) $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = True } ''Simple02) $(deriveBoth defaultOptions{ allNullaryToStringTag = True, unwrapUnaryRecords = False } ''Simple03) $(deriveBoth defaultOptions{ allNullaryToStringTag = True, unwrapUnaryRecords = True } ''Simple04) $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = False, fieldLabelModifier = drop 4 } ''SimpleRecord01) $(deriveBoth defaultOptions{ allNullaryToStringTag = False, unwrapUnaryRecords = True , fieldLabelModifier = drop 4 } ''SimpleRecord02) $(deriveBoth defaultOptions{ allNullaryToStringTag = True , unwrapUnaryRecords = False, fieldLabelModifier = drop 4 } ''SimpleRecord03) $(deriveBoth defaultOptions{ allNullaryToStringTag = True , unwrapUnaryRecords = True , fieldLabelModifier = drop 4 } ''SimpleRecord04) $(deriveBoth defaultOptions{ sumEncoding = UntaggedValue } ''SumUntagged) -- servant-elm use TaggedObject. $(deriveBoth defaultOptions{ fieldLabelModifier = drop 14, sumEncoding = TaggedObject "tag" "content" } ''SumIncludeUnit) $(deriveBoth defaultOptions ''NT1) $(deriveBoth defaultOptions { fieldLabelModifier = drop 4 } ''NT2) $(deriveBoth defaultOptions { unwrapUnaryRecords = False }''NT3) $(deriveBoth defaultOptions { fieldLabelModifier = drop 4, unwrapUnaryRecords = False } ''NT4) instance Arbitrary a => Arbitrary (Record1 a) where arbitrary = Record1 <$> arbitrary <*> fmap Just arbitrary <*> arbitrary <*> fmap Just arbitrary <*> (M.singleton "a" <$> 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 (RecordNestTuple a) where arbitrary = (\x y z -> RecordNestTuple (x, (y, z))) <$> arbitrary <*> 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 instance Arbitrary a => Arbitrary (Simple01 a) where arbitrary = Simple01 <$> arbitrary instance Arbitrary a => Arbitrary (Simple02 a) where arbitrary = Simple02 <$> arbitrary instance Arbitrary a => Arbitrary (Simple03 a) where arbitrary = Simple03 <$> arbitrary instance Arbitrary a => Arbitrary (Simple04 a) where arbitrary = Simple04 <$> arbitrary instance Arbitrary a => Arbitrary (SimpleRecord01 a) where arbitrary = SimpleRecord01 <$> arbitrary instance Arbitrary a => Arbitrary (SimpleRecord02 a) where arbitrary = SimpleRecord02 <$> arbitrary instance Arbitrary a => Arbitrary (SimpleRecord03 a) where arbitrary = SimpleRecord03 <$> arbitrary instance Arbitrary a => Arbitrary (SimpleRecord04 a) where arbitrary = SimpleRecord04 <$> arbitrary instance Arbitrary a => Arbitrary (SumUntagged a) where arbitrary = oneof [ SMInt <$> arbitrary, SMList <$> arbitrary ] instance Arbitrary a => Arbitrary (SumIncludeUnit a) where arbitrary = oneof [ return SumIncludeUnitZero, SumIncludeUnitOne <$> arbitrary, SumIncludeUnitTwo <$> arbitrary <*> arbitrary] instance Arbitrary NT1 where arbitrary = fmap NT1 arbitrary instance Arbitrary NT2 where arbitrary = fmap NT2 arbitrary instance Arbitrary NT3 where arbitrary = fmap NT3 arbitrary instance Arbitrary NT4 where arbitrary = fmap NT4 arbitrary elmModuleContent :: String elmModuleContent = unlines [ "module MyTests exposing (..)" , "-- This module requires the following packages:" , "-- * bartavelle/json-helpers" , "-- * NoRedInk/elm-json-decode-pipeline" , "-- * elm/json" , "-- * elm-explorations/test" , "" , "import Dict exposing (Dict, fromList)" , "import Expect exposing (Expectation, equal)" , "import Set exposing (Set)" , "import Json.Decode exposing (field, Value)" , "import Json.Encode" , "import Json.Helpers exposing (..)" , "import String" , "import Test exposing (Test, describe, test)" , "" , "newtypeDecode : Test" , "newtypeDecode = describe \"Newtype decoding checks\"" , " [ ntDecode1" , " , ntDecode2" , " , ntDecode3" , " , ntDecode4" , " ]" , "" , "newtypeEncode : Test" , "newtypeEncode = describe \"Newtype encoding checks\"" , " [ ntEncode1" , " , ntEncode2" , " , ntEncode3" , " , ntEncode4" , " ]" , "" , "recordDecode : Test" , "recordDecode = describe \"Record decoding checks\"" , " [ recordDecode1" , " , recordDecode2" , " , recordDecodeNestTuple" , " ]" , "" , "recordEncode : Test" , "recordEncode = describe \"Record encoding checks\"" , " [ recordEncode1" , " , recordEncode2" , " , recordEncodeNestTuple" , " ]" , "" , "sumDecode : Test" , "sumDecode = describe \"Sum decoding checks\"" , " [ sumDecode01" , " , sumDecode02" , " , sumDecode03" , " , sumDecode04" , " , sumDecode05" , " , sumDecode06" , " , sumDecode07" , " , sumDecode08" , " , sumDecode09" , " , sumDecode10" , " , sumDecode11" , " , sumDecode12" , " , sumDecodeUntagged" , " , sumDecodeIncludeUnit" , " ]" , "" , "sumEncode : Test" , "sumEncode = describe \"Sum encoding checks\"" , " [ sumEncode01" , " , sumEncode02" , " , sumEncode03" , " , sumEncode04" , " , sumEncode05" , " , sumEncode06" , " , sumEncode07" , " , sumEncode08" , " , sumEncode09" , " , sumEncode10" , " , sumEncode11" , " , sumEncode12" , " , sumEncodeUntagged" , " , sumEncodeIncludeUnit" , " ]" , "" , "simpleDecode : Test" , "simpleDecode = describe \"Simple records/types decode checks\"" , " [ simpleDecode01" , " , simpleDecode02" , " , simpleDecode03" , " , simpleDecode04" , " , simplerecordDecode01" , " , simplerecordDecode02" , " , simplerecordDecode03" , " , simplerecordDecode04" , " ]" , "" , "simpleEncode : Test" , "simpleEncode = describe \"Simple records/types encode checks\"" , " [ simpleEncode01" , " , simpleEncode02" , " , simpleEncode03" , " , simpleEncode04" , " , simplerecordEncode01" , " , simplerecordEncode02" , " , simplerecordEncode03" , " , simplerecordEncode04" , " ]" , "" , "-- this is done to prevent artificial differences due to object ordering, this won't work with Maybe's though :(" , "equalHack : String -> String -> Expectation" , "equalHack a b =" , " let remix = Json.Decode.decodeString Json.Decode.value" , " in equal (remix a) (remix b)" , "" , "" , makeModuleContentWithAlterations (newtypeAliases ["Record1", "Record2", "SimpleRecord01", "SimpleRecord02", "SimpleRecord03", "SimpleRecord04"] . defaultAlterations) [ DefineElm (Proxy :: Proxy (Record1 a)) , DefineElm (Proxy :: Proxy (Record2 a)) , DefineElm (Proxy :: Proxy (RecordNestTuple 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)) , DefineElm (Proxy :: Proxy (Simple01 a)) , DefineElm (Proxy :: Proxy (Simple02 a)) , DefineElm (Proxy :: Proxy (Simple03 a)) , DefineElm (Proxy :: Proxy (Simple04 a)) , DefineElm (Proxy :: Proxy (SimpleRecord01 a)) , DefineElm (Proxy :: Proxy (SimpleRecord02 a)) , DefineElm (Proxy :: Proxy (SimpleRecord03 a)) , DefineElm (Proxy :: Proxy (SimpleRecord04 a)) , DefineElm (Proxy :: Proxy (SumUntagged a)) , DefineElm (Proxy :: Proxy (SumIncludeUnit a)) , DefineElm (Proxy :: Proxy NT1) , DefineElm (Proxy :: Proxy NT2) , DefineElm (Proxy :: Proxy NT3) , DefineElm (Proxy :: Proxy NT4) ] ] 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]] rent <- sample' arbitrary :: IO [RecordNestTuple [Int]] sp01 <- sample' arbitrary :: IO [Simple01 [Int]] sp02 <- sample' arbitrary :: IO [Simple02 [Int]] sp03 <- sample' arbitrary :: IO [Simple03 [Int]] sp04 <- sample' arbitrary :: IO [Simple04 [Int]] sr01 <- sample' arbitrary :: IO [SimpleRecord01 [Int]] sr02 <- sample' arbitrary :: IO [SimpleRecord02 [Int]] sr03 <- sample' arbitrary :: IO [SimpleRecord03 [Int]] sr04 <- sample' arbitrary :: IO [SimpleRecord04 [Int]] sm <- sample' arbitrary :: IO [SumUntagged [Int]] smiu <- sample' arbitrary :: IO [SumIncludeUnit [Int]] nt1 <- sample' arbitrary :: IO [NT1] nt2 <- sample' arbitrary :: IO [NT2] nt3 <- sample' arbitrary :: IO [NT3] nt4 <- sample' arbitrary :: IO [NT4] 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 , mkRecordDecodeTest "NestTuple" rent , mkRecordEncodeTest "NestTuple" rent , mkSimpleEncodeTest "01" sp01 , mkSimpleEncodeTest "02" sp02 , mkSimpleEncodeTest "03" sp03 , mkSimpleEncodeTest "04" sp04 , mkSimpleDecodeTest "01" sp01 , mkSimpleDecodeTest "02" sp02 , mkSimpleDecodeTest "03" sp03 , mkSimpleDecodeTest "04" sp04 , mkSimpleRecordEncodeTest "01" sr01 , mkSimpleRecordEncodeTest "02" sr02 , mkSimpleRecordEncodeTest "03" sr03 , mkSimpleRecordEncodeTest "04" sr04 , mkSimpleRecordDecodeTest "01" sr01 , mkSimpleRecordDecodeTest "02" sr02 , mkSimpleRecordDecodeTest "03" sr03 , mkSimpleRecordDecodeTest "04" sr04 , mkSumEncodeTest "Untagged" sm , mkSumDecodeTest "Untagged" sm , mkSumEncodeTest "IncludeUnit" smiu , mkSumDecodeTest "IncludeUnit" smiu , mkDecodeTestNT "NT" "_nt" "1" extractNT1 nt1 , mkEncodeTestNT "NT" "_nt" "1" extractNT1 nt1 , mkDecodeTestNT "NT" "_nt" "2" extractNT2 nt2 , mkEncodeTestNT "NT" "_nt" "2" extractNT2 nt2 , 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 Json.Encode.int)" (mkEncodeTest "NT" "_nt" "4" nt4) ] elm-bridge-0.8.4/README.md0000644000000000000000000000534313661417756013224 0ustar0000000000000000Elm Bridge ===== [![Build Status](https://travis-ci.org/agrafix/elm-bridge.svg)](https://travis-ci.org/agrafix/elm-bridge) [![Hackage Deps](https://img.shields.io/hackage-deps/v/elm-bridge.svg)](http://packdeps.haskellers.com/reverse/elm-bridge) ## Intro Hackage: [elm-bridge](http://hackage.haskell.org/package/elm-bridge) 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! This version of the package only supports Elm 0.19. Version 0.5.2 supports Elm 0.18, and Version 0.3.0.2 supports Elm 0.16 and Elm 0.17. Note that the [bartavelle/json-helpers](http://package.elm-lang.org/packages/bartavelle/json-helpers/latest/) package, with version >= 1.2.0, is expected by the generated Elm modules. ## Usage ```haskell {-# LANGUAGE TemplateHaskell #-} import Elm.Derive import Elm.Module import Data.Proxy data Foo = Foo { f_name :: String , f_blablub :: Int } deriving (Show, Eq) deriveBoth defaultOptions ''Foo main :: IO () main = putStrLn $ makeElmModule "Foo" [ DefineElm (Proxy :: Proxy Foo) ] ``` Output will be: ```elm module Foo where import Json.Decode import Json.Decode exposing ((:=)) import Json.Encode import Json.Helpers exposing (..) type alias Foo = { f_name: String , f_blablub: Int } 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) , ("f_blablub", Json.Encode.int val.f_blablub) ] ``` Also, there are functions `Elm.Json.stringSerForSimpleAdt` and `Elm.Json.stringParserForSimpleAdt` to generate functions for your non-JSON ADT types. For more usage examples check the tests or the examples dir. ## Install ### Haskell * Using cabal: `cabal install elm-bridge` * From Source: `git clone https://github.com/agrafix/elm-bridge.git && cd elm-bridge && cabal install` ### Elm * `elm package install bartavelle/json-helpers` or, for Elm 0.19: * `elm install bartavelle/json-helpers` ## Contribute Pull requests are welcome! Please consider creating an issue beforehand, so we can discuss what you would like to do. Code should be written in a consistent style throughout the project. Avoid whitespace that is sensible to conflicts. (E.g. alignment of `=` signs in functions definitions) Note that by sending a pull request you agree that your contribution can be released under the BSD3 License as part of the `elm-bridge` package or related packages. elm-bridge-0.8.4/CHANGELOG.md0000644000000000000000000000301414547161616013542 0ustar0000000000000000# v0.8.3 * Support Int32 and Int64, from domenkozar # v0.8.0 * Directly support integer keys in dictionnaries, thanks to odanoboru # v0.7.0 * Support for GHC 9 # v0.6.0 * Support for Elm 0.19 # v0.5.2 * Fix a bug about tuples. # 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.` Add support for `aeson == 1.2.*` # v0.4.1 ## Bugfixes * Fixed support for Elm 0.18 (see issue #17) # v0.4.0 ## New features * Support for Elm 0.18 * Dropped support for Elm 0.17 and Elm 0.16 # v0.3.0 ## New features * Support for Elm 0.17 # v0.2.2 ## New features * The Elm JSON encoders and decoders now match `aeson` more closely. In partlicular, single constructor sum types are now encoded without the constructor. Also, the `aeson` 0.11 option `unwrapUnaryRecords` is now supported. ## Bugfixes * Fixed Elm type error in encoders for types like `[Map String v]` (0.2.1.2). # 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. elm-bridge-0.8.4/examples/Example1.hs0000644000000000000000000000055713132671410015553 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} import "elm-bridge" Elm.Derive import "elm-bridge" Elm.Module import Data.Proxy data Foo = Foo { f_name :: String , f_blablub :: Int } deriving (Show, Eq) deriveBoth defaultOptions ''Foo main :: IO () main = putStrLn $ makeElmModule "Foo" [ DefineElm (Proxy :: Proxy Foo) ] elm-bridge-0.8.4/LICENSE0000644000000000000000000000306513132671410012727 0ustar0000000000000000Copyright (c) 2015 - 2016 Alexander Thiemann and contributors All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Alexander Thiemann or agrafix nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. elm-bridge-0.8.4/Setup.hs0000644000000000000000000000005613132671410013353 0ustar0000000000000000import Distribution.Simple main = defaultMain elm-bridge-0.8.4/elm-bridge.cabal0000644000000000000000000000461314675275071014735 0ustar0000000000000000name: elm-bridge version: 0.8.4 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 option you like. Cheers! homepage: https://github.com/agrafix/elm-bridge license: BSD3 license-file: LICENSE author: Alexander Thiemann , Simon Marechal maintainer: Alexander Thiemann copyright: (c) 2015 - 2016 Alexander Thiemann and contributors category: Web, Compiler, Language build-type: Simple cabal-version: >=1.10 tested-with: GHC==9.0.1 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 Elm.Versions other-modules: Elm.Utils build-depends: base >= 4.15 && < 5, template-haskell, aeson >= 1 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 ghc-options: -O0 default-language: Haskell2010 test-suite derive-elm-tests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs other-modules: Elm.DeriveSpec Elm.TyRenderSpec Elm.JsonSpec Elm.ModuleSpec Elm.TyRepSpec build-depends: base, hspec >= 2.0, elm-bridge, aeson, containers default-language: Haskell2010 source-repository head type: git location: https://github.com/agrafix/elm-bridge