purescript-bridge 0.8.0.1 → 0.9.0.0
raw patch · 5 files changed
+224/−10 lines, 5 files
Files
- purescript-bridge.cabal +1/−1
- src/Language/PureScript/Bridge.hs +2/−1
- src/Language/PureScript/Bridge/Printer.hs +116/−6
- test/Spec.hs +100/−2
- test/TestData.hs +5/−0
purescript-bridge.cabal view
@@ -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
src/Language/PureScript/Bridge.hs view
@@ -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!"
src/Language/PureScript/Bridge/Printer.hs view
@@ -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
test/Spec.hs view
@@ -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
test/TestData.hs view
@@ -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))