elm-bridge 0.6.0 → 0.6.1

raw patch · 6 files changed

+135/−21 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +2/−0
• elm-bridge.cabal +1/−1
• src/Elm/Json.hs +87/−0
• test/Elm/JsonSpec.hs +23/−0
• test/Elm/ModuleSpec.hs +1/−1
• test/EndToEnd.hs +21/−19

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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)"     , "   ]"     , ""     ]

@@ -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)                        ]-