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.13.0.0 +version: 0.14.0.0 -- A short (one-line) description of the package. synopsis: Generate PureScript data types from Haskell data types diff --git a/src/Language/PureScript/Bridge/Builder.hs b/src/Language/PureScript/Bridge/Builder.hs --- a/src/Language/PureScript/Bridge/Builder.hs +++ b/src/Language/PureScript/Bridge/Builder.hs @@ -43,7 +43,6 @@ import Control.Monad.Trans.Reader (Reader, ReaderT (..), runReader) import Data.Maybe (fromMaybe) -import Data.Monoid import qualified Data.Text as T import Language.PureScript.Bridge.TypeInfo diff --git a/src/Language/PureScript/Bridge/CodeGenSwitches.hs b/src/Language/PureScript/Bridge/CodeGenSwitches.hs --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ b/src/Language/PureScript/Bridge/CodeGenSwitches.hs @@ -1,28 +1,43 @@ -- | General switches for the code generation, such as generating profunctor-lenses or not module Language.PureScript.Bridge.CodeGenSwitches ( Settings (..) + , ForeignOptions(..) , defaultSettings + , purs_0_11_settings , Switch , getSettings , defaultSwitch , noLenses, genLenses + , useGen, useGenRep + , genForeign, noForeign ) where import Data.Monoid (Endo(..)) -- | General settings for code generation -newtype Settings = Settings +data Settings = Settings { generateLenses :: Bool -- ^use purescript-profunctor-lens for generated PS-types? + , genericsGenRep :: Bool -- ^generate generics using purescript-generics-rep instead of purescript-generics + , generateForeign :: Maybe ForeignOptions -- ^generate Foreign.Generic Encode and Decode instances } deriving (Eq, Show) +data ForeignOptions = ForeignOptions + { unwrapSingleConstructors :: Bool + } + deriving (Eq, Show) -- | Settings to generate Lenses defaultSettings :: Settings -defaultSettings = Settings True +defaultSettings = Settings True True Nothing +-- |settings for purescript 0.11.x +purs_0_11_settings :: Settings +purs_0_11_settings = Settings True False Nothing + + -- | you can `mappend` switches to control the code generation type Switch = Endo Settings @@ -45,3 +60,19 @@ -- | Switch on the generatation of profunctor-lenses genLenses :: Switch genLenses = Endo $ \settings -> settings { generateLenses = True } + + +-- | Generate generics using purescript-generics-rep +useGenRep :: Switch +useGenRep = Endo $ \settings -> settings { genericsGenRep = True } + + +-- | Generate generics using purescript-generics +useGen :: Switch +useGen = Endo $ \settings -> settings { genericsGenRep = False } + +genForeign :: ForeignOptions -> Switch +genForeign opts = Endo $ \settings -> settings { generateForeign = Just opts } + +noForeign :: Switch +noForeign = Endo $ \settings -> settings { generateForeign = Nothing } diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs --- a/src/Language/PureScript/Bridge/PSTypes.hs +++ b/src/Language/PureScript/Bridge/PSTypes.hs @@ -8,7 +8,6 @@ module Language.PureScript.Bridge.PSTypes where import Control.Lens (views) -import Data.Monoid import qualified Data.Text as T import Control.Monad.Reader.Class diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -8,7 +8,6 @@ import Control.Monad import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Monoid import Data.Set (Set) import Data.Maybe (isJust) import qualified Data.Set as Set @@ -61,37 +60,47 @@ "-- File auto generated by purescript-bridge! --" : "module " <> psModuleName m <> " where\n" : map importLineToText allImports - ++ [ "" + <> [ "" , "import Prelude" - , "import Data.Generic (class Generic)" , "" ] - ++ map (sumTypeToText settings) (psTypes m) + <> map (sumTypeToText settings) (psTypes m) where - otherImports = - if Switches.generateLenses settings then - importsFromList _lensImports - else - importsFromList _noLensImports + otherImports = importsFromList (_lensImports settings <> _genericsImports settings <> _foreignImports settings) allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) -_lensImports :: [ImportLine] -_lensImports = [ - ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] - , ImportLine "Data.Lens" $ Set.fromList ["Iso'", "Prism'", "Lens'", "prism'", "lens"] - , ImportLine "Data.Lens.Record" $ Set.fromList ["prop"] - , ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"] - , ImportLine "Data.Symbol" $ Set.fromList ["SProxy(SProxy)"] - , ImportLine "Data.Newtype" $ Set.fromList ["class Newtype"] - ] -_noLensImports :: [ImportLine] -_noLensImports = [ - ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] - , ImportLine "Data.Newtype" $ Set.fromList ["class Newtype"] - ] - +_genericsImports :: Switches.Settings -> [ImportLine] +_genericsImports settings + | Switches.genericsGenRep settings = + [ ImportLine "Data.Generic.Rep" $ Set.fromList ["class Generic"] ] + | otherwise = + [ ImportLine "Data.Generic" $ Set.fromList ["class Generic"] ] + +_lensImports :: Switches.Settings -> [ImportLine] +_lensImports settings + | Switches.generateLenses settings = + [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] + , ImportLine "Data.Lens" $ Set.fromList ["Iso'", "Prism'", "Lens'", "prism'", "lens"] + , ImportLine "Data.Lens.Record" $ Set.fromList ["prop"] + , ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"] + , ImportLine "Data.Symbol" $ Set.fromList ["SProxy(SProxy)"] + , ImportLine "Data.Newtype" $ Set.fromList ["class Newtype"] + ] + | otherwise = + [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] + , ImportLine "Data.Newtype" $ Set.fromList ["class Newtype"] + ] + +_foreignImports :: Switches.Settings -> [ImportLine] +_foreignImports settings + | (isJust . Switches.generateForeign) settings = + [ ImportLine "Foreign.Generic" $ Set.fromList ["defaultOptions", "genericDecode", "genericEncode"] + , ImportLine "Foreign.Class" $ Set.fromList ["class Decode", "class Encode"] + ] + | otherwise = [] + importLineToText :: ImportLine -> Text importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")" where @@ -99,27 +108,56 @@ sumTypeToText :: Switches.Settings -> SumType 'PureScript -> Text sumTypeToText settings st = - sumTypeToTypeDecls st <> additionalCode + sumTypeToTypeDecls settings st <> additionalCode where additionalCode = if Switches.generateLenses settings then lenses else mempty lenses = "\n" <> sep <> "\n" <> sumTypeToOptics st <> sep sep = T.replicate 80 "-" -sumTypeToTypeDecls :: SumType 'PureScript -> Text -sumTypeToTypeDecls st@(SumType t cs _) = T.unlines $ +sumTypeToTypeDecls :: Switches.Settings -> SumType 'PureScript -> Text +sumTypeToTypeDecls settings (SumType t cs is) = T.unlines $ dataOrNewtype <> " " <> typeInfoToText True t <> " =" : " " <> T.intercalate "\n | " (map (constructorToText 4) cs) <> "\n" - : instances st + : instances settings (SumType t cs (filter genForeign is)) where dataOrNewtype = if isJust (nootype cs) then "newtype" else "data" + genForeign Encode = (isJust . Switches.generateForeign) settings + genForeign Decode = (isJust . Switches.generateForeign) settings + genForeign _ = True --- | Given a Purescript type, generate `derive instance` lines for typeclass +-- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. -instances :: SumType 'PureScript -> [Text] -instances st@(SumType t _ is) = map go is +instances :: Switches.Settings -> SumType 'PureScript -> [Text] +instances settings st@(SumType t _ is) = map go is where go :: Instance -> Text + go Encode = "instance encode" <> _typeName t <> " :: " <> extras <> "Encode " <> typeInfoToText False t <> " where\n" <> + " encode = genericEncode $ defaultOptions" <> encodeOpts + where + encodeOpts = case Switches.generateForeign settings of + Nothing -> "" + Just fopts -> " { unwrapSingleConstructors = " <> (T.toLower . T.pack . show . Switches.unwrapSingleConstructors) fopts <> " }" + stpLength = length sumTypeParameters + extras | stpLength == 0 = mempty + | otherwise = bracketWrap constraintsInner <> " => " + sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st + constraintsInner = T.intercalate ", " $ map instances sumTypeParameters + instances params = genericInstance settings params <> ", " <> encodeInstance params + bracketWrap x = "(" <> x <> ")" + go Decode = "instance decode" <> _typeName t <> " :: " <> extras <> "Decode " <> typeInfoToText False t <> " where\n" <> + " decode = genericDecode $ defaultOptions" <> decodeOpts + where + decodeOpts = case Switches.generateForeign settings of + Nothing -> "" + Just fopts -> " { unwrapSingleConstructors = " <> (T.toLower . T.pack . show . Switches.unwrapSingleConstructors) fopts <> " }" + stpLength = length sumTypeParameters + extras | stpLength == 0 = mempty + | otherwise = bracketWrap constraintsInner <> " => " + sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st + constraintsInner = T.intercalate ", " $ map instances sumTypeParameters + instances params = genericInstance settings params <> ", " <> decodeInstance params + bracketWrap x = "(" <> x <> ")" go i = "derive instance " <> T.toLower c <> _typeName t <> " :: " <> extras i <> c <> " " <> typeInfoToText False t <> postfix i where c = T.pack $ show i extras Generic | stpLength == 0 = mempty @@ -127,14 +165,31 @@ | otherwise = bracketWrap genericConstraintsInner <> " => " extras _ = "" postfix Newtype = " _" + postfix Generic + | Switches.genericsGenRep settings = " _" + | otherwise = "" postfix _ = "" stpLength = length sumTypeParameters - sumTypeParameters = filter isTypeParam . Set.toList $ getUsedTypes st - isTypeParam typ = _typeName typ `elem` map _typeName (_typeParameters t) - genericConstraintsInner = T.intercalate ", " $ map genericInstance sumTypeParameters - genericInstance = ("Generic " <>) . typeInfoToText False + sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st + genericConstraintsInner = T.intercalate ", " $ map (genericInstance settings) sumTypeParameters bracketWrap x = "(" <> x <> ")" +isTypeParam :: PSType -> PSType -> Bool +isTypeParam t typ = _typeName typ `elem` map _typeName (_typeParameters t) + +encodeInstance :: PSType -> Text +encodeInstance params = "Encode " <> typeInfoToText False params + +decodeInstance :: PSType -> Text +decodeInstance params = "Decode " <> typeInfoToText False params + +genericInstance :: Switches.Settings -> PSType -> Text +genericInstance settings params = + if not (Switches.genericsGenRep settings) then + "Generic " <> typeInfoToText False params + else + "Generic " <> typeInfoToText False params <> " r" <> mergedTypeInfoToText params + sumTypeToOptics :: SumType 'PureScript -> Text sumTypeToOptics st = constructorOptics st <> recordOptics st @@ -266,6 +321,13 @@ pLength = length params needParens = not topLevel && pLength > 0 textParameters = map (typeInfoToText False) params + +mergedTypeInfoToText :: PSType -> Text +mergedTypeInfoToText t = + _typeName t <> T.concat textParameters + where + params = _typeParameters t + textParameters = map mergedTypeInfoToText params sumTypesToModules :: Modules -> [SumType 'PureScript] -> Modules sumTypesToModules = foldr sumTypeToModule 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 @@ -55,12 +55,12 @@ -- 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 p = SumType (mkTypeInfo p) constructors (Generic : maybeToList (nootype constructors)) +mkSumType p = SumType (mkTypeInfo p) constructors (Encode : Decode : Generic : maybeToList (nootype constructors)) where constructors = gToConstructors (from (undefined :: t)) -- | Purescript typeclass instances that can be generated for your Haskell types. -data Instance = Generic | Newtype | Eq | Ord deriving (Eq, Show) +data Instance = Encode | Decode | Generic | Newtype | Eq | Ord deriving (Eq, Show) -- | The Purescript typeclass `Newtype` might be derivable if the original -- Haskell type was a simple type wrapper. diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -25,8 +25,8 @@ allTests :: Spec allTests = do - describe "buildBridge" $ do - let settings = defaultSettings + describe "buildBridge for purescript 0.12" $ do + let settings = purs_0_11_settings it "tests with Int" $ let bst = buildBridge defaultBridge (mkTypeInfo (Proxy :: Proxy Int)) ti = TypeInfo { _typePackage = "" @@ -51,7 +51,7 @@ ] } ] - [Eq, Ord, Generic] + [Eq, Ord, Encode, Decode, Generic] in bst `shouldBe` st it "tests generation of for custom type Foo" $ let prox = Proxy :: Proxy Foo @@ -97,6 +97,7 @@ , "module TestData where" , "" , "import Data.Either (Either)" + , "import Data.Generic (class Generic)" , "import Data.Lens (Iso', Lens', Prism', lens, prism')" , "import Data.Lens.Iso.Newtype (_Newtype)" , "import Data.Lens.Record (prop)" @@ -105,7 +106,6 @@ , "import Data.Symbol (SProxy(SProxy))" , "" , "import Prelude" - , "import Data.Generic (class Generic)" , "" , "data Bar a b m c =" , " Bar1 (Maybe a)" @@ -291,8 +291,8 @@ recTypeOptics = recordOptics recType in recTypeOptics `shouldBe` "" -- No record optics for multi-constructors - describe "buildBridge without lens-code-gen" $ do - let settings = getSettings noLenses + describe "buildBridge without lens-code-gen for purescript 0.11" $ do + let settings = getSettings (noLenses <> useGen) it "tests generation of for custom type Foo" $ let proxy = Proxy :: Proxy Foo recType = bridgeSumType (buildBridge defaultBridge) (order proxy $ mkSumType proxy) @@ -315,11 +315,11 @@ , "module TestData where" , "" , "import Data.Either (Either)" + , "import Data.Generic (class Generic)" , "import Data.Maybe (Maybe, Maybe(..))" , "import Data.Newtype (class Newtype)" , "" , "import Prelude" - , "import Data.Generic (class Generic)" , "" , "data Bar a b m c =" , " Bar1 (Maybe a)" @@ -374,6 +374,93 @@ , " SingleProduct String Int" , "" , "derive instance genericSingleProduct :: Generic SingleProduct" + ] + in recTypeText `shouldBe` txt + + + describe "buildBridge without lens-code-gen and generics-rep" $ do + let settings = getSettings (noLenses <> useGenRep) + it "tests generation of for custom type Foo" $ + let proxy = Proxy :: Proxy Foo + recType = bridgeSumType (buildBridge defaultBridge) (order proxy $ mkSumType proxy) + recTypeText = sumTypeToText settings recType + txt = T.unlines [ "data Foo =" + , " Foo" + , " | Bar Int" + , " | FooBar Int String" + , "" + , "derive instance eqFoo :: Eq Foo" + , "derive instance ordFoo :: Ord Foo" + , "derive instance genericFoo :: Generic Foo _" + ] + in recTypeText `shouldBe` txt + it "tests the generation of a whole (dummy) module" $ + let advanced' = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C))) + modules = sumTypeToModule advanced' Map.empty + m = head . map (moduleToText settings) . Map.elems $ modules + txt = T.unlines [ "-- File auto generated by purescript-bridge! --" + , "module TestData where" + , "" + , "import Data.Either (Either)" + , "import Data.Generic.Rep (class Generic)" + , "import Data.Maybe (Maybe, Maybe(..))" + , "import Data.Newtype (class Newtype)" + , "" + , "import Prelude" + , "" + , "data Bar a b m c =" + , " Bar1 (Maybe a)" + , " | Bar2 (Either a b)" + , " | Bar3 a" + , " | Bar4 {" + , " myMonadicResult :: m b" + , " }" + , "" + , "derive instance genericBar :: (Generic a ra, Generic b rb, Generic (m b) rmb) => Generic (Bar a b m c) _" + , "" + ] + in m `shouldBe` txt + it "tests generation of newtypes for record data type" $ + let recType' = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (SingleRecord A B))) + recTypeText = sumTypeToText settings recType' + txt = T.unlines [ "newtype SingleRecord a b =" + , " SingleRecord {" + , " _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "derive instance genericSingleRecord :: (Generic a ra, Generic b rb) => Generic (SingleRecord a b) _" + , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + ] + in recTypeText `shouldBe` txt + it "tests generation of newtypes for haskell newtype" $ + let recType' = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy SomeNewtype)) + recTypeText = sumTypeToText settings recType' + txt = T.unlines [ "newtype SomeNewtype =" + , " SomeNewtype Int" + , "" + , "derive instance genericSomeNewtype :: Generic SomeNewtype _" + , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" + ] + in recTypeText `shouldBe` txt + it "tests generation of newtypes for haskell data type with one argument" $ + let recType' = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy SingleValueConstr)) + recTypeText = sumTypeToText settings recType' + txt = T.unlines [ "newtype SingleValueConstr =" + , " SingleValueConstr Int" + , "" + , "derive instance genericSingleValueConstr :: Generic SingleValueConstr _" + , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" + ] + in recTypeText `shouldBe` txt + it "tests generation for haskell data type with one constructor, two arguments" $ + let recType' = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy SingleProduct)) + recTypeText = sumTypeToText settings recType' + txt = T.unlines [ "data SingleProduct =" + , " SingleProduct String Int" + , "" + , "derive instance genericSingleProduct :: Generic SingleProduct _" ] in recTypeText `shouldBe` txt