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.8.0.1 +version: 0.9.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.hs b/src/Language/PureScript/Bridge.hs --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -11,6 +11,7 @@ import Control.Applicative import qualified Data.Map as M +import qualified Data.Set as Set import qualified Data.Text.IO as T @@ -73,7 +74,7 @@ let modules = M.elems $ sumTypesToModules M.empty bridged mapM_ (printModule root) modules T.putStrLn "The following purescript packages are needed by the generated code:\n" - let packages = sumTypesToNeededPackages bridged + let packages = Set.insert "purescript-profunctor-lenses" $ sumTypesToNeededPackages bridged mapM_ (T.putStrLn . mappend " - ") packages T.putStrLn "\nSuccessfully created your PureScript modules!" 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 @@ -4,6 +4,7 @@ module Language.PureScript.Bridge.Printer where +import Control.Lens import Control.Monad import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -57,10 +58,23 @@ moduleToText m = T.unlines $ "-- File auto generated by purescript-bridge! --" : "module " <> psModuleName m <> " where\n" - : map importLineToText (Map.elems (psImportLines m)) - ++ [ "\nimport Data.Generic (class Generic)\n\n" ] + : map importLineToText allImports + ++ [ "" + , "import Prelude" + , "import Data.Generic (class Generic)" + , "" + ] ++ map sumTypeToText (psTypes m) + where + otherImports = importsFromList _lensImports + allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) +_lensImports :: [ImportLine] +_lensImports = [ + ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] + -- , ImportLine "Prelude" mempty + , ImportLine "Data.Lens" $ Set.fromList ["PrismP", "LensP", "prism'", "lens"] + ] importLineToText :: ImportLine -> Text importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")" @@ -68,11 +82,13 @@ typeList = T.intercalate ", " (Set.toList (importTypes l)) sumTypeToText :: SumType 'PureScript -> Text -sumTypeToText st@(SumType t cs) = T.unlines $ +sumTypeToText st@(SumType t cs) = (T.unlines $ "data " <> typeInfoToText True t <> " =" : " " <> T.intercalate "\n | " (map (constructorToText 4) cs) - : [ "\nderive instance generic" <> _typeName t <> " :: " <> genericConstrains <> genericInstance t ] + : [ "\nderive instance generic" <> _typeName t <> " :: " <> genericConstrains <> genericInstance t ]) + <> "\n" <> sep <> "\n" <> sumTypeToPrismsAndLenses st <> sep where + sep = T.replicate 80 "-" genericInstance = ("Generic " <>) . typeInfoToText False genericConstrains | stpLength == 0 = mempty @@ -86,7 +102,27 @@ sumTypeParameters = filter isTypeParam . Set.toList $ getUsedTypes st isTypeParam typ = _typeName typ `elem` map _typeName (_typeParameters t) +sumTypeToPrismsAndLenses :: SumType 'PureScript -> Text +sumTypeToPrismsAndLenses st = sumTypeToPrisms st <> sumTypeToLenses st +sumTypeToPrisms :: SumType 'PureScript -> Text +sumTypeToPrisms st = T.unlines $ map (constructorToPrism moreThan1 st) cs + where + cs = st ^. sumTypeConstructors + moreThan1 = length cs > 1 + + +sumTypeToLenses :: SumType 'PureScript -> Text +sumTypeToLenses st = T.unlines $ recordEntryToLens st <$> dcName <*> 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 + constructorToText :: Int -> DataConstructor 'PureScript -> Text constructorToText _ (DataConstructor n (Left ts)) = n <> " " <> T.intercalate " " (map (typeInfoToText False) ts) constructorToText indentation (DataConstructor n (Right rs)) = @@ -95,10 +131,84 @@ <> spaces indentation <> "}" where intercalation = "\n" <> spaces indentation <> "," <> " " - spaces c = T.replicate c " " +spaces :: Int -> Text +spaces c = T.replicate c " " + + +typeNameAndForall :: SumType 'PureScript -> (Text, Text) +typeNameAndForall st = (typName, forAll) + where + typName = typeInfoToText False (st ^. sumTypeInfo) + forAllParams = st ^.. sumTypeInfo.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 <> " }" + where + inners = T.intercalate ", " $ map mkElem rs + +mkFnArgs :: [RecordEntry 'PureScript] -> Text +mkFnArgs [r] = r ^. recLabel +mkFnArgs rs = fromEntries (\recE -> recE ^. recLabel <> ": " <> recE ^. recLabel) rs + +mkTypeSig :: [RecordEntry 'PureScript] -> Text +mkTypeSig [] = "Unit" +mkTypeSig [r] = typeInfoToText False $ r ^. recValue +mkTypeSig rs = fromEntries recordEntryToText rs + +constructorToPrism :: Bool -> SumType 'PureScript -> DataConstructor 'PureScript -> Text +constructorToPrism otherConstructors st (DataConstructor n args) = + case args of + Left cs -> pName <> forAll <> "PrismP " <> typName <> " " <> mkTypeSig types <> "\n" + <> pName <> " = prism' " <> getter <> " f\n" + <> spaces 2 <> "where\n" + <> spaces 4 <> "f " <> mkF cs + <> otherConstructorFallThrough + where + mkF [] = n <> " = Just unit\n" + mkF _ = "(" <> n <> " " <> T.unwords (map _recLabel types) <> ") = Just $ " <> mkFnArgs types <> "\n" + getter | 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 <> "PrismP " <> typName <> " { " <> recordSig <> "}\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) + where + (typName, forAll) = typeNameAndForall st + pName = "_" <> n + otherConstructorFallThrough | otherConstructors = spaces 4 <> "f _ = Nothing\n" + | otherwise = "\n" + +recordEntryToLens :: SumType 'PureScript -> Text -> RecordEntry 'PureScript -> Text +recordEntryToLens st constructorName e = + case hasUnderscore of + False -> "" + True -> + lensName <> forAll <> "LensP " <> typName <> " " <> recType <> "\n" + <> lensName <> " = lens get set\n where\n" + <> spaces 4 <> "get (" <> constructorName <> " r) = r." <> recName <> "\n" + <> spaces 4 <> "set (" <> constructorName <> " r) = " <> setter + where + (typName, forAll) = typeNameAndForall st + setter = constructorName <> " <<< r { " <> recName <> " = _ }\n" + recName = e ^. recLabel + lensName = T.drop 1 recName + recType = typeInfoToText False (e ^. recValue) + hasUnderscore = e ^. recLabel.to (T.isPrefixOf "_") + recordEntryToText :: RecordEntry 'PureScript -> Text -recordEntryToText e = _recLabel e <> " :: " <> typeInfoToText True (_recValue e) +recordEntryToText e = _recLabel e <> " :: " <> typeInfoToText True (e ^. recValue) typeInfoToText :: Bool -> PSType -> Text diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,6 +10,7 @@ import Control.Monad (unless) import qualified Data.Map as Map +import Data.Monoid ((<>)) import Data.Proxy import qualified Data.Text as T import Language.PureScript.Bridge @@ -61,11 +62,12 @@ , "module TestData where" , "" , "import Data.Either (Either)" - , "import Data.Maybe (Maybe)" + , "import Data.Lens (LensP, PrismP, lens, prism')" + , "import Data.Maybe (Maybe, Maybe(..))" , "" + , "import Prelude" , "import Data.Generic (class Generic)" , "" - , "" , "data Bar a b m c =" , " Bar1 (Maybe a)" , " | Bar2 (Either a b)" @@ -76,6 +78,102 @@ , "" , "derive instance genericBar :: (Generic a, Generic b, Generic (m b)) => Generic (Bar a b m c)" , "" + , "--------------------------------------------------------------------------------" + , "_Bar1 :: forall a b m c. PrismP (Bar a b m c) (Maybe a)" + , "_Bar1 = prism' Bar1 f" + , " where" + , " f (Bar1 a) = Just $ a" + , " f _ = Nothing" + , "" + , "_Bar2 :: forall a b m c. PrismP (Bar a b m c) (Either a b)" + , "_Bar2 = prism' Bar2 f" + , " where" + , " f (Bar2 a) = Just $ a" + , " f _ = Nothing" + , "" + , "_Bar3 :: forall a b m c. PrismP (Bar a b m c) a" + , "_Bar3 = prism' Bar3 f" + , " where" + , " f (Bar3 a) = Just $ a" + , " f _ = Nothing" + , "" + , "_Bar4 :: forall a b m c. PrismP (Bar a b m c) { myMonadicResult :: m b}" + , "_Bar4 = prism' Bar4 f" + , " where" + , " f (Bar4 r) = Just r" + , " f _ = Nothing" + , "" + , "--------------------------------------------------------------------------------" ] in m `shouldBe` txt + it "test generation of Prisms" $ + 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 + txt = T.unlines [ + "_Bar1 :: forall a b m c. PrismP (Bar a b m c) (Maybe a)" + , "_Bar1 = prism' Bar1 f" + , " where" + , " f (Bar1 a) = Just $ a" + , " f _ = Nothing" + , "" + , "_Bar2 :: forall a b m c. PrismP (Bar a b m c) (Either a b)" + , "_Bar2 = prism' Bar2 f" + , " where" + , " f (Bar2 a) = Just $ a" + , " f _ = Nothing" + , "" + , "_Bar3 :: forall a b m c. PrismP (Bar a b m c) a" + , "_Bar3 = prism' Bar3 f" + , " where" + , " f (Bar3 a) = Just $ a" + , " f _ = Nothing" + , "" + , "_Bar4 :: forall a b m c. PrismP (Bar a b m c) { myMonadicResult :: m b}" + , "_Bar4 = prism' Bar4 f" + , " where" + , " f (Bar4 r) = Just r" + , " f _ = Nothing" + , "" + , "_Foo :: PrismP Foo Unit" + , "_Foo = prism' (\\_ -> Foo) f" + , " where" + , " f Foo = Just unit" + , " f _ = Nothing" + , "" + , "_Bar :: PrismP Foo Int" + , "_Bar = prism' Bar f" + , " where" + , " f (Bar a) = Just $ a" + , " f _ = Nothing" + , "" + , "_FooBar :: PrismP 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 (barPrisms <> fooPrisms) `shouldBe` txt + it "tests generation of lenses" $ + 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 + txt = T.unlines [ + "a :: forall a b. LensP (SingleRecord a b) a" + , "a = lens get set" + , " where" + , " get (SingleRecord r) = r._a" + , " set (SingleRecord r) = SingleRecord <<< r { _a = _ }" + , "" + , "b :: forall a b. LensP (SingleRecord a b) b" + , "b = lens get set" + , " where" + , " get (SingleRecord r) = r._b" + , " set (SingleRecord r) = SingleRecord <<< r { _b = _ }" + , "" + ] + in (barLenses <> recTypeLenses) `shouldBe` txt diff --git a/test/TestData.hs b/test/TestData.hs --- a/test/TestData.hs +++ b/test/TestData.hs @@ -44,6 +44,11 @@ | Bar4 { myMonadicResult :: m b } deriving (Generic, Typeable, Show) +data SingleRecord a b = SingleRecord { + _a :: a + , _b :: b + , c :: String + } deriving(Generic, Typeable, Show) a :: HaskellType a = mkTypeInfo (Proxy :: Proxy (Either String Int))