purescript-bridge 0.11.0.0 → 0.11.1.0

raw patch · 4 files changed

+181/−84 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• purescript-bridge.cabal +1/−1
• src/Language/PureScript/Bridge/Printer.hs +73/−52
• test/Spec.hs +97/−31
• test/TestData.hs +10/−0

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

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

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

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