From ddefcb9e8f773be4a637fdc75bd83eca6ca6e2d8 Mon Sep 17 00:00:00 2001 From: Alexander Thiemann Date: Sun, 9 Aug 2015 18:00:06 +0200 Subject: [PATCH] first working prototype --- .gitignore | 12 ++++ LICENSE | 30 +++++++++ Setup.hs | 2 + app/Main.hs | 6 ++ elm-bridge.cabal | 42 +++++++++++++ src/Elm/Derive.hs | 131 +++++++++++++++++++++++++++++++++++++++ src/Elm/TyRender.hs | 57 +++++++++++++++++ src/Elm/TyRep.hs | 66 ++++++++++++++++++++ src/Lib.hs | 6 ++ stack.yaml | 5 ++ test/Elm/DeriveSpec.hs | 83 +++++++++++++++++++++++++ test/Elm/TestHelpers.hs | 9 +++ test/Elm/TyRenderSpec.hs | 53 ++++++++++++++++ test/Spec.hs | 1 + 14 files changed, 503 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 100644 elm-bridge.cabal create mode 100644 src/Elm/Derive.hs create mode 100644 src/Elm/TyRender.hs create mode 100644 src/Elm/TyRep.hs create mode 100644 src/Lib.hs create mode 100644 stack.yaml create mode 100644 test/Elm/DeriveSpec.hs create mode 100644 test/Elm/TestHelpers.hs create mode 100644 test/Elm/TyRenderSpec.hs create mode 100644 test/Spec.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3f32ce7 --- /dev/null +++ b/.gitignore @@ -0,0 +1,12 @@ +dist +cabal-dev +*.o +*.hi +*.chi +*.chs.h +.virthualenv +.DS_Store +.cabal-sandbox +cabal.sandbox.config +*~ +.stack-work diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..039925e --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015 Alexander Thiemann + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..de1c1ab --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = someFunc diff --git a/elm-bridge.cabal b/elm-bridge.cabal new file mode 100644 index 0000000..8971a3b --- /dev/null +++ b/elm-bridge.cabal @@ -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 +maintainer: Alexander Thiemann +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 diff --git a/src/Elm/Derive.hs b/src/Elm/Derive.hs new file mode 100644 index 0000000..971efde --- /dev/null +++ b/src/Elm/Derive.hs @@ -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" diff --git a/src/Elm/TyRender.hs b/src/Elm/TyRender.hs new file mode 100644 index 0000000..a12c3fa --- /dev/null +++ b/src/Elm/TyRender.hs @@ -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" diff --git a/src/Elm/TyRep.hs b/src/Elm/TyRep.hs new file mode 100644 index 0000000..85a106b --- /dev/null +++ b/src/Elm/TyRep.hs @@ -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) diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000..d36ff27 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..3f45371 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +flags: {} +packages: +- '.' +extra-deps: [] +resolver: lts-2.20 diff --git a/test/Elm/DeriveSpec.hs b/test/Elm/DeriveSpec.hs new file mode 100644 index 0000000..f6f556c --- /dev/null +++ b/test/Elm/DeriveSpec.hs @@ -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 diff --git a/test/Elm/TestHelpers.hs b/test/Elm/TestHelpers.hs new file mode 100644 index 0000000..d8b41da --- /dev/null +++ b/test/Elm/TestHelpers.hs @@ -0,0 +1,9 @@ +module Elm.TestHelpers where + +import Elm.Derive + +fieldDropOpts :: Int -> DeriveOpts +fieldDropOpts i = + defaultOpts + { do_fieldModifier = drop i + } diff --git a/test/Elm/TyRenderSpec.hs b/test/Elm/TyRenderSpec.hs new file mode 100644 index 0000000..283a44b --- /dev/null +++ b/test/Elm/TyRenderSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}