mirror of
https://github.com/ilyakooo0/elm-bridge.git
synced 2024-10-05 17:47:50 +03:00
first working prototype
This commit is contained in:
commit
ddefcb9e8f
12
.gitignore
vendored
Normal file
12
.gitignore
vendored
Normal file
@ -0,0 +1,12 @@
|
||||
dist
|
||||
cabal-dev
|
||||
*.o
|
||||
*.hi
|
||||
*.chi
|
||||
*.chs.h
|
||||
.virthualenv
|
||||
.DS_Store
|
||||
.cabal-sandbox
|
||||
cabal.sandbox.config
|
||||
*~
|
||||
.stack-work
|
30
LICENSE
Normal file
30
LICENSE
Normal file
@ -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.
|
6
app/Main.hs
Normal file
6
app/Main.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Main where
|
||||
|
||||
import Lib
|
||||
|
||||
main :: IO ()
|
||||
main = someFunc
|
42
elm-bridge.cabal
Normal file
42
elm-bridge.cabal
Normal file
@ -0,0 +1,42 @@
|
||||
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 free (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
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: Elm.Derive, Elm.TyRep, Elm.TyRender
|
||||
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.TestHelpers
|
||||
build-depends:
|
||||
base,
|
||||
hspec >= 2.0,
|
||||
elm-bridge
|
||||
default-language: Haskell2010
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/agrafix/derive-elm
|
131
src/Elm/Derive.hs
Normal file
131
src/Elm/Derive.hs
Normal file
@ -0,0 +1,131 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Elm.Derive
|
||||
( deriveElmDef, defaultOpts, DeriveOpts(..) )
|
||||
where
|
||||
|
||||
import Elm.TyRep
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
compileType :: Type -> Q Exp
|
||||
compileType ty =
|
||||
case ty of
|
||||
ListT -> [|ETyCon (ETCon "List")|]
|
||||
TupleT i -> [|ETyTuple i|]
|
||||
ConT name ->
|
||||
let n = 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 =
|
||||
instanceD (cxt [])
|
||||
(classType `appT` instanceType)
|
||||
[ funD 'compileElmDef
|
||||
[ clause [ return WildP ] (normalB body) []
|
||||
]
|
||||
]
|
||||
where
|
||||
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 r <- deriveElmDef' opts name
|
||||
return [r]
|
||||
|
||||
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"
|
57
src/Elm/TyRender.hs
Normal file
57
src/Elm/TyRender.hs
Normal file
@ -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"
|
66
src/Elm/TyRep.hs
Normal file
66
src/Elm/TyRep.hs
Normal file
@ -0,0 +1,66 @@
|
||||
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)
|
6
src/Lib.hs
Normal file
6
src/Lib.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Lib
|
||||
( someFunc
|
||||
) where
|
||||
|
||||
someFunc :: IO ()
|
||||
someFunc = putStrLn "someFunc"
|
5
stack.yaml
Normal file
5
stack.yaml
Normal file
@ -0,0 +1,5 @@
|
||||
flags: {}
|
||||
packages:
|
||||
- '.'
|
||||
extra-deps: []
|
||||
resolver: lts-2.20
|
83
test/Elm/DeriveSpec.hs
Normal file
83
test/Elm/DeriveSpec.hs
Normal file
@ -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
|
9
test/Elm/TestHelpers.hs
Normal file
9
test/Elm/TestHelpers.hs
Normal file
@ -0,0 +1,9 @@
|
||||
module Elm.TestHelpers where
|
||||
|
||||
import Elm.Derive
|
||||
|
||||
fieldDropOpts :: Int -> DeriveOpts
|
||||
fieldDropOpts i =
|
||||
defaultOpts
|
||||
{ do_fieldModifier = drop i
|
||||
}
|
53
test/Elm/TyRenderSpec.hs
Normal file
53
test/Elm/TyRenderSpec.hs
Normal file
@ -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
|
1
test/Spec.hs
Normal file
1
test/Spec.hs
Normal file
@ -0,0 +1 @@
|
||||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
Loading…
Reference in New Issue
Block a user