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.11.0.0 +version: 0.11.1.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/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -72,8 +72,11 @@ _lensImports :: [ImportLine] _lensImports = [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] - -- , ImportLine "Prelude" mempty - , ImportLine "Data.Lens" $ Set.fromList ["Prism'", "Lens'", "prism'", "lens"] + , 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"] ] importLineToText :: ImportLine -> Text @@ -87,57 +90,65 @@ <> "\n" <> sep <> "\n" - <> sumTypeToPrismsAndLenses st + <> sumTypeToOptics st <> sep where sep = T.replicate 80 "-" sumTypeToTypeDecls :: SumType 'PureScript -> Text sumTypeToTypeDecls st@(SumType t cs) = T.unlines $ - dataOrNewtype cs <> " " <> typeInfoToText True t <> " =" - : " " <> T.intercalate "\n | " (map (constructorToText 4) cs) - : [ "\nderive instance generic" <> _typeName t <> " :: " <> genericConstrains <> genericInstance t ] + dataOrNewtype <> " " <> typeInfoToText True t <> " =" + : " " <> T.intercalate "\n | " (map (constructorToText 4) cs) <> "\n" + : "derive instance generic" <> _typeName t <> " :: " <> genericConstraints <> genericInstance t <> "\n" + : [ "derive instance newtype" <> _typeName t <> " :: " <> newtypeInstance t <> " _\n" | isNewtype cs] where genericInstance = ("Generic " <>) . typeInfoToText False - genericConstrains + newtypeInstance = ("Newtype " <>) . typeInfoToText False + genericConstraints | stpLength == 0 = mempty | otherwise = (<> " => ") $ if stpLength == 1 - then genericConstrainsInner - else bracketWrap genericConstrainsInner - genericConstrainsInner = T.intercalate ", " $ map genericInstance sumTypeParameters + then genericConstraintsInner + else bracketWrap genericConstraintsInner + genericConstraintsInner = T.intercalate ", " $ map genericInstance sumTypeParameters stpLength = length sumTypeParameters bracketWrap x = "(" <> x <> ")" sumTypeParameters = filter isTypeParam . Set.toList $ getUsedTypes st isTypeParam typ = _typeName typ `elem` map _typeName (_typeParameters t) - dataOrNewtype [constr] - | either isSingletonList (const True) (_sigValues constr) = "newtype" - dataOrNewtype _ = "data" + isNewtype [constr] + | either isSingletonList (const True) (_sigValues constr) = True + isNewtype _ = False + dataOrNewtype = if isNewtype cs then "newtype" else "data" isSingletonList [_] = True - isSingletonList _ = False + isSingletonList _ = False -sumTypeToPrismsAndLenses :: SumType 'PureScript -> Text -sumTypeToPrismsAndLenses st = sumTypeToPrisms st <> sumTypeToLenses st +sumTypeToOptics :: SumType 'PureScript -> Text +sumTypeToOptics st = constructorOptics st <> recordOptics st -sumTypeToPrisms :: SumType 'PureScript -> Text -sumTypeToPrisms st = T.unlines $ map (constructorToPrism moreThan1 st) cs +constructorOptics :: SumType 'PureScript -> Text +constructorOptics st = + case st ^. sumTypeConstructors of + [] -> mempty -- No work required. + [c] -> constructorToOptic False typeInfo c + cs -> T.unlines $ map (constructorToOptic True typeInfo) cs where - cs = st ^. sumTypeConstructors - moreThan1 = length cs > 1 + typeInfo = st ^. sumTypeInfo -sumTypeToLenses :: SumType 'PureScript -> Text -sumTypeToLenses st = T.unlines $ recordEntryToLens st <$> dcName <*> dcRecords +recordOptics :: SumType 'PureScript -> Text +-- Match on SumTypes with a single DataConstructor (that's a list of a single element) +recordOptics st@(SumType _ [_]) = T.unlines $ recordEntryToLens st <$> dcRecords where cs = st ^. sumTypeConstructors - dcName = lensableConstructor ^.. traversed.sigConstructor dcRecords = lensableConstructor ^.. traversed.sigValues._Right.traverse.filtered hasUnderscore hasUnderscore e = e ^. recLabel.to (T.isPrefixOf "_") lensableConstructor = filter singleRecordCons cs ^? _head singleRecordCons (DataConstructor _ (Right _)) = True singleRecordCons _ = False +recordOptics _ = "" constructorToText :: Int -> DataConstructor 'PureScript -> Text +constructorToText _ (DataConstructor n (Left [])) = n constructorToText _ (DataConstructor n (Left ts)) = n <> " " <> T.intercalate " " (map (typeInfoToText False) ts) constructorToText indentation (DataConstructor n (Right rs)) = n <> " {\n" @@ -150,15 +161,14 @@ spaces c = T.replicate c " " -typeNameAndForall :: SumType 'PureScript -> (Text, Text) -typeNameAndForall st = (typName, forAll) +typeNameAndForall :: TypeInfo 'PureScript -> (Text, Text) +typeNameAndForall typeInfo = (typName, forAll) where - typName = typeInfoToText False (st ^. sumTypeInfo) - forAllParams = st ^.. sumTypeInfo.typeParameters.traversed.to (typeInfoToText False) + typName = typeInfoToText False typeInfo + forAllParams = typeInfo ^.. typeParameters.traversed.to (typeInfoToText False) forAll = case forAllParams of [] -> " :: " cs -> " :: forall " <> T.intercalate " " cs <> ". " - -- textParameters = map (typeInfoToText False) params fromEntries :: (RecordEntry a -> Text) -> [RecordEntry a] -> Text fromEntries mkElem rs = "{ " <> inners <> " }" @@ -170,52 +180,63 @@ mkFnArgs rs = fromEntries (\recE -> recE ^. recLabel <> ": " <> recE ^. recLabel) rs mkTypeSig :: [RecordEntry 'PureScript] -> Text -mkTypeSig [] = "Unit" +mkTypeSig [] = "Unit" mkTypeSig [r] = typeInfoToText False $ r ^. recValue -mkTypeSig rs = fromEntries recordEntryToText rs +mkTypeSig rs = fromEntries recordEntryToText rs -constructorToPrism :: Bool -> SumType 'PureScript -> DataConstructor 'PureScript -> Text -constructorToPrism otherConstructors st (DataConstructor n args) = +constructorToOptic :: Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Text +constructorToOptic otherConstructors typeInfo (DataConstructor n args) = case args of - Left cs -> pName <> forAll <> "Prism' " <> typName <> " " <> mkTypeSig types <> "\n" + Left cs -> + if otherConstructors + then + pName <> forAll <> "Prism' " <> typName <> " " <> mkTypeSig types <> "\n" <> pName <> " = prism' " <> getter <> " f\n" <> spaces 2 <> "where\n" <> spaces 4 <> "f " <> mkF cs <> otherConstructorFallThrough + <> "\n" + else pName <> forAll <> "Iso' " <> typName <> " " <> mkTypeSig (constructorTypes cs) <> "\n" + <> pName <> " = _Newtype" + <> "\n" where mkF [] = n <> " = Just unit\n" mkF _ = "(" <> n <> " " <> T.unwords (map _recLabel types) <> ") = Just $ " <> mkFnArgs types <> "\n" - getter | cs == [] = "(\\_ -> " <> n <> ")" + getter | null cs = "(\\_ -> " <> n <> ")" | length cs == 1 = n | otherwise = "(\\{ " <> T.intercalate ", " cArgs <> " } -> " <> n <> " " <> T.intercalate " " cArgs <> ")" where cArgs = map (T.singleton . fst) $ zip ['a'..] cs - types = [RecordEntry (T.singleton label) t | (label, t) <- zip ['a'..] cs] - Right rs -> pName <> forAll <> "Prism' " <> typName <> " { " <> recordSig <> "}\n" + types = constructorTypes cs + Right rs -> + if otherConstructors + then + pName <> forAll <> "Prism' " <> typName <> " { " <> recordSig rs <> " }\n" <> pName <> " = prism' " <> n <> " f\n" <> spaces 2 <> "where\n" <> spaces 4 <> "f (" <> n <> " r) = Just r\n" <> otherConstructorFallThrough - where - recordSig = T.intercalate ", " (map recordEntryToText rs) + <> "\n" + else + pName <> forAll <> "Iso' " <> typName <> " { " <> recordSig rs <> "}\n" + <> pName <> " = _Newtype\n" + <> "\n" where - (typName, forAll) = typeNameAndForall st + recordSig rs = T.intercalate ", " (map recordEntryToText rs) + constructorTypes cs = [RecordEntry (T.singleton label) t | (label, t) <- zip ['a'..] cs] + (typName, forAll) = typeNameAndForall typeInfo pName = "_" <> n - otherConstructorFallThrough | otherConstructors = spaces 4 <> "f _ = Nothing\n" - | otherwise = "\n" + otherConstructorFallThrough | otherConstructors = spaces 4 <> "f _ = Nothing" + | otherwise = "" -recordEntryToLens :: SumType 'PureScript -> Text -> RecordEntry 'PureScript -> Text -recordEntryToLens st constructorName e = - case hasUnderscore of - False -> "" - True -> - lensName <> forAll <> "Lens' " <> typName <> " " <> recType <> "\n" - <> lensName <> " = lens get set\n where\n" - <> spaces 4 <> "get (" <> constructorName <> " r) = r." <> recName <> "\n" - <> spaces 4 <> "set (" <> constructorName <> " r) = " <> setter +recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Text +recordEntryToLens st e = + if hasUnderscore + then lensName <> forAll <> "Lens' " <> typName <> " " <> recType <> "\n" + <> lensName <> " = _Newtype <<< prop (SProxy :: SProxy \"" <> recName <> "\")\n" + else "" where - (typName, forAll) = typeNameAndForall st - setter = constructorName <> " <<< r { " <> recName <> " = _ }\n" + (typName, forAll) = typeNameAndForall (st ^. sumTypeInfo) recName = e ^. recLabel lensName = T.drop 1 recName recType = typeInfoToText False (e ^. recValue) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,8 +7,6 @@ {-# LANGUAGE TypeSynonymInstances #-} module Main where - -import Control.Monad (unless) import qualified Data.Map as Map import Data.Monoid ((<>)) import Data.Proxy @@ -18,13 +16,10 @@ import Test.Hspec (Spec, describe, hspec, it) import Test.Hspec.Expectations.Pretty - import TestData - - main :: IO () -main = hspec $ do allTests +main = hspec $ allTests allTests :: Spec @@ -54,6 +49,40 @@ } ] in bst `shouldBe` st + it "tests generation of for custom type Foo" $ + let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo)) + recTypeText = sumTypeToText recType + txt = T.stripEnd $ + T.unlines [ "data Foo =" + , " Foo" + , " | Bar Int" + , " | FooBar Int String" + , "" + , "derive instance genericFoo :: Generic Foo" + , "" + , "" + , "--------------------------------------------------------------------------------" + , "_Foo :: Prism' Foo Unit" + , "_Foo = prism' (\\_ -> Foo) f" + , " where" + , " f Foo = Just unit" + , " f _ = Nothing" + , "" + , "_Bar :: Prism' Foo Int" + , "_Bar = prism' Bar f" + , " where" + , " f (Bar a) = Just $ a" + , " f _ = Nothing" + , "" + , "_FooBar :: Prism' Foo { a :: Int, b :: String }" + , "_FooBar = prism' (\\{ a, b } -> FooBar a b) f" + , " where" + , " f (FooBar a b) = Just $ { a: a, b: b }" + , " f _ = Nothing" + , "" + , "--------------------------------------------------------------------------------" + ] + 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 @@ -62,8 +91,12 @@ , "module TestData where" , "" , "import Data.Either (Either)" - , "import Data.Lens (Lens', Prism', lens, prism')" + , "import Data.Lens (Iso', Lens', Prism', lens, prism')" + , "import Data.Lens.Iso.Newtype (_Newtype)" + , "import Data.Lens.Record (prop)" , "import Data.Maybe (Maybe, Maybe(..))" + , "import Data.Newtype (class Newtype)" + , "import Data.Symbol (SProxy(SProxy))" , "" , "import Prelude" , "import Data.Generic (class Generic)" @@ -78,6 +111,7 @@ , "" , "derive instance genericBar :: (Generic a, Generic b, Generic (m b)) => Generic (Bar a b m c)" , "" + , "" , "--------------------------------------------------------------------------------" , "_Bar1 :: forall a b m c. Prism' (Bar a b m c) (Maybe a)" , "_Bar1 = prism' Bar1 f" @@ -97,7 +131,7 @@ , " f (Bar3 a) = Just $ a" , " f _ = Nothing" , "" - , "_Bar4 :: forall a b m c. Prism' (Bar a b m c) { myMonadicResult :: m b}" + , "_Bar4 :: forall a b m c. Prism' (Bar a b m c) { myMonadicResult :: m b }" , "_Bar4 = prism' Bar4 f" , " where" , " f (Bar4 r) = Just r" @@ -106,11 +140,11 @@ , "--------------------------------------------------------------------------------" ] in m `shouldBe` txt - it "test generation of Prisms" $ + it "test generation of constructor optics" $ let bar = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C))) foo = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo)) - barPrisms = sumTypeToPrisms bar - fooPrisms = sumTypeToPrisms foo + barOptics = constructorOptics bar + fooOptics = constructorOptics foo txt = T.unlines [ "_Bar1 :: forall a b m c. Prism' (Bar a b m c) (Maybe a)" , "_Bar1 = prism' Bar1 f" @@ -130,7 +164,7 @@ , " f (Bar3 a) = Just $ a" , " f _ = Nothing" , "" - , "_Bar4 :: forall a b m c. Prism' (Bar a b m c) { myMonadicResult :: m b}" + , "_Bar4 :: forall a b m c. Prism' (Bar a b m c) { myMonadicResult :: m b }" , "_Bar4 = prism' Bar4 f" , " where" , " f (Bar4 r) = Just r" @@ -155,31 +189,26 @@ , " f _ = Nothing" , "" ] - in (barPrisms <> fooPrisms) `shouldBe` txt - it "tests generation of lenses" $ + in (barOptics <> fooOptics) `shouldBe` txt + it "tests generation of record optics" $ let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (SingleRecord A B))) bar = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C))) - barLenses = sumTypeToLenses bar - recTypeLenses = sumTypeToLenses recType + barOptics = recordOptics bar + recTypeOptics = recordOptics recType txt = T.unlines [ "a :: forall a b. Lens' (SingleRecord a b) a" - , "a = lens get set" - , " where" - , " get (SingleRecord r) = r._a" - , " set (SingleRecord r) = SingleRecord <<< r { _a = _ }" + , "a = _Newtype <<< prop (SProxy :: SProxy \"_a\")" , "" , "b :: forall a b. Lens' (SingleRecord a b) b" - , "b = lens get set" - , " where" - , " get (SingleRecord r) = r._b" - , " set (SingleRecord r) = SingleRecord <<< r { _b = _ }" + , "b = _Newtype <<< prop (SProxy :: SProxy \"_b\")" , "" ] - in (barLenses <> recTypeLenses) `shouldBe` txt + in (barOptics <> recTypeOptics) `shouldBe` txt it "tests generation of newtypes for record data type" $ let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (SingleRecord A B))) - recTypeText = sumTypeToTypeDecls recType - txt = T.unlines [ "newtype SingleRecord a b =" + recTypeText = sumTypeToText recType + txt = T.stripEnd $ + T.unlines [ "newtype SingleRecord a b =" , " SingleRecord {" , " _a :: a" , " , _b :: b" @@ -187,23 +216,60 @@ , " }" , "" , "derive instance genericSingleRecord :: (Generic a, Generic b) => Generic (SingleRecord a b)" + , "" + , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + , "" + , "" + , "--------------------------------------------------------------------------------" + , "_SingleRecord :: forall a b. Iso' (SingleRecord a b) { _a :: a, _b :: b, c :: String}" + , "_SingleRecord = _Newtype" + ,"" + , "a :: forall a b. Lens' (SingleRecord a b) a" + , "a = _Newtype <<< prop (SProxy :: SProxy \"_a\")" + , "" + , "b :: forall a b. Lens' (SingleRecord a b) b" + , "b = _Newtype <<< prop (SProxy :: SProxy \"_b\")" + , "" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldBe` txt it "tests generation of newtypes for haskell newtype" $ let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy SomeNewtype)) - recTypeText = sumTypeToTypeDecls recType - txt = T.unlines [ "newtype SomeNewtype =" + recTypeText = sumTypeToText recType + txt = T.stripEnd $ + T.unlines [ "newtype SomeNewtype =" , " SomeNewtype Int" , "" , "derive instance genericSomeNewtype :: Generic SomeNewtype" + , "" + , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" + , "" + , "" + , "--------------------------------------------------------------------------------" + , "_SomeNewtype :: Iso' SomeNewtype Int" + , "_SomeNewtype = _Newtype" + , "--------------------------------------------------------------------------------" ] 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 = sumTypeToTypeDecls recType - txt = T.unlines [ "newtype SingleValueConstr =" + recTypeText = sumTypeToText recType + txt = T.stripEnd $ + T.unlines [ "newtype SingleValueConstr =" , " SingleValueConstr Int" , "" , "derive instance genericSingleValueConstr :: Generic SingleValueConstr" + , "" + , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" + , "" + , "" + , "--------------------------------------------------------------------------------" + , "_SingleValueConstr :: Iso' SingleValueConstr Int" + , "_SingleValueConstr = _Newtype" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldBe` txt + it "tests that sum types with multiple constructors don't generate record optics" $ + let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy TwoRecords)) + recTypeOptics = recordOptics recType + in recTypeOptics `shouldBe` "" -- No record optics for multi-constructors diff --git a/test/TestData.hs b/test/TestData.hs --- a/test/TestData.hs +++ b/test/TestData.hs @@ -50,6 +50,16 @@ , c :: String } deriving(Generic, Typeable, Show) +data TwoRecords + = FirstRecord { + _fra :: String + , _frb :: Int + } + | SecondRecord { + _src :: Int + , _srd :: [Int] + } deriving(Generic, Typeable, Show) + newtype SomeNewtype = SomeNewtype Int deriving (Generic, Typeable, Show)