diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.7.0.0 +version: 0.7.0.1 -- A short (one-line) description of the package. synopsis: Generate PureScript data types from Haskell data types @@ -70,7 +70,7 @@ -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && <= 5.1 , containers , directory , filepath @@ -90,12 +90,15 @@ Test-Suite tests - type: exitcode-stdio-1.0 - main-is: Spec.hs - build-depends: base - , containers - -- , HUnit - , purescript-bridge - , text - hs-source-dirs: test - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: TestData + build-depends: base + , containers + , purescript-bridge + , text + , hspec + , hspec-expectations-pretty-diff + + hs-source-dirs: test + default-language: Haskell2010 diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -34,7 +34,7 @@ import Language.PureScript.Bridge.TypeInfo -- | Generic representation of your Haskell types. -data SumType (lang :: Language) = SumType (TypeInfo lang) [DataConstructor lang] deriving Show +data SumType (lang :: Language) = SumType (TypeInfo lang) [DataConstructor lang] deriving (Show, Eq) -- | TypInfo lens for 'SumType'. sumTypeInfo :: Functor f => (TypeInfo lang -> f (TypeInfo lang) ) -> SumType lang -> f (SumType lang) @@ -47,21 +47,22 @@ -- | Create a representation of your sum (and product) types, -- for doing type translations and writing it out to your PureScript modules. -- In order to get the type information we use a dummy variable of type 'Proxy' (YourType). -mkSumType :: forall t. (Generic t, Typeable t, GDataConstructor (Rep t)) => Proxy t -> SumType 'Haskell +mkSumType :: forall t. (Generic t, Typeable t, GDataConstructor (Rep t)) + => Proxy t -> SumType 'Haskell mkSumType p = SumType (mkTypeInfo p) constructors where constructors = gToConstructors (from (undefined :: t)) -data DataConstructor (lang :: Language) = DataConstructor { - _sigConstructor :: !Text -, _sigValues :: !(Either [TypeInfo lang] [RecordEntry lang]) -} deriving Show +data DataConstructor (lang :: Language) = + DataConstructor { _sigConstructor :: !Text -- ^ e.g. `Left`/`Right` for `Either` + , _sigValues :: !(Either [TypeInfo lang] [RecordEntry lang]) + } deriving (Show, Eq) -data RecordEntry (lang :: Language) = RecordEntry { - _recLabel :: !Text -, _recValue :: !(TypeInfo lang) -} deriving Show +data RecordEntry (lang :: Language) = + RecordEntry { _recLabel :: !Text -- ^ e.g. `runState` for `State` + , _recValue :: !(TypeInfo lang) + } deriving (Show, Eq) class GDataConstructor f where gToConstructors :: f a -> [DataConstructor 'Haskell] @@ -73,23 +74,22 @@ gToConstructors (M1 c) = gToConstructors c instance (GDataConstructor a, GDataConstructor b) => GDataConstructor (a :+: b) where - gToConstructors (_ :: (a :+: b) f) = gToConstructors (undefined :: a f) ++ gToConstructors (undefined :: b f) + gToConstructors (_ :: (a :+: b) f) = gToConstructors (undefined :: a f) + ++ gToConstructors (undefined :: b f) instance (Constructor a, GRecordEntry b) => GDataConstructor (C1 a b) where - gToConstructors c@(M1 r) = [ - DataConstructor { - _sigConstructor = constructor - , _sigValues = values - } - ] + gToConstructors c@(M1 r) = [ DataConstructor { _sigConstructor = constructor + , _sigValues = values } + ] where constructor = T.pack $ conName c values = if conIsRecord c - then Right $ gToRecordEntries r - else Left $ map _recValue $ gToRecordEntries r + then Right $ gToRecordEntries r + else Left $ map _recValue $ gToRecordEntries r instance (GRecordEntry a, GRecordEntry b) => GRecordEntry (a :*: b) where - gToRecordEntries (_ :: (a :*: b) f) = gToRecordEntries (undefined :: a f) ++ gToRecordEntries (undefined :: b f) + gToRecordEntries (_ :: (a :*: b) f) = gToRecordEntries (undefined :: a f) + ++ gToRecordEntries (undefined :: b f) instance GRecordEntry U1 where diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,55 +1,80 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} - +{-# LANGUAGE CPP #-} module Main where +import Control.Monad (unless) import qualified Data.Map as Map import Data.Proxy -import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable -import GHC.Generics (Generic) import Language.PureScript.Bridge -import Language.PureScript.Bridge.PSTypes import Language.PureScript.Bridge.TypeParameters +import Test.Hspec (Spec, hspec, describe, it) +import Test.Hspec.Expectations.Pretty +import TestData --- Check that examples compile: -textBridge :: BridgePart -textBridge = do - typeName ^== "Text" - typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" - return psString -stringBridge :: BridgePart -stringBridge = do - haskType ^== mkTypeInfo (Proxy :: Proxy String) - return psString +main :: IO () +main = hspec $ do allTests -data Foo = Foo | Bar Int | FooBar Int Text deriving (Generic, Typeable, Show) -data Bar a b m = Bar1 (Maybe a) | Bar2 (Either a b) | Bar3 a - | Bar4 { - myMonadicResult :: m b - } deriving (Generic, Typeable, Show) +allTests :: Spec +allTests = + describe "buildBridge" $ do + it "tests with Int" $ + let bst = buildBridge defaultBridge (mkTypeInfo (Proxy :: Proxy Int)) + ti = TypeInfo { _typePackage = "purescript-prim" + , _typeModule = "Prim" + , _typeName = "Int" + , _typeParameters = []} + in bst `shouldBe` ti + it "tests with custom type Foo" $ + let bst = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo)) + st = SumType + TypeInfo { _typePackage = "" , _typeModule = "TestData" , _typeName = "Foo" , _typeParameters = [] } + [ DataConstructor { _sigConstructor = "Foo" , _sigValues = Left [] } + , DataConstructor + { _sigConstructor = "Bar" + , _sigValues = Left [ TypeInfo { _typePackage = "purescript-prim" , _typeModule = "Prim" , _typeName = "Int" , _typeParameters = [] } ] + } + , DataConstructor + { _sigConstructor = "FooBar" + , _sigValues = Left [ TypeInfo { _typePackage = "purescript-prim" , _typeModule = "Prim" , _typeName = "Int" , _typeParameters = [] } + , TypeInfo { _typePackage = "purescript-prim" , _typeModule = "Prim" , _typeName = "String" , _typeParameters = [] } + ] + } + ] + in bst `shouldBe` st + it "tests the generation of a whole (dummy) module" $ + let advanced = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1))) + modules = sumTypeToModule advanced Map.empty + m = head . map moduleToText . Map.elems $ modules + txt = T.unlines [ "-- File auto generated by purescript-bridge! --" + , "module TestData where" + , "" + , "import Data.Either (Either)" + , "import Data.Maybe (Maybe)" + , "" + , "import Data.Generic (class Generic)" + , "" + , "" + , "data Bar a b m =" + , " Bar1 (Maybe a)" + , " | Bar2 (Either a b)" + , " | Bar3 a" + , " | Bar4 {" + , " myMonadicResult :: m b" + , " }" + , "" + , "derive instance genericBar :: Generic Bar" + , "" + ] + in m `shouldBe` txt -main :: IO () -main = do - let r = buildBridge defaultBridge (mkTypeInfo (Proxy :: Proxy Int)) - let r2 = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo)) - putStrLn "Bridge a single int: " - print r - putStrLn "\nBridge Foo:" - print r2 - let advanced = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1))) - let modules = sumTypeToModule advanced Map.empty - let m = head . map moduleToText . Map.elems $ modules - putStrLn "\n Complete module for Bar type:\n" - putStrLn $ T.unpack m diff --git a/test/TestData.hs b/test/TestData.hs new file mode 100644 --- /dev/null +++ b/test/TestData.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} + + +module TestData where + +import Data.Proxy +import Data.Text (Text) +import Data.Typeable +import GHC.Generics (Generic) +import Language.PureScript.Bridge +import Language.PureScript.Bridge.PSTypes + + + +-- Check that examples compile: +textBridge :: BridgePart +textBridge = do + typeName ^== "Text" + typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" + return psString + +stringBridge :: BridgePart +stringBridge = do + haskType ^== mkTypeInfo (Proxy :: Proxy String) + return psString + +data Foo = Foo + | Bar Int + | FooBar Int Text + deriving (Generic, Typeable, Show) + +data Test = TestIntInt Int Int + | TestBool {bool :: Bool} + | TestVoid + deriving (Generic, Typeable, Show) + +data Bar a b m = Bar1 (Maybe a) | Bar2 (Either a b) | Bar3 a + | Bar4 { myMonadicResult :: m b } + deriving (Generic, Typeable, Show) + + +a :: HaskellType +a = mkTypeInfo (Proxy :: Proxy (Either String Int)) + +applyBridge :: FullBridge +applyBridge = buildBridge defaultBridge + +psA :: PSType +psA = applyBridge a + +b :: SumType 'Haskell +b = mkSumType (Proxy :: Proxy (Either String Int)) + +t :: TypeInfo 'PureScript +cs :: [DataConstructor 'PureScript] +psB :: SumType 'PureScript +psB@(SumType t cs) = bridgeSumType (buildBridge defaultBridge) b +