diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,198 @@ +Eclipse Public License - v 1.0 + +THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC +LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM +CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. + +1. DEFINITIONS + +"Contribution" means: + +a) in the case of the initial Contributor, the initial code and documentation + distributed under this Agreement, and +b) in the case of each subsequent Contributor: + i) changes to the Program, and + ii) additions to the Program; + + where such changes and/or additions to the Program originate from and are + distributed by that particular Contributor. A Contribution 'originates' from + a Contributor if it was added to the Program by such Contributor itself or + anyone acting on such Contributor's behalf. Contributions do not include + additions to the Program which: (i) are separate modules of software + distributed in conjunction with the Program under their own license + agreement, and (ii) are not derivative works of the Program. + +"Contributor" means any person or entity that distributes the Program. + +"Licensed Patents" mean patent claims licensable by a Contributor which are +necessarily infringed by the use or sale of its Contribution alone or when +combined with the Program. + +"Program" means the Contributions distributed in accordance with this Agreement. + +"Recipient" means anyone who receives the Program under this Agreement, +including all Contributors. + +2. GRANT OF RIGHTS + a) Subject to the terms of this Agreement, each Contributor hereby grants + Recipient a non-exclusive, worldwide, royalty-free copyright license to + reproduce, prepare derivative works of, publicly display, publicly perform, + distribute and sublicense the Contribution of such Contributor, if any, and + such derivative works, in source code and object code form. + b) Subject to the terms of this Agreement, each Contributor hereby grants + Recipient a non-exclusive, worldwide, royalty-free patent license under + Licensed Patents to make, use, sell, offer to sell, import and otherwise + transfer the Contribution of such Contributor, if any, in source code and + object code form. This patent license shall apply to the combination of the + Contribution and the Program if, at the time the Contribution is added by + the Contributor, such addition of the Contribution causes such combination + to be covered by the Licensed Patents. The patent license shall not apply + to any other combinations which include the Contribution. No hardware per + se is licensed hereunder. + c) Recipient understands that although each Contributor grants the licenses to + its Contributions set forth herein, no assurances are provided by any + Contributor that the Program does not infringe the patent or other + intellectual property rights of any other entity. Each Contributor + disclaims any liability to Recipient for claims brought by any other entity + based on infringement of intellectual property rights or otherwise. As a + condition to exercising the rights and licenses granted hereunder, each + Recipient hereby assumes sole responsibility to secure any other + intellectual property rights needed, if any. For example, if a third party + patent license is required to allow Recipient to distribute the Program, it + is Recipient's responsibility to acquire that license before distributing + the Program. + d) Each Contributor represents that to its knowledge it has sufficient + copyright rights in its Contribution, if any, to grant the copyright + license set forth in this Agreement. + +3. REQUIREMENTS + +A Contributor may choose to distribute the Program in object code form under its +own license agreement, provided that: + + a) it complies with the terms and conditions of this Agreement; and + b) its license agreement: + i) effectively disclaims on behalf of all Contributors all warranties and + conditions, express and implied, including warranties or conditions of + title and non-infringement, and implied warranties or conditions of + merchantability and fitness for a particular purpose; + ii) effectively excludes on behalf of all Contributors all liability for + damages, including direct, indirect, special, incidental and + consequential damages, such as lost profits; + iii) states that any provisions which differ from this Agreement are offered + by that Contributor alone and not by any other party; and + iv) states that source code for the Program is available from such + Contributor, and informs licensees how to obtain it in a reasonable + manner on or through a medium customarily used for software exchange. + +When the Program is made available in source code form: + + a) it must be made available under this Agreement; and + b) a copy of this Agreement must be included with each copy of the Program. + Contributors may not remove or alter any copyright notices contained within + the Program. + +Each Contributor must identify itself as the originator of its Contribution, if +any, in a manner that reasonably allows subsequent Recipients to identify the +originator of the Contribution. + +4. COMMERCIAL DISTRIBUTION + +Commercial distributors of software may accept certain responsibilities with +respect to end users, business partners and the like. While this license is +intended to facilitate the commercial use of the Program, the Contributor who +includes the Program in a commercial product offering should do so in a manner +which does not create potential liability for other Contributors. Therefore, if +a Contributor includes the Program in a commercial product offering, such +Contributor ("Commercial Contributor") hereby agrees to defend and indemnify +every other Contributor ("Indemnified Contributor") against any losses, damages +and costs (collectively "Losses") arising from claims, lawsuits and other legal +actions brought by a third party against the Indemnified Contributor to the +extent caused by the acts or omissions of such Commercial Contributor in +connection with its distribution of the Program in a commercial product +offering. The obligations in this section do not apply to any claims or Losses +relating to any actual or alleged intellectual property infringement. In order +to qualify, an Indemnified Contributor must: a) promptly notify the Commercial +Contributor in writing of such claim, and b) allow the Commercial Contributor to +control, and cooperate with the Commercial Contributor in, the defense and any +related settlement negotiations. The Indemnified Contributor may participate in +any such claim at its own expense. + +For example, a Contributor might include the Program in a commercial product +offering, Product X. That Contributor is then a Commercial Contributor. If that +Commercial Contributor then makes performance claims, or offers warranties +related to Product X, those performance claims and warranties are such +Commercial Contributor's responsibility alone. Under this section, the +Commercial Contributor would have to defend claims against the other +Contributors related to those performance claims and warranties, and if a court +requires any other Contributor to pay any damages as a result, the Commercial +Contributor must pay those damages. + +5. NO WARRANTY + +EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN +"AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR +IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE, +NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each +Recipient is solely responsible for determining the appropriateness of using and +distributing the Program and assumes all risks associated with its exercise of +rights under this Agreement , including but not limited to the risks and costs +of program errors, compliance with applicable laws, damage to or loss of data, +programs or equipment, and unavailability or interruption of operations. + +6. DISCLAIMER OF LIABILITY + +EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY +CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST +PROFITS), 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 OR DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS +GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + +7. GENERAL + +If any provision of this Agreement is invalid or unenforceable under applicable +law, it shall not affect the validity or enforceability of the remainder of the +terms of this Agreement, and without further action by the parties hereto, such +provision shall be reformed to the minimum extent necessary to make such +provision valid and enforceable. + +If Recipient institutes patent litigation against any entity (including a +cross-claim or counterclaim in a lawsuit) alleging that the Program itself +(excluding combinations of the Program with other software or hardware) +infringes such Recipient's patent(s), then such Recipient's rights granted under +Section 2(b) shall terminate as of the date such litigation is filed. + +All Recipient's rights under this Agreement shall terminate if it fails to +comply with any of the material terms or conditions of this Agreement and does +not cure such failure in a reasonable period of time after becoming aware of +such noncompliance. If all Recipient's rights under this Agreement terminate, +Recipient agrees to cease use and distribution of the Program as soon as +reasonably practicable. However, Recipient's obligations under this Agreement +and any licenses granted by Recipient relating to the Program shall continue and +survive. + +Everyone is permitted to copy and distribute copies of this Agreement, but in +order to avoid inconsistency the Agreement is copyrighted and may only be +modified in the following manner. The Agreement Steward reserves the right to +publish new versions (including revisions) of this Agreement from time to time. +No one other than the Agreement Steward has the right to modify this Agreement. +The Eclipse Foundation is the initial Agreement Steward. The Eclipse Foundation +may assign the responsibility to serve as the Agreement Steward to a suitable +separate entity. Each new version of the Agreement will be given a +distinguishing version number. The Program (including Contributions) may always +be distributed subject to the version of the Agreement under which it was +received. In addition, after a new version of the Agreement is published, +Contributor may elect to distribute the Program (including its Contributions) +under the new version. Except as expressly stated in Sections 2(a) and 2(b) +above, Recipient receives no rights or licenses to the intellectual property of +any Contributor under this Agreement, whether expressly, by implication, +estoppel or otherwise. All rights in the Program not expressly granted under +this Agreement are reserved. + +This Agreement is governed by the laws of the State of New York and the +intellectual property laws of the United States of America. No party to this +Agreement will bring a legal action under this Agreement more than one year +after the cause of action arose. Each party waives its rights to a jury trial in +any resulting litigation. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/elm-export.cabal b/elm-export.cabal new file mode 100644 --- /dev/null +++ b/elm-export.cabal @@ -0,0 +1,59 @@ +name: elm-export +version: 0.3.0.0 +cabal-version: >=1.10 +build-type: Simple +license: OtherLicense +license-file: LICENSE.txt +copyright: 2015 Kris Jenkins +maintainer: kris.jenkins@clearercode.com +homepage: http://github.com/krisajenkins/elm-export +synopsis: A library to generate Elm types from Haskell source. +description: + Please see README.md +category: Web +author: Kris Jenkins + +source-repository head + type: git + location: https://github.com/krisajenkins/elm-export + +library + exposed-modules: + Elm + build-depends: + base >=4.7 && <5, + bytestring >=0.10.6.0 && <0.11, + containers >=0.5.6.2 && <0.6, + directory >=1.2.2.0 && <1.3, + mtl >=2.2.1 && <2.3, + text >=1.2.2.0 && <1.3, + time >=1.5.0.1 && <1.6 + default-language: Haskell2010 + hs-source-dirs: src + other-modules: + Elm.Type + Elm.Common + Elm.Decoder + Elm.Encoder + Elm.File + Elm.Record + +test-suite elm-export-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: + QuickCheck >=2.8.1 && <2.9, + base >=4.8.2.0 && <4.9, + bytestring >=0.10.6.0 && <0.11, + containers >=0.5.6.2 && <0.6, + elm-export >=0.3.0.0 && <0.4, + hspec >=2.2.2 && <2.3, + hspec-core >=2.2.2 && <2.3, + quickcheck-instances >=0.3.12 && <0.4, + text >=1.2.2.0 && <1.3, + time >=1.5.0.1 && <1.6 + default-language: Haskell2010 + hs-source-dirs: test + other-modules: + ExportSpec + ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Elm.hs b/src/Elm.hs new file mode 100644 --- /dev/null +++ b/src/Elm.hs @@ -0,0 +1,8 @@ +module Elm (module X) where + +import Elm.Common as X (Options (..), defaultOptions) +import Elm.Decoder as X +import Elm.Encoder as X +import Elm.File as X +import Elm.Record as X +import Elm.Type as X diff --git a/src/Elm/Common.hs b/src/Elm/Common.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Common.hs @@ -0,0 +1,21 @@ +module Elm.Common where + +import Elm.Type + +isTopLevel :: ElmTypeExpr -> Bool +isTopLevel (Primitive _) = True +isTopLevel (DataType _ _) = True +isTopLevel (Product (Primitive "List") (Primitive "Char")) = True +isTopLevel _ = False + +-- Put parentheses around the string if the Elm type requires it (i.e. it's not a +-- Primitive Elm type nor a named DataType). +parenthesize :: ElmTypeExpr -> String -> String +parenthesize t s = + if isTopLevel t then s else "(" ++ s ++ ")" + +data Options = + Options {fieldLabelModifier :: String -> String} + +defaultOptions :: Options +defaultOptions = Options {fieldLabelModifier = id} diff --git a/src/Elm/Decoder.hs b/src/Elm/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Decoder.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} + +module Elm.Decoder (toElmDecoderSource, toElmDecoderSourceWith) + where + +import Control.Monad.Reader +import Elm.Common +import Elm.Type +import Text.Printf + +render :: ElmTypeExpr -> Reader Options String + +render (TopLevel (DataType d t)) = + printf "%s : Json.Decode.Decoder %s\n%s =\n%s" fnName d fnName <$> render t + where fnName = "decode" ++ d + +render (DataType d _) = return $ "decode" ++ d + +render (Record n t) = printf " Json.Decode.succeed %s\n%s" n <$> render t + +render (Product (Primitive "List") (Primitive "Char")) = render (Primitive "String") + +render (Product (Primitive "List") t) = printf "Json.Decode.list %s" <$> render t + +render (Product (Primitive "Maybe") t) = printf "Json.Decode.maybe %s" <$> render t + +render (Product x y) = + do bodyX <- render x + bodyY <- render y + return $ printf "%s\n%s" bodyX bodyY + +render (Selector n t) = + do fieldModifier <- asks fieldLabelModifier + printf " |: (\"%s\" := %s)" (fieldModifier n) <$> render t + +render (Tuple2 x y) = + do bodyX <- render x + bodyY <- render y + return $ printf "Json.Decode.tuple2 (,) %s %s" bodyX bodyY + +render (Dict x y) = + printf "Json.Decode.map Dict.fromList (Json.Decode.list (%s))" <$> render (Tuple2 x y) + +render (Primitive "String") = return "Json.Decode.string" + +render (Primitive "Int") = return "Json.Decode.int" + +render (Primitive "Double") = return "Json.Decode.float" + +render (Primitive "Float") = return "Json.Decode.float" + +render (Primitive "Date") = return "Json.Decode.Extra.date" + +render (Primitive "Bool") = return "Json.Decode.bool" + +render (Field t) = render t + +render x = return $ printf "<%s>" (show x) + +toElmDecoderSourceWith :: ElmType a => Options -> a -> String +toElmDecoderSourceWith options x = + runReader (render . TopLevel $ toElmType x) options + +toElmDecoderSource :: ElmType a => a -> String +toElmDecoderSource = toElmDecoderSourceWith defaultOptions diff --git a/src/Elm/Encoder.hs b/src/Elm/Encoder.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Encoder.hs @@ -0,0 +1,61 @@ +module Elm.Encoder (toElmEncoderSource, toElmEncoderSourceWith) + where + +import Control.Monad.Reader +import Elm.Common +import Elm.Type +import Text.Printf + +render :: ElmTypeExpr -> Reader Options String + +render (TopLevel (DataType d t)) = + printf "%s : %s -> Json.Encode.Value\n%s x =%s" fnName d fnName <$> render t + where fnName = "encode" ++ d + +render (DataType d _) = return $ "encode" ++ d + +render (Record _ t) = + printf "\n Json.Encode.object\n [ %s\n ]" <$> render t + +render (Product (Primitive "List") (Primitive "Char")) = + render (Primitive "String") + +render (Product (Primitive "List") t) = + printf "(Json.Encode.list << List.map %s)" <$> render t + +render (Product (Primitive "Maybe") t) = + printf "(Maybe.withDefault Json.Encode.null << Maybe.map %s)" <$> render t + +render (Tuple2 x y) = + do bodyX <- render x + bodyY <- render y + return $ printf "Exts.Json.Encode.tuple2 %s %s" bodyX bodyY + +render (Dict x y) = + do bodyX <- render x + bodyY <- render y + return $ printf "Exts.Json.Encode.dict %s %s" bodyX bodyY + +render (Product x y) = + do bodyX <- render x + bodyY <- render y + return $ printf "%s\n , %s" bodyX bodyY + +render (Selector n t) = + do fieldModifier <- asks fieldLabelModifier + typeBody <- render t + return $ printf "( \"%s\", %s x.%s )" (fieldModifier n) typeBody n + +render (Primitive "String") = return "Json.Encode.string" +render (Primitive "Int") = return "Json.Encode.int" +render (Primitive "Double") = return "Json.Encode.float" +render (Primitive "Float") = return "Json.Encode.float" +render (Primitive "Date") = return "(Json.Encode.string << Exts.Date.toISOString)" +render (Primitive "Bool") = return "Json.Encode.bool" +render (Field t) = render t + +toElmEncoderSourceWith :: ElmType a => Options -> a -> String +toElmEncoderSourceWith options x = runReader (render . TopLevel $ toElmType x) options + +toElmEncoderSource :: ElmType a => a -> String +toElmEncoderSource = toElmEncoderSourceWith defaultOptions diff --git a/src/Elm/File.hs b/src/Elm/File.hs new file mode 100644 --- /dev/null +++ b/src/Elm/File.hs @@ -0,0 +1,38 @@ +module Elm.File (Spec(..),specsToDir) where + +import Data.List +import System.Directory +import Text.Printf + +pathString :: [String] -> String +pathString = intercalate "/" + +data Spec = + Spec {namespace :: [String] + ,declarations :: [String]} + +pathForSpec :: FilePath -> Spec -> [String] +pathForSpec rootDir spec = rootDir : namespace spec + +ensureDirectory :: FilePath -> Spec -> IO () +ensureDirectory rootDir spec = + let dir = pathString . init $ pathForSpec rootDir spec + in createDirectoryIfMissing True dir + +specToFile :: FilePath -> Spec -> IO () +specToFile rootDir spec = + let path = pathForSpec rootDir spec + file = pathString path ++ ".elm" + namespaceString = + intercalate "." + (namespace spec) + body = + intercalate + "\n\n" + (printf "module %s where" namespaceString : declarations spec) + in do printf "Writing: %s\n" file + writeFile file body + +specsToDir :: [Spec] -> FilePath -> IO () +specsToDir specs rootDir = mapM_ processSpec specs + where processSpec = ensureDirectory rootDir >> specToFile rootDir diff --git a/src/Elm/Record.hs b/src/Elm/Record.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Record.hs @@ -0,0 +1,73 @@ +module Elm.Record (toElmTypeSource,toElmTypeSourceWith) where + +import Control.Monad.Reader +import Elm.Common +import Elm.Type +import Text.Printf + +render :: ElmTypeExpr -> Reader Options String + +render (TopLevel (DataType dataTypeName record@(Record _ _))) = + printf "type alias %s =\n { %s\n }" dataTypeName <$> render record + +render (TopLevel (DataType d s@(Sum _ _))) = + printf "type %s\n = %s" d <$> render s + +render (DataType d _) = return d +render (Primitive s) = return s + +render (Sum x y) = + do bodyX <- render x + bodyY <- render y + return $ printf "%s\n | %s" bodyX bodyY + +render (Field t) = render t + +render (Selector s t) = do fieldModifier <- asks fieldLabelModifier + printf "%s : %s" (fieldModifier s) <$> render t + +render (Constructor c Unit) = pure c + +render (Constructor c t) = printf "%s %s" c <$> render t + +render (Tuple2 x y) = + do bodyX <- render x + bodyY <- render y + return $ printf "( %s, %s )" bodyX bodyY + +render (Dict x y) = + do bodyX <- render x + bodyY <- render y + return $ printf "Dict %s %s" bodyX bodyY + +render (Product (Primitive "List") (Primitive "Char")) = return "String" + +render (Product (Primitive "List") p@(Product _ _)) = + printf "List (%s)" <$> render p + +render (Product (Primitive "List") t) = printf "List %s" <$> render t + +render (Product (Primitive "Dict") (Product k v)) = + do keyBody <- render k + valueBody <- render v + return $ printf "Dict %s %s" keyBody valueBody + +render (Product x y) = + do bodyX <- render x + bodyY <- render y + return $ printf ("%s " ++ parenthesize y "%s") bodyX bodyY + +render (Record n (Product x y)) = + do bodyX <- render (Record n x) + bodyY <- render (Record n y) + return $ printf "%s\n , %s" bodyX bodyY + +render (Record _ s@(Selector _ _)) = render s + +render Unit = return "" + +toElmTypeSourceWith :: ElmType a => Options -> a -> String +toElmTypeSourceWith options x = runReader (render . TopLevel $ toElmType x) options + +toElmTypeSource :: ElmType a => a -> String +toElmTypeSource = toElmTypeSourceWith defaultOptions diff --git a/src/Elm/Type.hs b/src/Elm/Type.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Type.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Elm.Type where + +import Data.Map +import Data.Proxy +import Data.Text +import Data.Time +import GHC.Generics +import Prelude + +-- TODO Without doubt, this definition can be tightened up so that +-- there are fewer (or hopefully zero) representable illegal states. +data ElmTypeExpr where + TopLevel :: ElmTypeExpr -> ElmTypeExpr + DataType :: String -> ElmTypeExpr -> ElmTypeExpr + Record :: String -> ElmTypeExpr -> ElmTypeExpr + Constructor :: String -> ElmTypeExpr -> ElmTypeExpr + Selector :: String -> ElmTypeExpr -> ElmTypeExpr + Field :: ElmTypeExpr -> ElmTypeExpr + Sum :: ElmTypeExpr -> ElmTypeExpr -> ElmTypeExpr + Dict :: ElmTypeExpr -> ElmTypeExpr -> ElmTypeExpr + Tuple2 :: ElmTypeExpr -> ElmTypeExpr -> ElmTypeExpr + Product :: ElmTypeExpr -> ElmTypeExpr -> ElmTypeExpr + Unit :: ElmTypeExpr + Primitive :: String -> ElmTypeExpr + deriving (Eq, Show) + +class ElmType a where + toElmType :: a -> ElmTypeExpr + default toElmType :: (Generic a,GenericElmType (Rep a)) => a -> ElmTypeExpr + toElmType = genericToElmType . from + +instance ElmType Bool where + toElmType _ = Primitive "Bool" + +instance ElmType Char where + toElmType _ = Primitive "Char" + +instance ElmType Text where + toElmType _ = Primitive "String" + +instance ElmType Float where + toElmType _ = Primitive "Float" + +instance ElmType UTCTime where + toElmType _ = Primitive "Date" + +instance ElmType Day where + toElmType _ = Primitive "Date" + +instance ElmType Double where + toElmType _ = Primitive "Float" + +instance ElmType Int where + toElmType _ = Primitive "Int" + +instance ElmType Integer where + toElmType _ = Primitive "Int" + +instance (ElmType a,ElmType b) => ElmType (a,b) where + toElmType _ = + Tuple2 (toElmType (Proxy :: Proxy a)) + (toElmType (Proxy :: Proxy b)) + +instance ElmType a => ElmType [a] where + toElmType _ = Product (Primitive "List") (toElmType (Proxy :: Proxy a)) + +instance ElmType a => ElmType (Maybe a) where + toElmType _ = Product (Primitive "Maybe") (toElmType (Proxy :: Proxy a)) + +instance (ElmType k,ElmType v) => ElmType (Map k v) where + toElmType _ = + Dict (toElmType (Proxy :: Proxy k)) + (toElmType (Proxy :: Proxy v)) + +instance ElmType a => ElmType (Proxy a) where + toElmType _ = toElmType (undefined :: a) + +class GenericElmType f where + genericToElmType :: f a -> ElmTypeExpr + +instance (GenericElmType f,Datatype d) => GenericElmType (D1 d f) where + genericToElmType d@(M1 x) = + DataType (datatypeName d) + (genericToElmType x) + +instance (Constructor c,GenericElmType f) => GenericElmType (C1 c f) where + genericToElmType c@(M1 x) = + if conIsRecord c + then Record name body + else Constructor name body + where name = conName c + body = genericToElmType x + +instance (Selector c,GenericElmType f) => GenericElmType (S1 c f) where + genericToElmType s@(M1 x) = + Selector (selName s) + (genericToElmType x) + +instance GenericElmType U1 where + genericToElmType _ = Unit + +instance (ElmType c) => GenericElmType (K1 R c) where + genericToElmType (K1 x) = Field (toElmType x) + +instance (GenericElmType f,GenericElmType g) => GenericElmType (f :+: g) where + genericToElmType _ = Sum + (genericToElmType (undefined :: f p)) + (genericToElmType (undefined :: g p)) + +instance (GenericElmType f,GenericElmType g) => GenericElmType (f :*: g) where + genericToElmType _ = + Product (genericToElmType (undefined :: f p)) + (genericToElmType (undefined :: g p)) diff --git a/test/ExportSpec.hs b/test/ExportSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExportSpec.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module ExportSpec where + +-- import Data.Aeson +-- import Data.ByteString hiding (readFile) +-- import qualified Data.ByteString.Lazy as LBS +import Data.Char +import Data.Map +import Data.Proxy +import Data.Text +import Data.Time +import Elm +import GHC.Generics +import Test.Hspec hiding (Spec) +import Test.Hspec as Hspec +import Text.Printf + +data Post = + Post {id :: Int + ,name :: String + ,age :: Maybe Double + ,comments :: [Comment] + ,promoted :: Maybe Comment + ,author :: Maybe String} + deriving (Generic,ElmType) + +data Comment = + Comment {postId :: Int + ,text :: Text + ,mainCategories :: (String,String) + ,published :: Bool + ,created :: UTCTime + ,tags :: Map String Int} + deriving (Generic,ElmType) + +data Position + = Beginning + | Middle + | End + deriving (Generic,ElmType) + +spec :: Hspec.Spec +spec = + do toElmTypeSpec + toElmDecoderSpec + toElmEncoderSpec + +toElmTypeSpec :: Hspec.Spec +toElmTypeSpec = + describe "Convert to Elm types." $ + do it "toElmTypeSource Post" $ + shouldMatchTypeSource defaultOptions + (Proxy :: Proxy Post) + "test/PostType.elm" + it "toElmTypeSource Comment" $ + shouldMatchTypeSource defaultOptions + (Proxy :: Proxy Comment) + "test/CommentType.elm" + it "toElmTypeSource Position" $ + shouldMatchTypeSource defaultOptions + (Proxy :: Proxy Position) + "test/PositionType.elm" + it "toElmTypeSourceWithOptions Post" $ + shouldMatchTypeSource + (defaultOptions {fieldLabelModifier = withPrefix "post"}) + (Proxy :: Proxy Post) + "test/PostTypeWithOptions.elm" + it "toElmTypeSourceWithOptions Comment" $ + shouldMatchTypeSource + (defaultOptions {fieldLabelModifier = withPrefix "comment"}) + (Proxy :: Proxy Comment) + "test/CommentTypeWithOptions.elm" + +toElmDecoderSpec :: Hspec.Spec +toElmDecoderSpec = + describe "Convert to Elm decoders." $ + do it "toElmDecoderSource Post" $ + shouldMatchDecoderSource defaultOptions + (Proxy :: Proxy Post) + "test/PostDecoder.elm" + it "toElmDecoderSource Comment" $ + shouldMatchDecoderSource defaultOptions + (Proxy :: Proxy Comment) + "test/CommentDecoder.elm" + it "toElmDecoderSourceWithOptions Post" $ + shouldMatchDecoderSource + (defaultOptions {fieldLabelModifier = withPrefix "post"}) + (Proxy :: Proxy Post) + "test/PostDecoderWithOptions.elm" + it "toElmDecoderSourceWithOptions Comment" $ + shouldMatchDecoderSource + (defaultOptions {fieldLabelModifier = withPrefix "comment"}) + (Proxy :: Proxy Comment) + "test/CommentDecoderWithOptions.elm" + it "toElmDecoderSourceWithOptions Position" $ + shouldMatchDecoderSource + (defaultOptions {fieldLabelModifier = withPrefix "position"}) + (Proxy :: Proxy Position) + "test/PositionDecoderWithOptions.elm" + +toElmEncoderSpec :: Hspec.Spec +toElmEncoderSpec = + describe "Convert to Elm encoders." $ + do it "toElmEncoderSource Post" $ + shouldMatchEncoderSource defaultOptions + (Proxy :: Proxy Post) + "test/PostEncoder.elm" + it "toElmEncoderSource Comment" $ + shouldMatchEncoderSource defaultOptions + (Proxy :: Proxy Comment) + "test/CommentEncoder.elm" + it "toElmEncoderSource Position" $ + shouldMatchEncoderSource defaultOptions + (Proxy :: Proxy Position) + "test/PositionEncoder.elm" + it "toElmEncoderSourceWithOptions Post" $ + shouldMatchEncoderSource + (defaultOptions {fieldLabelModifier = withPrefix "post"}) + (Proxy :: Proxy Post) + "test/PostEncoderWithOptions.elm" + it "toElmEncoderSourceWithOptions Comment" $ + shouldMatchEncoderSource + (defaultOptions {fieldLabelModifier = withPrefix "comment"}) + (Proxy :: Proxy Comment) + "test/CommentEncoderWithOptions.elm" + it "toElmEncoderSourceWithOptions Position" $ + shouldMatchEncoderSource + (defaultOptions {fieldLabelModifier = withPrefix "position"}) + (Proxy :: Proxy Position) + "test/PositionEncoderWithOptions.elm" + +shouldMatchTypeSource + :: ElmType a + => Options -> a -> FilePath -> IO () +shouldMatchTypeSource options x = + shouldMatchFile . printf outputWrapping $ toElmTypeSourceWith options x + +shouldMatchDecoderSource + :: ElmType a + => Options -> a -> FilePath -> IO () +shouldMatchDecoderSource options x = + shouldMatchFile . printf outputWrapping $ toElmDecoderSourceWith options x + +shouldMatchEncoderSource + :: ElmType a + => Options -> a -> FilePath -> IO () +shouldMatchEncoderSource options x = + shouldMatchFile . printf outputWrapping $ toElmEncoderSourceWith options x + +outputWrapping :: String +outputWrapping = "module Main (..) where\n\n\n%s\n" + +shouldMatchFile :: String -> FilePath -> IO () +shouldMatchFile actual fileExpected = + do source <- readFile fileExpected + actual `shouldBe` source + +initCap :: String -> String +initCap [] = [] +initCap (c:cs) = Data.Char.toUpper c : cs + +withPrefix :: String -> String -> String +withPrefix prefix s = prefix ++ initCap s + +k = hspec spec diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}