diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -70,6 +70,8 @@ ] ``` +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 diff --git a/elm-bridge.cabal b/elm-bridge.cabal --- a/elm-bridge.cabal +++ b/elm-bridge.cabal @@ -1,5 +1,5 @@ name: elm-bridge -version: 0.6.0 +version: 0.6.1 synopsis: Derive Elm types and Json code from Haskell types, using aeson's options description: Building the bridge from Haskell to Elm and back. Define types once, and derive the aeson and elm functions at the same time, using any aeson diff --git a/src/Elm/Json.hs b/src/Elm/Json.hs --- a/src/Elm/Json.hs +++ b/src/Elm/Json.hs @@ -11,6 +11,8 @@ , jsonSerForDef , jsonParserForType , jsonSerForType + , stringSerForSimpleAdt + , stringParserForSimpleAdt ) where @@ -175,6 +177,7 @@ then jsonSerForType t' else "(maybeEncode (" ++ jsonSerForType t' ++ "))" ETyApp (ETyCon (ETCon "Set")) t' -> "(encodeSet " ++ jsonSerForType t' ++ ")" + ETyApp (ETyApp (ETyCon (ETCon "Dict")) (ETyCon (ETCon "String"))) value -> "(Json.Encode.dict identity (" ++ jsonSerForType value ++ "))" ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "(encodeMap (" ++ jsonSerForType key ++ ") (" ++ jsonSerForType value ++ "))" _ -> case unpackTupleType ty of @@ -253,3 +256,87 @@ ++ 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) diff --git a/test/Elm/JsonSpec.hs b/test/Elm/JsonSpec.hs --- a/test/Elm/JsonSpec.hs +++ b/test/Elm/JsonSpec.hs @@ -177,6 +177,16 @@ , " 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 )" @@ -195,6 +205,15 @@ , " 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" @@ -312,6 +331,10 @@ 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 diff --git a/test/Elm/ModuleSpec.hs b/test/Elm/ModuleSpec.hs --- a/test/Elm/ModuleSpec.hs +++ b/test/Elm/ModuleSpec.hs @@ -64,7 +64,7 @@ , " , (\"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 (encodeMap (Json.Encode.string) (Json.Encode.bool))) val.list_map)" + , " , (\"list_map\", (Json.Encode.list (Json.Encode.dict identity (Json.Encode.bool))) val.list_map)" , " ]" , "" ] diff --git a/test/EndToEnd.hs b/test/EndToEnd.hs --- a/test/EndToEnd.hs +++ b/test/EndToEnd.hs @@ -1,22 +1,23 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} module Main where -import Elm.Derive -import Elm.Module -import Data.Proxy -import Data.Aeson hiding (defaultOptions) -import Data.Aeson.Types (SumEncoding(..)) -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen (sample', oneof, Gen) -import qualified Data.Text as T -import Control.Applicative -import System.Environment -import Data.Char (toLower) -import Data.List (stripPrefix) -import Prelude +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 } deriving Show +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 Sum01 a = Sum01A a | Sum01B (Maybe a) | Sum01C a a | Sum01D { _s01foo :: a } | Sum01E { _s01bar :: Int, _s01baz :: Int } deriving Show @@ -61,7 +62,7 @@ = case stripPrefix needle haystack of Just nxt -> dropAll needle nxt Nothing -> case haystack of - [] -> [] + [] -> [] (x:xs) -> x : dropAll needle xs @@ -186,7 +187,7 @@ $(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 + 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 @@ -234,8 +235,10 @@ , "-- This module requires the following packages:" , "-- * bartavelle/json-helpers" , "-- * NoRedInk/elm-json-decode-pipeline" + , "-- * elm/json" + , "-- * elm-explorations/test" , "" - , "import Dict exposing (Dict)" + , "import Dict exposing (Dict, fromList)" , "import Expect exposing (Expectation, equal)" , "import Set exposing (Set)" , "import Json.Decode exposing (field, Value)" @@ -458,4 +461,3 @@ , dropAll "(Json.Decode.list Json.Decode.int)" (mkDecodeTest "NT" "_nt" "4" nt4) , dropAll "(Json.Encode.list Json.Encode.int)" (mkEncodeTest "NT" "_nt" "4" nt4) ] -