elm-bridge (empty) → 0.1.0.0
raw patch · 16 files changed
+859/−0 lines, 16 filesdep +basedep +elm-bridgedep +hspecsetup-changed
Dependencies added: base, elm-bridge, hspec, template-haskell
Files
- LICENSE +30/−0
- README.md +71/−0
- Setup.hs +2/−0
- elm-bridge.cabal +50/−0
- examples/Example1.hs +20/−0
- src/Elm/Derive.hs +146/−0
- src/Elm/Json.hs +133/−0
- src/Elm/Module.hs +28/−0
- src/Elm/TyRender.hs +57/−0
- src/Elm/TyRep.hs +79/−0
- test/Elm/DeriveSpec.hs +83/−0
- test/Elm/JsonSpec.hs +66/−0
- test/Elm/ModuleSpec.hs +31/−0
- test/Elm/TestHelpers.hs +9/−0
- test/Elm/TyRenderSpec.hs +53/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015 Alexander Thiemann <mail@athiemann.net>++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.
+ README.md view
@@ -0,0 +1,71 @@+Elm Bridge+=====++[](https://travis-ci.org/agrafix/elm-bridge)++[](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!++## 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)++deriveElmDef defaultOpts ''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+++type alias Foo =+ { f_name: String+ , f_blablub: Int+ }++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 val =+ Json.Encode.object+ [ ("f_name", Json.Encode.string val.f_name)+ , ("f_blablub", Json.Encode.int val.f_blablub)+ ]+```++For more usage examples check the tests or the examples dir.++## Install++* Using cabal: `cabal install elm-bridge`+* From Source: `git clone https://github.com/agrafix/elm-bridge.git && cd elm-bridge && cabal install`
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ elm-bridge.cabal view
@@ -0,0 +1,50 @@+name: elm-bridge+version: 0.1.0.0+synopsis: Derive Elm types from Haskell types+description: Building the bridge from Haskell to Elm and back. Define types once,+ use on both sides and enjoy easy (de)serialisation. Cheers!+homepage: http://github.com/agrafix/derive-elm+license: BSD3+license-file: LICENSE+author: Alexander Thiemann <mail@athiemann.net>+maintainer: Alexander Thiemann <mail@athiemann.net>+copyright: (c) 2015 Alexander Thiemann+category: Web, Compiler, Language+build-type: Simple+cabal-version: >=1.10++extra-source-files:+ README.md+ examples/*.hs++library+ hs-source-dirs: src+ exposed-modules:+ Elm.Derive+ Elm.Json+ Elm.Module+ Elm.TyRender+ Elm.TyRep+ build-depends: base >= 4.7 && < 5,+ template-haskell+ 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.TestHelpers+ Elm.ModuleSpec+ build-depends:+ base,+ hspec >= 2.0,+ elm-bridge+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/agrafix/derive-elm
+ examples/Example1.hs view
@@ -0,0 +1,20 @@+{-# 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)++deriveElmDef defaultOpts ''Foo++main :: IO ()+main =+ putStrLn $ makeElmModule "Foo"+ [ DefineElm (Proxy :: Proxy Foo)+ ]
+ src/Elm/Derive.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+module Elm.Derive+ ( deriveElmDef, defaultOpts, DeriveOpts(..) )+where++import Elm.TyRep++import Control.Monad+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++data DeriveOpts+ = DeriveOpts+ { do_fieldModifier :: String -> String+ , do_constrModifier :: String -> String+ }++defaultOpts :: DeriveOpts+defaultOpts =+ DeriveOpts+ { do_fieldModifier = id+ , do_constrModifier = id+ }++isConcreteType :: Type -> Bool+isConcreteType ty =+ case ty of+ AppT l r ->+ isConcreteType l+ ListT -> True++conCompiler :: String -> String+conCompiler s =+ case s of+ "Double" -> "Float"+ "Text" -> "String"+ "Vector" -> "List"+ _ -> s++compileType :: Type -> Q Exp+compileType ty =+ case ty of+ ListT -> [|ETyCon (ETCon "List")|]+ TupleT i -> [|ETyTuple i|]+ ConT name ->+ let n = conCompiler $ nameBase name+ in [|ETyCon (ETCon n)|]+ VarT name ->+ let n = nameBase name+ in [|ETyVar (ETVar n)|]+ SigT ty _ ->+ compileType ty+ AppT a b ->+ let a1 = compileType a+ b1 = compileType b+ in [|ETyApp $a1 $b1|]+ _ -> fail $ "Unsupported type: " ++ show ty+++runDerive :: Name -> [TyVarBndr] -> (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 :: DeriveOpts -> Name -> [TyVarBndr] -> Con -> Q [Dec]+deriveAlias opts name vars c =+ case c of+ RecC _ conFields ->+ let fields = listE $ map mkField conFields+ in runDerive name vars $ \typeName ->+ [|ETypeAlias (EAlias $typeName $fields)|]+ _ ->+ fail "Can only derive records like C { v :: Int, w :: a }"+ where+ mkField :: VarStrictType -> Q Exp+ mkField (fname, _, ftype) =+ [|(fldName, $fldType)|]+ where+ fldName = do_fieldModifier opts $ nameBase fname+ fldType = compileType ftype++deriveSum :: DeriveOpts -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]+deriveSum opts name vars constrs =+ runDerive name vars $ \typeName ->+ [|ETypeSum (ESum $typeName $sumOpts)|]+ where+ sumOpts =+ listE $ map mkOpt constrs+ mkOpt :: Con -> Q Exp+ mkOpt c =+ case c of+ NormalC name args ->+ let n = do_constrModifier opts $ nameBase name+ tyArgs = listE $ map (\(_, ty) -> compileType ty) args+ in [|(n, $tyArgs)|]+ _ ->+ fail "Can only derive sum types with options like C Int a"++deriveSynonym :: DeriveOpts -> Name -> [TyVarBndr] -> Type -> Q [Dec]+deriveSynonym opts name vars otherT =+ runDerive name vars $ \typeName ->+ [|ETypePrimAlias (EPrimAlias $typeName $otherType)|]+ where+ otherType = compileType otherT++deriveElmDef :: DeriveOpts -> Name -> Q [Dec]+deriveElmDef opts name =+ do TyConI tyCon <- reify name+ case tyCon of+ DataD _ _ tyVars constrs _ ->+ case constrs of+ [] -> fail "Can not derive empty data decls"+ [x] -> deriveAlias opts name tyVars x+ _ -> deriveSum opts name tyVars constrs+ NewtypeD _ _ tyVars constr _ ->+ deriveAlias opts name tyVars constr+ TySynD _ vars otherTy ->+ deriveSynonym opts name vars otherTy+ _ -> fail "Oops, can only derive data and newtype"
+ src/Elm/Json.hs view
@@ -0,0 +1,133 @@+{- |+This module implements a generator for JSON serialisers and parsers of arbitrary elm types.+Please note: It's still very hacky and might not work for all possible elm types yet.+-}+module Elm.Json+ ( jsonParserForDef+ , jsonSerForDef+ )+where++import Data.List+import Data.Maybe++import Elm.TyRep++-- | Compile a JSON parser for an Elm type+jsonParserForType :: EType -> String+jsonParserForType 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' -> "Json.Decode.maybe (" ++ jsonParserForType t' ++ ")"+ _ ->+ case unpackTupleType ty of+ [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty+ [x] ->+ case unpackToplevelConstr x of+ (y : ys) ->+ jsonParserForType y ++ " "+ ++ unwords (catMaybes $ map (\t' ->+ case t' of+ ETyVar _ -> Just $ "(" ++ jsonParserForType t' ++ ")"+ _ -> Nothing+ ) ys)+ _ -> error $ "Do suitable json parser found for " ++ show ty+ xs ->+ let tupleLen = length xs+ commas = replicate (tupleLen - 1) ','+ in "Json.Decode.tuple" ++ show tupleLen ++ " (" ++ commas ++ ") "+ ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")") xs)++-- | Compile a JSON parser for an Elm type definition+jsonParserForDef :: ETypeDef -> String+jsonParserForDef etd =+ case etd of+ ETypePrimAlias (EPrimAlias name ty) ->+ makeName name ++ " = " ++ jsonParserForType ty ++ "\n"+ ETypeAlias (EAlias name fields) ->+ makeName name ++ " = \n"+ ++ intercalate "\n" (map (\(fldName, fldType) -> " (\"" ++ fldName ++ "\" := "+ ++ jsonParserForType fldType+ ++ ") `Json.Decode.andThen` \\p" ++ fldName ++ " -> ") fields)+ ++ "\n Json.Decode.succeed {" ++ intercalate ", " (map (\(fldName, _) -> fldName ++ " = p" ++ fldName) fields) ++ "}\n"+ ETypeSum (ESum name opts) ->+ makeName name ++ " = \n"+ ++ " Json.Decode.oneOf \n [ "+ ++ intercalate "\n , " (map mkOpt opts) ++ "\n"+ ++ " ]\n"+ where+ mkOpt (name, args) =+ let argLen = length args+ in "(\"" ++ name ++ "\" := Json.tuple" ++ show argLen ++ " " ++ name ++ " "+ ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")") args)+ ++ ")"+ where+ makeName name =+ "jsonDec" ++ et_name name ++ " "+ ++ unwords (map (\tv -> "localDecoder_" ++ tv_name tv) $ et_args name)++-- | Compile a JSON serializer for an Elm type+jsonSerForType :: EType -> String+jsonSerForType 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 << map " ++ jsonSerForType t' ++ ")"+ ETyApp (ETyCon (ETCon "Maybe")) t' -> "(\v -> case v of Just val -> " ++ jsonSerForType t' ++ " val Nothing -> Json.Encode.null)"+ _ ->+ case unpackTupleType ty of+ [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty+ [x] ->+ case unpackToplevelConstr x of+ (y : ys) ->+ "(" ++ jsonSerForType y ++ " "+ ++ unwords (catMaybes $ map (\t' ->+ case t' of+ ETyVar _ -> Just $ "(" ++ jsonSerForType t' ++ ")"+ _ -> Nothing+ ) ys) ++ ")"+ _ -> error $ "Do suitable json serialiser found for " ++ show ty+ xs ->+ let tupleLen = length xs+ tupleArgsV = zip xs [1..]+ tupleArgs =+ unwords $ map (\(_, v) -> "v" ++ show v) tupleArgsV+ in "(\\" ++ tupleArgs ++ " -> [" ++ intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType t' ++ ") v" ++ 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 ++ " = " ++ jsonSerForType ty ++ " val\n"+ ETypeAlias (EAlias name fields) ->+ makeName name ++ " = \n Json.Encode.object\n ["+ ++ intercalate "\n ," (map (\(fldName, fldType) -> " (\"" ++ fldName ++ "\", " ++ jsonSerForType fldType ++ " val." ++ fldName ++ ")") fields)+ ++ "\n ]\n"+ ETypeSum (ESum name opts) ->+ makeName name ++ " = \n"+ ++ " case val of\n "+ ++ intercalate "\n " (map mkOpt opts) ++ "\n"+ where+ mkOpt (name, args) =+ let namedArgs = zip args [1..]+ argList = unwords $ map (\(_, i) -> "v" ++ show i ) namedArgs+ mkArg :: (EType, Int) -> String+ mkArg (arg, idx) =+ jsonSerForType arg ++ " v" ++ show idx+ in " " ++ name ++ " " ++ argList ++ " -> [" ++ intercalate ", " (map mkArg namedArgs) ++ "]"+ where+ makeName name =+ "jsonEnc" ++ et_name name ++ " "+ ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name)+ ++ " val"
+ src/Elm/Module.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Elm.Module where++import Data.Proxy+import Data.List++import Elm.TyRep+import Elm.TyRender+import Elm.Json++-- | Existential quantification wrapper for lists of type definitions+data DefineElm+ = forall a. IsElmDefinition a => DefineElm (Proxy a)++-- | Compile an Elm module+makeElmModule :: String -> [DefineElm] -> String+makeElmModule moduleName defs =+ "module " ++ moduleName ++ " where \n\n"+ ++ "import Json.Decode\n"+ ++ "import Json.Decode exposing ((:=))\n"+ ++ "import Json.Encode\n"+ ++ "\n\n"+ ++ intercalate "\n\n" (map mkDef defs)+ where+ mkDef (DefineElm proxy) =+ let def = compileElmDef proxy+ in renderElm def ++ "\n" ++ jsonParserForDef def ++ "\n" ++ jsonSerForDef def ++ "\n"
+ src/Elm/TyRender.hs view
@@ -0,0 +1,57 @@+module Elm.TyRender where++import Elm.TyRep++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 renderSingleTy xs) ++ ")"+ where+ renderSingleTy ty =+ case ty of+ ETyVar v -> renderElm v+ ETyCon c -> renderElm c+ ETyTuple n -> error "Library Bug: This should never happen!"+ ETyApp l r -> "(" ++ renderElm l ++ " " ++ renderElm r ++ ")"++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 =+ "type alias " ++ renderElm (ea_name alias) ++ " = \n { "+ ++ intercalate "\n , " (map (\(fld, ty) -> 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_options s))+ ++ "\n"+ where+ mkOpt (name, types) =+ name ++ " " ++ unwords (map renderElm types)++instance ElmRenderable EPrimAlias where+ renderElm pa =+ "type alias " ++ renderElm (epa_name pa) ++ " = " ++ renderElm (epa_type pa) ++ "\n"
+ src/Elm/TyRep.hs view
@@ -0,0 +1,79 @@+module Elm.TyRep where++import Data.List+import Data.Proxy++class IsElmDefinition a where+ compileElmDef :: Proxy a -> ETypeDef++data ETypeDef+ = ETypeAlias EAlias+ | ETypePrimAlias EPrimAlias+ | ETypeSum ESum+ deriving (Show, Eq)++data EType+ = ETyVar ETVar+ | ETyCon ETCon+ | ETyApp EType EType+ | ETyTuple Int+ deriving (Show, Eq, Ord)++data ETCon+ = ETCon+ { tc_name :: String+ } deriving (Show, Eq, Ord)++data ETVar+ = ETVar+ { tv_name :: String+ } deriving (Show, Eq, Ord)++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)]+ } deriving (Show, Eq, Ord)++data ESum+ = ESum+ { es_name :: ETypeName+ , es_options :: [(String, [EType])]+ } deriving (Show, Eq, Ord)++unpackTupleType :: EType -> [EType]+unpackTupleType t =+ unfoldr (\ty ->+ case ty of+ Just (ETyApp (ETyApp (ETyTuple i) r) r') ->+ Just (r, Just r')+ Just t ->+ Just (t, Nothing)+ Nothing ->+ Nothing+ ) (Just t)++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)
+ test/Elm/DeriveSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}+module Elm.DeriveSpec (spec) where++import Elm.Derive+import Elm.TyRep++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++deriveElmDef defaultOpts ''Foo+deriveElmDef defaultOpts ''Bar+deriveElmDef defaultOpts ''SomeOpts++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"}))]+ }++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"})))+ ]+ }++someOptsElm :: ETypeDef+someOptsElm =+ ETypeSum $+ ESum+ { es_name =+ ETypeName+ { et_name = "SomeOpts"+ , et_args = [ETVar {tv_name = "a"}]+ }+ , es_options =+ [ ("Okay",[ETyCon (ETCon {tc_name = "Int"})])+ , ("NotOkay",[ETyVar (ETVar {tv_name = "a"})])+ ]+ }++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
+ test/Elm/JsonSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TemplateHaskell #-}+module Elm.JsonSpec (spec) where++import Elm.Derive+import Elm.TyRep+import Elm.Json++import Elm.TestHelpers++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++$(deriveElmDef (fieldDropOpts 2) ''Foo)+$(deriveElmDef (fieldDropOpts 2) ''Bar)+$(deriveElmDef defaultOpts ''SomeOpts)++fooSer :: String+fooSer = "jsonEncFoo val = \n Json.Encode.object\n [ (\"name\", Json.Encode.string val.name)\n , (\"blablub\", Json.Encode.int val.blablub)\n ]\n"++fooParse :: String+fooParse = "jsonDecFoo = \n (\"name\" := Json.Decode.string) `Json.Decode.andThen` \\pname -> \n (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub -> \n Json.Decode.succeed {name = pname, blablub = pblablub}\n"++barSer :: String+barSer = "jsonEncBar localEncoder_a val = \n Json.Encode.object\n [ (\"name\", localEncoder_a val.name)\n , (\"blablub\", Json.Encode.int val.blablub)\n , (\"tuple\", (\\v1 v2 -> [(Json.Encode.int) v1,(Json.Encode.string) v2] val.tuple)\n , (\"list\", (Json.Encode.list << map Json.Encode.bool) val.list)\n ]\n"++barParse :: String+barParse = "jsonDecBar localDecoder_a = \n (\"name\" := localDecoder_a) `Json.Decode.andThen` \\pname -> \n (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub -> \n (\"tuple\" := Json.Decode.tuple2 (,) (Json.Decode.int) (Json.Decode.string)) `Json.Decode.andThen` \\ptuple -> \n (\"list\" := Json.Decode.list (Json.Decode.bool)) `Json.Decode.andThen` \\plist -> \n Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist}\n"++someOptsParse :: String+someOptsParse = "jsonDecSomeOpts localDecoder_a = \n Json.Decode.oneOf \n [ (\"Okay\" := Json.tuple1 Okay (Json.Decode.int))\n , (\"NotOkay\" := Json.tuple1 NotOkay (localDecoder_a))\n ]\n"++someOptsSer :: String+someOptsSer = "jsonEncSomeOpts localEncoder_a val = \n case val of\n Okay v1 -> [Json.Encode.int v1]\n NotOkay v1 -> [localEncoder_a v1]\n"++spec :: Spec+spec =+ describe "json serialisation" $+ do let rFoo = compileElmDef (Proxy :: Proxy Foo)+ rBar = compileElmDef (Proxy :: Proxy (Bar a))+ rSomeOpts = compileElmDef (Proxy :: Proxy (SomeOpts a))+ it "should produce the correct ser code" $+ do jsonSerForDef rFoo `shouldBe` fooSer+ jsonSerForDef rBar `shouldBe` barSer+ jsonSerForDef rSomeOpts `shouldBe` someOptsSer+ it "should produce the correct parse code" $+ do jsonParserForDef rFoo `shouldBe` fooParse+ jsonParserForDef rBar `shouldBe` barParse+ jsonParserForDef rSomeOpts `shouldBe` someOptsParse
+ test/Elm/ModuleSpec.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}+module Elm.ModuleSpec (spec) where++import Elm.Derive+import Elm.Module++import Elm.TestHelpers++import Data.Proxy+import Test.Hspec++data Bar a+ = Bar+ { b_name :: a+ , b_blablub :: Int+ , b_tuple :: (Int, String)+ , b_list :: [Bool]+ } deriving (Show, Eq)++$(deriveElmDef (fieldDropOpts 2) ''Bar)++moduleCode :: String+moduleCode = "module Foo where \n\nimport Json.Decode\nimport Json.Decode exposing ((:=))\nimport Json.Encode\n\n\ntype alias Bar a = \n { name: a\n , blablub: Int\n , tuple: (Int, String)\n , list: (List Bool)\n }\n\njsonDecBar localDecoder_a = \n (\"name\" := localDecoder_a) `Json.Decode.andThen` \\pname -> \n (\"blablub\" := Json.Decode.int) `Json.Decode.andThen` \\pblablub -> \n (\"tuple\" := Json.Decode.tuple2 (,) (Json.Decode.int) (Json.Decode.string)) `Json.Decode.andThen` \\ptuple -> \n (\"list\" := Json.Decode.list (Json.Decode.bool)) `Json.Decode.andThen` \\plist -> \n Json.Decode.succeed {name = pname, blablub = pblablub, tuple = ptuple, list = plist}\n\njsonEncBar localEncoder_a val = \n Json.Encode.object\n [ (\"name\", localEncoder_a val.name)\n , (\"blablub\", Json.Encode.int val.blablub)\n , (\"tuple\", (\\v1 v2 -> [(Json.Encode.int) v1,(Json.Encode.string) v2] val.tuple)\n , (\"list\", (Json.Encode.list << map Json.Encode.bool) val.list)\n ]\n\n"++spec :: Spec+spec =+ describe "makeElmModule" $+ it "should produce the correct code" $+ do let modu =+ makeElmModule "Foo" [DefineElm (Proxy :: Proxy (Bar a))]+ modu `shouldBe` moduleCode
+ test/Elm/TestHelpers.hs view
@@ -0,0 +1,9 @@+module Elm.TestHelpers where++import Elm.Derive++fieldDropOpts :: Int -> DeriveOpts+fieldDropOpts i =+ defaultOpts+ { do_fieldModifier = drop i+ }
+ test/Elm/TyRenderSpec.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TemplateHaskell #-}+module Elm.TyRenderSpec (spec) where++import Elm.Derive+import Elm.TyRep+import Elm.TyRender++import Elm.TestHelpers++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++$(deriveElmDef (fieldDropOpts 2) ''Foo)+$(deriveElmDef (fieldDropOpts 2) ''Bar)+$(deriveElmDef defaultOpts ''SomeOpts)++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"++spec :: Spec+spec =+ describe "deriveElmRep" $+ do let rFoo = compileElmDef (Proxy :: Proxy Foo)+ rBar = compileElmDef (Proxy :: Proxy (Bar a))+ rSomeOpts = compileElmDef (Proxy :: Proxy (SomeOpts a))+ it "should produce the correct code" $+ do renderElm rFoo `shouldBe` fooCode+ renderElm rBar `shouldBe` barCode+ renderElm rSomeOpts `shouldBe` someOptsCode
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}