first working prototype

.gitignore

@@ -0,0 +1,12 @@
+dist
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+.virthualenv
+.DS_Store
+.cabal-sandbox
+cabal.sandbox.config
+*~
+.stack-work

LICENSE

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

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Lib
+
+main :: IO ()
+main = someFunc

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

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"

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"

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)

src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

stack.yaml

@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps: []
+resolver: lts-2.20

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

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
+    }

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

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}