mirror of
https://github.com/ilyakooo0/elm-bridge.git
synced 2024-09-11 14:05:55 +03:00
added json ser/parser and module gen
This commit is contained in:
parent
498e7e3dd1
commit
a70750de09
@ -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,
|
||||
|
@ -34,6 +34,8 @@ conCompiler :: String -> String
|
||||
conCompiler s =
|
||||
case s of
|
||||
"Double" -> "Float"
|
||||
"Text" -> "String"
|
||||
"Vector" -> "List"
|
||||
_ -> s
|
||||
|
||||
compileType :: Type -> Q Exp
|
||||
|
127
src/Elm/Json.hs
Normal file
127
src/Elm/Json.hs
Normal file
@ -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"
|
22
src/Elm/Module.hs
Normal file
22
src/Elm/Module.hs
Normal file
@ -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"
|
@ -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)
|
||||
|
66
test/Elm/JsonSpec.hs
Normal file
66
test/Elm/JsonSpec.hs
Normal file
@ -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
|
31
test/Elm/ModuleSpec.hs
Normal file
31
test/Elm/ModuleSpec.hs
Normal file
@ -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
|
Loading…
Reference in New Issue
Block a user