added json ser/parser and module gen

elm-bridge.cabal

@@ -18,7 +18,12 @@ extra-source-files:
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Elm.Derive, Elm.TyRep, Elm.TyRender
+  exposed-modules:
+                       Elm.Derive
+                       Elm.Json
+                       Elm.Module
+                       Elm.TyRender
+                       Elm.TyRep
   build-depends:       base >= 4.7 && < 5,
                        template-haskell
   default-language:    Haskell2010
@@ -30,7 +35,9 @@ test-suite derive-elm-tests
   other-modules:
                        Elm.DeriveSpec
                        Elm.TyRenderSpec
+                       Elm.JsonSpec
                        Elm.TestHelpers
+                       Elm.ModuleSpec
   build-depends:
                        base,
                        hspec >= 2.0,

src/Elm/Derive.hs

@@ -34,6 +34,8 @@ conCompiler :: String -> String
 conCompiler s =
     case s of
       "Double" -> "Float"
+      "Text" -> "String"
+      "Vector" -> "List"
       _ -> s
 
 compileType :: Type -> Q Exp

src/Elm/Json.hs

@@ -0,0 +1,127 @@
+module Elm.Json
+    ( jsonParserForDef
+    , jsonSerForDef
+    )
+where
+
+import Data.List
+import Data.Maybe
+
+import Elm.TyRep
+
+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)
+
+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)
+
+
+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) ++ "]"
+
+
+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

@@ -0,0 +1,22 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Elm.Module where
+
+import Data.Proxy
+import Data.List
+
+import Elm.TyRep
+import Elm.TyRender
+import Elm.Json
+
+data DefineElm
+   = forall a. IsElmDefinition a => DefineElm (Proxy a)
+
+makeElmModule :: String -> [DefineElm] -> String
+makeElmModule moduleName defs =
+    "module " ++ moduleName ++ " where \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/TyRep.hs

@@ -64,3 +64,16 @@ unpackTupleType t =
                    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/JsonSpec.hs

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

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