From 81ad9e8639026b7fd7796ac85e113769dc502ace Mon Sep 17 00:00:00 2001 From: David Smith Date: Wed, 8 May 2019 16:17:42 +0100 Subject: [PATCH 001/111] add optional Foreign encoding and decoding --- src/Language/PureScript/Bridge/Builder.hs | 1 - .../PureScript/Bridge/CodeGenSwitches.hs | 19 ++++- src/Language/PureScript/Bridge/PSTypes.hs | 1 - src/Language/PureScript/Bridge/Printer.hs | 77 +++++++++++++++---- src/Language/PureScript/Bridge/SumType.hs | 4 +- stack-8.0.yaml | 2 +- 6 files changed, 80 insertions(+), 24 deletions(-) diff --git a/src/Language/PureScript/Bridge/Builder.hs b/src/Language/PureScript/Bridge/Builder.hs index 79ba4c4a..c6bfee34 100644 --- a/src/Language/PureScript/Bridge/Builder.hs +++ b/src/Language/PureScript/Bridge/Builder.hs @@ -43,7 +43,6 @@ import Control.Monad.Reader.Class 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 index b3654c18..5125a024 100644 --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ b/src/Language/PureScript/Bridge/CodeGenSwitches.hs @@ -1,6 +1,7 @@ -- | 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 @@ -8,6 +9,7 @@ module Language.PureScript.Bridge.CodeGenSwitches , defaultSwitch , noLenses, genLenses , useGen, useGenRep + , genForeign, noForeign ) where @@ -17,18 +19,23 @@ import Data.Monoid (Endo(..)) 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 True +defaultSettings = Settings True True Nothing -- |settings for purescript 0.11.x purs_0_11_settings :: Settings -purs_0_11_settings = Settings True False +purs_0_11_settings = Settings True False Nothing -- | you can `mappend` switches to control the code generation @@ -62,4 +69,10 @@ useGenRep = Endo $ \settings -> settings { genericsGenRep = True } -- | Generate generics using purescript-generics useGen :: Switch -useGen = Endo $ \settings -> settings { genericsGenRep = False } \ No newline at end of file +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 } \ No newline at end of file diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs index fe76093e..d8b39fa0 100644 --- 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 index b7f7be88..4a63be17 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -8,7 +8,6 @@ import Control.Lens 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,13 +60,13 @@ moduleToText settings m = T.unlines $ "-- File auto generated by purescript-bridge! --" : "module " <> psModuleName m <> " where\n" : map importLineToText allImports - ++ [ "" - , "import Prelude" + <> [ "" + , "import Prelude" -- TODO: need a switch for Foreign.Generic to see if we should import or not and then implementation of the instances , "" ] - ++ map (sumTypeToText settings) (psTypes m) + <> map (sumTypeToText settings) (psTypes m) where - otherImports = importsFromList (_lensImports settings ++ _genericsImports settings) + otherImports = importsFromList (_lensImports settings <> _genericsImports settings <> _foreignImports settings) allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) @@ -94,6 +93,13 @@ _lensImports settings , 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 <> ")" @@ -110,19 +116,48 @@ sumTypeToText settings st = sep = T.replicate 80 "-" sumTypeToTypeDecls :: Switches.Settings -> SumType 'PureScript -> Text -sumTypeToTypeDecls settings st@(SumType t cs _) = T.unlines $ +sumTypeToTypeDecls settings (SumType t cs is) = T.unlines $ dataOrNewtype <> " " <> typeInfoToText True t <> " =" : " " <> T.intercalate "\n | " (map (constructorToText 4) cs) <> "\n" - : instances settings 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 :: 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 @@ -135,16 +170,26 @@ instances settings st@(SumType t _ is) = map go is | 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 params = - if not (Switches.genericsGenRep settings) then - "Generic " <> typeInfoToText False params - else - "Generic " <> typeInfoToText False params <> " r" <> mergedTypeInfoToText params + 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 diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index e51024e5..36e22ec3 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -55,12 +55,12 @@ sumTypeConstructors inj (SumType info constrs is) = (\cs -> SumType info cs is) -- 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/stack-8.0.yaml b/stack-8.0.yaml index 53b15e12..26d3ef57 100644 --- a/stack-8.0.yaml +++ b/stack-8.0.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2016-09-04 +resolver: lts-13.15 packages: - '.' extra-deps: [] From 80774b20f8df2af4138f9e2a6d0c64da33b1fcc5 Mon Sep 17 00:00:00 2001 From: David Smith Date: Wed, 8 May 2019 16:54:24 +0100 Subject: [PATCH 002/111] remove TODO --- src/Language/PureScript/Bridge/Printer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 4a63be17..c6dd6137 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -61,7 +61,7 @@ moduleToText settings m = T.unlines $ : "module " <> psModuleName m <> " where\n" : map importLineToText allImports <> [ "" - , "import Prelude" -- TODO: need a switch for Foreign.Generic to see if we should import or not and then implementation of the instances + , "import Prelude" , "" ] <> map (sumTypeToText settings) (psTypes m) From ecd2bd8a25c38d100207270dcc7b8dc7e965119c Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 10 May 2019 17:30:13 +0100 Subject: [PATCH 003/111] use https://github.com/paf31/purescript-foreign-generic/pull/52 --- src/Language/PureScript/Bridge/Printer.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index c6dd6137..0902ab7a 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -96,7 +96,7 @@ _lensImports settings _foreignImports :: Switches.Settings -> [ImportLine] _foreignImports settings | (isJust . Switches.generateForeign) settings = - [ ImportLine "Foreign.Generic" $ Set.fromList ["defaultOptions", "genericDecode", "genericEncode"] + [ ImportLine "Foreign.Generic" $ Set.fromList ["defaultOptions", "genericDecode", "genericEncode", "aesonSumEncoding"] , ImportLine "Foreign.Class" $ Set.fromList ["class Decode", "class Encode"] ] | otherwise = [] @@ -131,13 +131,18 @@ sumTypeToTypeDecls settings (SumType t cs is) = T.unlines $ instances :: Switches.Settings -> SumType 'PureScript -> [Text] instances settings st@(SumType t _ is) = map go is where + recordUpdateString :: [(Text, Text)] -> Text + recordUpdateString args = "{ " <> T.intercalate ", " (map (\(k, v) -> k <> " = " <> v) args) <> " }" + 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 <> " }" + Just fopts -> recordUpdateString [ ("unwrapSingleConstructors", (T.toLower . T.pack . show . Switches.unwrapSingleConstructors) fopts) + , ("sumEncoding", "aesonSumEncoding") + ] stpLength = length sumTypeParameters extras | stpLength == 0 = mempty | otherwise = bracketWrap constraintsInner <> " => " @@ -150,7 +155,9 @@ instances settings st@(SumType t _ is) = map go is where decodeOpts = case Switches.generateForeign settings of Nothing -> "" - Just fopts -> " { unwrapSingleConstructors = " <> (T.toLower . T.pack . show . Switches.unwrapSingleConstructors) fopts <> " }" + Just fopts -> recordUpdateString [ ("unwrapSingleConstructors", (T.toLower . T.pack . show . Switches.unwrapSingleConstructors) fopts) + , ("sumEncoding", "aesonSumEncoding") + ] stpLength = length sumTypeParameters extras | stpLength == 0 = mempty | otherwise = bracketWrap constraintsInner <> " => " From 70f165412c5fb1410e71f3245b12388f7eba8c51 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 17 May 2019 13:20:24 +0100 Subject: [PATCH 004/111] Whitespace changes. --- src/Language/PureScript/Bridge.hs | 85 ++-- src/Language/PureScript/Bridge/Builder.hs | 152 +++--- .../PureScript/Bridge/CodeGenSwitches.hs | 58 +-- src/Language/PureScript/Bridge/PSTypes.hs | 83 ++-- src/Language/PureScript/Bridge/Primitives.hs | 23 +- src/Language/PureScript/Bridge/Printer.hs | 470 +++++++++++------- src/Language/PureScript/Bridge/SumType.hs | 169 ++++--- src/Language/PureScript/Bridge/Tuple.hs | 22 +- src/Language/PureScript/Bridge/TypeInfo.hs | 96 ++-- .../PureScript/Bridge/TypeParameters.hs | 52 +- 10 files changed, 710 insertions(+), 500 deletions(-) diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index 7d9239b0..8c2b84d6 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -1,29 +1,29 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -module Language.PureScript.Bridge ( - bridgeSumType +module Language.PureScript.Bridge + ( bridgeSumType , defaultBridge , module Bridge , writePSTypes , writePSTypesWith - , defaultSwitch, noLenses, genLenses - ) where - + , defaultSwitch + , noLenses + , genLenses + ) where import Control.Applicative -import qualified Data.Map as M -import qualified Data.Set as Set -import qualified Data.Text.IO as T - +import qualified Data.Map as M +import qualified Data.Set as Set +import qualified Data.Text.IO as T import Language.PureScript.Bridge.Builder as Bridge +import Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.Primitives as Bridge import Language.PureScript.Bridge.Printer as Bridge import Language.PureScript.Bridge.SumType as Bridge import Language.PureScript.Bridge.Tuple as Bridge import Language.PureScript.Bridge.TypeInfo as Bridge -import Language.PureScript.Bridge.CodeGenSwitches as Switches -- | Your entry point to this library and quite likely all you will need. -- Make sure all your types derive `Generic` and `Typeable`. @@ -80,7 +80,6 @@ import Language.PureScript.Bridge.CodeGenSwitches as Switches writePSTypes :: FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypes = writePSTypesWith Switches.defaultSwitch - -- | Works like `writePSTypes` but you can add additional switches to control the generation of your PureScript code -- -- == Switches/Settings: @@ -89,23 +88,23 @@ writePSTypes = writePSTypesWith Switches.defaultSwitch -- -- == /WARNING/: -- This function overwrites files - make backups or use version control! -writePSTypesWith :: Switches.Switch -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () +writePSTypesWith :: + Switches.Switch -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypesWith switch root bridge sts = do - mapM_ (printModule settings root) modules - T.putStrLn "The following purescript packages are needed by the generated code:\n" - mapM_ (T.putStrLn . mappend " - ") packages - T.putStrLn "\nSuccessfully created your PureScript modules!" - - where - settings = Switches.getSettings switch - bridged = map (bridgeSumType bridge) sts - modules = M.elems $ sumTypesToModules M.empty bridged - packages = - if Switches.generateLenses settings then - Set.insert "purescript-profunctor-lenses" $ sumTypesToNeededPackages bridged - else - sumTypesToNeededPackages bridged - + mapM_ (printModule settings root) modules + T.putStrLn + "The following purescript packages are needed by the generated code:\n" + mapM_ (T.putStrLn . mappend " - ") packages + T.putStrLn "\nSuccessfully created your PureScript modules!" + where + settings = Switches.getSettings switch + bridged = map (bridgeSumType bridge) sts + modules = M.elems $ sumTypesToModules M.empty bridged + packages = + if Switches.generateLenses settings + then Set.insert "purescript-profunctor-lenses" $ + sumTypesToNeededPackages bridged + else sumTypesToNeededPackages bridged -- | Translate all 'TypeInfo' values in a 'SumType' to PureScript types. -- @@ -115,7 +114,8 @@ writePSTypesWith switch root bridge sts = do -- -- > bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo)) bridgeSumType :: FullBridge -> SumType 'Haskell -> SumType 'PureScript -bridgeSumType br (SumType t cs is) = SumType (br t) (map (bridgeConstructor br) cs) is +bridgeSumType br (SumType t cs is) = + SumType (br t) (map (bridgeConstructor br) cs) is -- | Default bridge for mapping primitive/common types: -- You can append your own bridges like this: @@ -125,25 +125,24 @@ bridgeSumType br (SumType t cs is) = SumType (br t) (map (bridgeConstructor br) -- Find examples for bridge definitions in "Language.PureScript.Bridge.Primitives" and -- "Language.PureScript.Bridge.Tuple". defaultBridge :: BridgePart -defaultBridge = textBridge - <|> stringBridge - <|> listBridge - <|> maybeBridge - <|> eitherBridge - <|> boolBridge - <|> intBridge - <|> doubleBridge - <|> tupleBridge - <|> unitBridge - <|> noContentBridge +defaultBridge = + textBridge <|> stringBridge <|> listBridge <|> maybeBridge <|> eitherBridge <|> + boolBridge <|> + intBridge <|> + doubleBridge <|> + tupleBridge <|> + unitBridge <|> + noContentBridge -- | Translate types in a constructor. -bridgeConstructor :: FullBridge -> DataConstructor 'Haskell -> DataConstructor 'PureScript +bridgeConstructor :: + FullBridge -> DataConstructor 'Haskell -> DataConstructor 'PureScript bridgeConstructor br (DataConstructor name (Left infos)) = - DataConstructor name . Left $ map br infos + DataConstructor name . Left $ map br infos bridgeConstructor br (DataConstructor name (Right record)) = - DataConstructor name . Right $ map (bridgeRecordEntry br) record + DataConstructor name . Right $ map (bridgeRecordEntry br) record -- | Translate types in a record entry. -bridgeRecordEntry :: FullBridge -> RecordEntry 'Haskell -> RecordEntry 'PureScript +bridgeRecordEntry :: + FullBridge -> RecordEntry 'Haskell -> RecordEntry 'PureScript bridgeRecordEntry br (RecordEntry label value) = RecordEntry label $ br value diff --git a/src/Language/PureScript/Bridge/Builder.hs b/src/Language/PureScript/Bridge/Builder.hs index c6bfee34..3a42a749 100644 --- a/src/Language/PureScript/Bridge/Builder.hs +++ b/src/Language/PureScript/Bridge/Builder.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} -- | A bridge builder DSL, powered by 'Monad', 'Alternative' and lens. -- @@ -17,38 +17,36 @@ -- > view haskType -- -- Find usage examples in "Language.PureScript.Bridge.Primitives" and "Language.PureScript.Bridge.PSTypes" -module Language.PureScript.Bridge.Builder ( - BridgeBuilder -, BridgePart -, FixUpBuilder -, FixUpBridge -, BridgeData -, fullBridge -, (^==) -, doCheck -, (<|>) -, psTypeParameters -, FullBridge -, buildBridge -, clearPackageFixUp -, errorFixUp -, buildBridgeWithCustomFixUp -) where - -import Control.Applicative -import Control.Lens -import Control.Monad (MonadPlus, guard, mplus, - mzero) -import Control.Monad.Reader.Class -import Control.Monad.Trans.Reader (Reader, ReaderT (..), - runReader) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Language.PureScript.Bridge.TypeInfo +module Language.PureScript.Bridge.Builder + ( BridgeBuilder + , BridgePart + , FixUpBuilder + , FixUpBridge + , BridgeData + , fullBridge + , (^==) + , doCheck + , (<|>) + , psTypeParameters + , FullBridge + , buildBridge + , clearPackageFixUp + , errorFixUp + , buildBridgeWithCustomFixUp + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad (MonadPlus, guard, mplus, mzero) +import Control.Monad.Reader.Class +import Control.Monad.Trans.Reader (Reader, ReaderT(..), runReader) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Language.PureScript.Bridge.TypeInfo newtype BridgeBuilder a = BridgeBuilder (ReaderT BridgeData Maybe a) - deriving (Functor, Applicative, Monad, MonadReader BridgeData) + deriving (Functor, Applicative, Monad, MonadReader BridgeData) type BridgePart = BridgeBuilder PSType @@ -64,7 +62,6 @@ type BridgePart = BridgeBuilder PSType -- > -- > import Control.Monad.Reader.Class -- > import Language.PureScript.Bridge.TypeInfo - -- > -- > psEither :: MonadReader BridgeData m => m PSType -- > psEither = .... @@ -79,18 +76,21 @@ type BridgePart = BridgeBuilder PSType -- > psEither :: FixUpBridge -- > psEither = .... -- -newtype FixUpBuilder a = FixUpBuilder (Reader BridgeData a) deriving (Functor, Applicative, Monad, MonadReader BridgeData) +newtype FixUpBuilder a = + FixUpBuilder (Reader BridgeData a) + deriving (Functor, Applicative, Monad, MonadReader BridgeData) type FixUpBridge = FixUpBuilder PSType type FullBridge = HaskellType -> PSType -data BridgeData = BridgeData { +data BridgeData = + BridgeData -- | The Haskell type to translate. - _haskType :: HaskellType + { _haskType :: HaskellType -- | Reference to the bridge itself, needed for translation of type constructors. - , _fullBridge :: FullBridge - } + , _fullBridge :: FullBridge + } -- | By implementing the 'haskType' lens in the HasHaskType class, we are able -- to use it for both 'BridgeData' and a plain 'HaskellType', therefore @@ -133,12 +133,13 @@ clearPackageFixUp :: MonadReader BridgeData m => m PSType clearPackageFixUp = do input <- view haskType psArgs <- psTypeParameters - return TypeInfo { - _typePackage = "" - , _typeModule = input ^. typeModule - , _typeName = input ^. typeName - , _typeParameters = psArgs - } + return + TypeInfo + { _typePackage = "" + , _typeModule = input ^. typeModule + , _typeName = input ^. typeName + , _typeParameters = psArgs + } -- | A 'FixUpBridge' which calles 'error' when used. -- Usage: @@ -146,12 +147,17 @@ clearPackageFixUp = do -- > buildBridgeWithCustomFixUp errorFixUp yourBridge errorFixUp :: MonadReader BridgeData m => m PSType errorFixUp = do - inType <- view haskType - let message = "No translation supplied for Haskell type: '" - <> inType ^. typeName <> "', from module: '" - <> inType ^. typeModule <> "', from package: '" - <> inType ^. typePackage <> "'!" - return $ error $ T.unpack message + inType <- view haskType + let message = + "No translation supplied for Haskell type: '" <> inType ^. typeName <> + "', from module: '" <> + inType ^. + typeModule <> + "', from package: '" <> + inType ^. + typePackage <> + "'!" + return $ error $ T.unpack message -- | Build a bridge. -- @@ -163,18 +169,16 @@ errorFixUp = do buildBridge :: BridgePart -> FullBridge buildBridge = buildBridgeWithCustomFixUp clearPackageFixUp - -- | Takes a constructed BridgePart and makes it a total function ('FullBridge') -- by using the supplied 'FixUpBridge' when 'BridgePart' returns 'Nothing'. buildBridgeWithCustomFixUp :: FixUpBridge -> BridgePart -> FullBridge -buildBridgeWithCustomFixUp (FixUpBuilder fixUp) (BridgeBuilder bridgePart) = let - mayBridge :: HaskellType -> Maybe PSType - mayBridge inType = runReaderT bridgePart $ BridgeData inType bridge - fixBridge inType = runReader fixUp $ BridgeData inType bridge - bridge inType = fixTypeParameters $ fromMaybe (fixBridge inType) (mayBridge inType) - in - bridge - +buildBridgeWithCustomFixUp (FixUpBuilder fixUp) (BridgeBuilder bridgePart) = + let mayBridge :: HaskellType -> Maybe PSType + mayBridge inType = runReaderT bridgePart $ BridgeData inType bridge + fixBridge inType = runReader fixUp $ BridgeData inType bridge + bridge inType = + fixTypeParameters $ fromMaybe (fixBridge inType) (mayBridge inType) + in bridge -- | Translate types that come from any module named "Something.TypeParameters" to lower case: -- @@ -183,28 +187,28 @@ buildBridgeWithCustomFixUp (FixUpBuilder fixUp) (BridgeBuilder bridgePart) = let -- -- It enables you to even bridge type constructor definitions, see "Language.PureScript.Bridge.TypeParameters" for more details. fixTypeParameters :: TypeInfo lang -> TypeInfo lang -fixTypeParameters t = if "TypeParameters" `T.isSuffixOf` _typeModule t - then t { - _typePackage = "" -- Don't suggest any packages - , _typeModule = "" -- Don't import any modules - , _typeName = t ^. typeName . to (stripNum . T.toLower) - } +fixTypeParameters t = + if "TypeParameters" `T.isSuffixOf` _typeModule t + then t + { _typePackage = "" -- Don't suggest any packages + , _typeModule = "" -- Don't import any modules + , _typeName = t ^. typeName . to (stripNum . T.toLower) + } else t where stripNum v = fromMaybe v (T.stripSuffix "1" v) - -- | Alternative instance for BridgeBuilder so you can construct bridges with '<|>', -- which behaves like a logical 'or' ('||'). If the left-hand side results in Nothing -- the right-hand side is used, otherwise the left-hand side. -- For usage examples see "Language.PureScript.Bridge.Primitives". instance Alternative BridgeBuilder where empty = BridgeBuilder . ReaderT $ const Nothing - BridgeBuilder a <|> BridgeBuilder b = BridgeBuilder . ReaderT $ \bridgeData -> let - ia = runReaderT a bridgeData + BridgeBuilder a <|> BridgeBuilder b = + BridgeBuilder . ReaderT $ \bridgeData -> + let ia = runReaderT a bridgeData ib = runReaderT b bridgeData - in - ia <|> ib + in ia <|> ib instance MonadPlus BridgeBuilder where mzero = empty diff --git a/src/Language/PureScript/Bridge/CodeGenSwitches.hs b/src/Language/PureScript/Bridge/CodeGenSwitches.hs index 5125a024..c88a73b1 100644 --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ b/src/Language/PureScript/Bridge/CodeGenSwitches.hs @@ -1,78 +1,74 @@ -- | 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 - +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 -data 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) + deriving (Eq, Show) -data ForeignOptions = ForeignOptions +data ForeignOptions = + ForeignOptions { unwrapSingleConstructors :: Bool } - deriving (Eq, Show) + deriving (Eq, Show) -- | Settings to generate Lenses defaultSettings :: Settings 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 - -- | Translate switches into settings getSettings :: Switch -> Settings getSettings switch = appEndo switch defaultSettings - -- | Default switches include code generation for lenses defaultSwitch :: Switch defaultSwitch = mempty - -- | Switch off the generatation of profunctor-lenses noLenses :: Switch -noLenses = Endo $ \settings -> settings { generateLenses = False } - +noLenses = Endo $ \settings -> settings {generateLenses = False} -- | Switch on the generatation of profunctor-lenses genLenses :: Switch -genLenses = Endo $ \settings -> settings { generateLenses = True } - +genLenses = Endo $ \settings -> settings {generateLenses = True} -- | Generate generics using purescript-generics-rep useGenRep :: Switch -useGenRep = Endo $ \settings -> settings { genericsGenRep = True } - +useGenRep = Endo $ \settings -> settings {genericsGenRep = True} -- | Generate generics using purescript-generics useGen :: Switch -useGen = Endo $ \settings -> settings { genericsGenRep = False } +useGen = Endo $ \settings -> settings {genericsGenRep = False} genForeign :: ForeignOptions -> Switch -genForeign opts = Endo $ \settings -> settings { generateForeign = Just opts } +genForeign opts = Endo $ \settings -> settings {generateForeign = Just opts} noForeign :: Switch -noForeign = Endo $ \settings -> settings { generateForeign = Nothing } \ No newline at end of file +noForeign = Endo $ \settings -> settings {generateForeign = Nothing} diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs index d8b39fa0..f85d8870 100644 --- a/src/Language/PureScript/Bridge/PSTypes.hs +++ b/src/Language/PureScript/Bridge/PSTypes.hs @@ -8,9 +8,8 @@ module Language.PureScript.Bridge.PSTypes where import Control.Lens (views) -import qualified Data.Text as T import Control.Monad.Reader.Class - +import qualified Data.Text as T import Language.PureScript.Bridge.Builder import Language.PureScript.Bridge.TypeInfo @@ -20,58 +19,70 @@ psArray :: MonadReader BridgeData m => m PSType psArray = TypeInfo "" "Prim" "Array" <$> psTypeParameters psBool :: PSType -psBool = TypeInfo { - _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Boolean" - , _typeParameters = [] - } +psBool = + TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Boolean" + , _typeParameters = [] + } -- | Uses type parameters from 'haskType' (bridged). psEither :: MonadReader BridgeData m => m PSType -psEither = TypeInfo "purescript-either" "Data.Either" "Either" <$> psTypeParameters +psEither = + TypeInfo "purescript-either" "Data.Either" "Either" <$> psTypeParameters psInt :: PSType -psInt = TypeInfo { - _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Int" - , _typeParameters = [] - } +psInt = + TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Int" + , _typeParameters = [] + } psNumber :: PSType -psNumber = TypeInfo { - _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Number" - , _typeParameters = [] - } +psNumber = + TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Number" + , _typeParameters = [] + } -- | Uses type parameters from 'haskType' (bridged). psMaybe :: MonadReader BridgeData m => m PSType psMaybe = TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" <$> psTypeParameters psString :: PSType -psString = TypeInfo { - _typePackage = "" - , _typeModule = "Prim" - , _typeName = "String" - , _typeParameters = [] - } +psString = + TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "String" + , _typeParameters = [] + } -- | Uses type parameters from 'haskType' (bridged). psTuple :: MonadReader BridgeData m => m PSType psTuple = do size <- views (haskType . typeParameters) length - let - tupleModule = if size == 2 then "Data.Tuple" else "Data.Tuple.Nested" - tupleName = "Tuple" <> if size == 2 then "" else T.pack (show size) + let tupleModule = + if size == 2 + then "Data.Tuple" + else "Data.Tuple.Nested" + tupleName = + "Tuple" <> + if size == 2 + then "" + else T.pack (show size) TypeInfo "purescript-tuples" tupleModule tupleName <$> psTypeParameters psUnit :: PSType -psUnit = TypeInfo { - _typePackage = "purescript-prelude" - , _typeModule = "Prelude" - , _typeName = "Unit" - , _typeParameters = [] - } +psUnit = + TypeInfo + { _typePackage = "purescript-prelude" + , _typeModule = "Prelude" + , _typeName = "Unit" + , _typeParameters = [] + } diff --git a/src/Language/PureScript/Bridge/Primitives.hs b/src/Language/PureScript/Bridge/Primitives.hs index a7d35221..e9bdcfe9 100644 --- a/src/Language/PureScript/Bridge/Primitives.hs +++ b/src/Language/PureScript/Bridge/Primitives.hs @@ -2,16 +2,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} - module Language.PureScript.Bridge.Primitives where - -import Data.Proxy -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.PSTypes -import Language.PureScript.Bridge.TypeInfo -import Control.Monad.Reader.Class - +import Control.Monad.Reader.Class +import Data.Proxy +import Language.PureScript.Bridge.Builder +import Language.PureScript.Bridge.PSTypes +import Language.PureScript.Bridge.TypeInfo boolBridge :: BridgePart boolBridge = typeName ^== "Bool" >> return psBool @@ -36,13 +33,15 @@ maybeBridge :: BridgePart maybeBridge = typeName ^== "Maybe" >> psMaybe stringBridge :: BridgePart -stringBridge = haskType ^== mkTypeInfo (Proxy :: Proxy String ) >> return psString +stringBridge = + haskType ^== mkTypeInfo (Proxy :: Proxy String) >> return psString textBridge :: BridgePart textBridge = do - typeName ^== "Text" - typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" - return psString + typeName ^== "Text" + typeModule ^== "Data.Text.Internal" <|> + typeModule ^== "Data.Text.Internal.Lazy" + return psString unitBridge :: BridgePart unitBridge = typeName ^== "()" >> return psUnit diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 0902ab7a..da5310f8 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -4,39 +4,63 @@ module Language.PureScript.Bridge.Printer where -import Control.Lens -import Control.Monad -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import Data.Maybe (isJust) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import System.Directory -import System.FilePath - - -import Language.PureScript.Bridge.SumType -import Language.PureScript.Bridge.TypeInfo +import Control.Lens (filtered, to, + traversed, (^.), + (^..), (^?), + _Right, _head) +import Control.Monad (unless) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches - - -data Module (lang :: Language) = PSModule { - psModuleName :: !Text -, psImportLines :: !(Map Text ImportLine) -, psTypes :: ![SumType lang] -} deriving Show +import Language.PureScript.Bridge.SumType (DataConstructor (DataConstructor), + Instance (Decode, Encode, Generic, Newtype), + RecordEntry (RecordEntry), + SumType (SumType), + getUsedTypes, + nootype, recLabel, + recValue, + sigValues, + sumTypeConstructors, + sumTypeInfo, + _recLabel) +import Language.PureScript.Bridge.TypeInfo (Language (PureScript), + PSType, TypeInfo, + typeParameters, + _typeModule, + _typeName, + _typePackage, + _typeParameters) +import System.Directory (createDirectoryIfMissing, + doesDirectoryExist) +import System.FilePath (joinPath, + takeDirectory, + ()) + +data Module (lang :: Language) = + PSModule + { psModuleName :: !Text + , psImportLines :: !(Map Text ImportLine) + , psTypes :: ![SumType lang] + } + deriving (Show) type PSModule = Module 'PureScript -data ImportLine = ImportLine { - importModule :: !Text -, importTypes :: !(Set Text) -} deriving Show +data ImportLine = + ImportLine + { importModule :: !Text + , importTypes :: !(Set Text) + } + deriving (Show) type Modules = Map Text PSModule + type ImportLines = Map Text ImportLine printModule :: Switches.Settings -> FilePath -> PSModule -> IO () @@ -44,7 +68,8 @@ printModule settings root m = do unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir T.writeFile mPath . moduleToText settings $ m where - mFile = (joinPath . map T.unpack . T.splitOn "." $ psModuleName m) <> ".purs" + mFile = + (joinPath . map T.unpack . T.splitOn "." $ psModuleName m) <> ".purs" mPath = root mFile mDir = takeDirectory mPath @@ -56,33 +81,32 @@ sumTypeToNeededPackages st = Set.filter (not . T.null) . Set.map _typePackage $ getUsedTypes st moduleToText :: Switches.Settings -> Module 'PureScript -> Text -moduleToText settings m = T.unlines $ - "-- File auto generated by purescript-bridge! --" - : "module " <> psModuleName m <> " where\n" - : map importLineToText allImports - <> [ "" - , "import Prelude" - , "" - ] - <> map (sumTypeToText settings) (psTypes m) +moduleToText settings m = + T.unlines $ "-- File auto generated by purescript-bridge! --" : "module " <> + psModuleName m <> + " where\n" : + map importLineToText allImports <> + ["", "import Prelude", ""] <> + map (sumTypeToText settings) (psTypes m) where - otherImports = importsFromList (_lensImports settings <> _genericsImports settings <> _foreignImports settings) + otherImports = + importsFromList + (_lensImports settings <> _genericsImports settings <> + _foreignImports settings) allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) - _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"] ] - + [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" $ + 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)"] @@ -95,10 +119,12 @@ _lensImports settings _foreignImports :: Switches.Settings -> [ImportLine] _foreignImports settings - | (isJust . Switches.generateForeign) settings = - [ ImportLine "Foreign.Generic" $ Set.fromList ["defaultOptions", "genericDecode", "genericEncode", "aesonSumEncoding"] - , ImportLine "Foreign.Class" $ Set.fromList ["class Decode", "class Encode"] - ] + | (isJust . Switches.generateForeign) settings = + [ ImportLine "Foreign.Generic" $ + Set.fromList + ["defaultOptions", "genericDecode", "genericEncode", "aesonSumEncoding"] + , ImportLine "Foreign.Class" $ Set.fromList ["class Decode", "class Encode"] + ] | otherwise = [] importLineToText :: ImportLine -> Text @@ -107,24 +133,29 @@ importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")" typeList = T.intercalate ", " (Set.toList (importTypes l)) sumTypeToText :: Switches.Settings -> SumType 'PureScript -> Text -sumTypeToText settings st = - sumTypeToTypeDecls settings st <> additionalCode +sumTypeToText settings st = sumTypeToTypeDecls settings st <> additionalCode where additionalCode = - if Switches.generateLenses settings then lenses else mempty + if Switches.generateLenses settings + then lenses + else mempty lenses = "\n" <> sep <> "\n" <> sumTypeToOptics st <> sep sep = T.replicate 80 "-" 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 settings (SumType t cs (filter genForeign is)) +sumTypeToTypeDecls settings (SumType t cs is) = + T.unlines $ dataOrNewtype <> " " <> typeInfoToText True t <> " =" : " " <> + T.intercalate "\n | " (map (constructorToText 4) cs) <> + "\n" : + instances settings (SumType t cs (filter genForeign is)) where - dataOrNewtype = if isJust (nootype cs) then "newtype" else "data" + dataOrNewtype = + if isJust (nootype cs) + then "newtype" + else "data" genForeign Encode = (isJust . Switches.generateForeign) settings genForeign Decode = (isJust . Switches.generateForeign) settings - genForeign _ = True + genForeign _ = True -- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. @@ -132,54 +163,89 @@ instances :: Switches.Settings -> SumType 'PureScript -> [Text] instances settings st@(SumType t _ is) = map go is where recordUpdateString :: [(Text, Text)] -> Text - recordUpdateString args = "{ " <> T.intercalate ", " (map (\(k, v) -> k <> " = " <> v) args) <> " }" - + recordUpdateString args = + "{ " <> T.intercalate ", " (map (\(k, v) -> k <> " = " <> v) args) <> " }" go :: Instance -> Text - go Encode = "instance encode" <> _typeName t <> " :: " <> extras <> "Encode " <> typeInfoToText False t <> " where\n" <> - " encode = genericEncode $ defaultOptions" <> encodeOpts + 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 -> recordUpdateString [ ("unwrapSingleConstructors", (T.toLower . T.pack . show . Switches.unwrapSingleConstructors) fopts) - , ("sumEncoding", "aesonSumEncoding") - ] + encodeOpts = + case Switches.generateForeign settings of + Nothing -> "" + Just fopts -> + recordUpdateString + [ ( "unwrapSingleConstructors" + , (T.toLower . T.pack . show . + Switches.unwrapSingleConstructors) + fopts) + , ("sumEncoding", "aesonSumEncoding") + ] stpLength = length sumTypeParameters - extras | stpLength == 0 = mempty - | otherwise = bracketWrap constraintsInner <> " => " - sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st + 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 + 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 + 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 -> recordUpdateString [ ("unwrapSingleConstructors", (T.toLower . T.pack . show . Switches.unwrapSingleConstructors) fopts) - , ("sumEncoding", "aesonSumEncoding") - ] + decodeOpts = + case Switches.generateForeign settings of + Nothing -> "" + Just fopts -> + recordUpdateString + [ ( "unwrapSingleConstructors" + , (T.toLower . T.pack . show . + Switches.unwrapSingleConstructors) + fopts) + , ("sumEncoding", "aesonSumEncoding") + ] stpLength = length sumTypeParameters - extras | stpLength == 0 = mempty - | otherwise = bracketWrap constraintsInner <> " => " - sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st + 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 + 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 + | stpLength == 1 = genericConstraintsInner <> " => " + | otherwise = bracketWrap genericConstraintsInner <> " => " + extras _ = "" + postfix Newtype = " _" + postfix Generic + | Switches.genericsGenRep settings = " _" + | otherwise = "" + postfix _ = "" + stpLength = length sumTypeParameters + sumTypeParameters = + filter (isTypeParam t) . Set.toList $ getUsedTypes st + genericConstraintsInner = + T.intercalate ", " $ map (genericInstance settings) sumTypeParameters 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 - | stpLength == 1 = genericConstraintsInner <> " => " - | otherwise = bracketWrap genericConstraintsInner <> " => " - extras _ = "" - postfix Newtype = " _" - postfix Generic - | Switches.genericsGenRep settings = " _" - | otherwise = "" - postfix _ = "" - stpLength = length sumTypeParameters - 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) @@ -192,10 +258,10 @@ 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 + 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 @@ -211,38 +277,45 @@ constructorOptics st = 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 +recordOptics st@(SumType _ [_] _) = + T.unlines $ recordEntryToLens st <$> dcRecords where cs = st ^. sumTypeConstructors - dcRecords = lensableConstructor ^.. traversed.sigValues._Right.traverse.filtered hasUnderscore - hasUnderscore e = e ^. recLabel.to (T.isPrefixOf "_") + 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 _ (DataConstructor n (Left [])) = n +constructorToText _ (DataConstructor n (Left ts)) = + n <> " " <> T.intercalate " " (map (typeInfoToText False) ts) constructorToText indentation (DataConstructor n (Right rs)) = - n <> " {\n" - <> spaces (indentation + 2) <> T.intercalate intercalation (map recordEntryToText rs) <> "\n" - <> spaces indentation <> "}" + n <> " {\n" <> spaces (indentation + 2) <> + T.intercalate intercalation (map recordEntryToText rs) <> + "\n" <> + spaces indentation <> + "}" where intercalation = "\n" <> spaces indentation <> "," <> " " spaces :: Int -> Text spaces c = T.replicate c " " - typeNameAndForall :: TypeInfo 'PureScript -> (Text, Text) typeNameAndForall typeInfo = (typName, forAll) where typName = typeInfoToText False typeInfo - forAllParams = typeInfo ^.. typeParameters.traversed.to (typeInfoToText False) - forAll = case forAllParams of - [] -> " :: " - cs -> " :: forall " <> T.intercalate " " cs <> ". " + forAllParams = + typeInfo ^.. typeParameters . traversed . to (typeInfoToText False) + forAll = + case forAllParams of + [] -> " :: " + cs -> " :: forall " <> T.intercalate " " cs <> ". " fromEntries :: (RecordEntry a -> Text) -> [RecordEntry a] -> Text fromEntries mkElem rs = "{ " <> inners <> " }" @@ -251,76 +324,111 @@ fromEntries mkElem rs = "{ " <> inners <> " }" mkFnArgs :: [RecordEntry 'PureScript] -> Text mkFnArgs [r] = r ^. recLabel -mkFnArgs rs = fromEntries (\recE -> recE ^. recLabel <> ": " <> recE ^. recLabel) rs +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 -constructorToOptic :: Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Text +constructorToOptic :: + Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Text constructorToOptic otherConstructors typeInfo (DataConstructor n args) = - case (args,otherConstructors) of + case (args, otherConstructors) of (Left [c], False) -> - pName <> forAll <> "Iso' " <> typName <> " " <> mkTypeSig (constructorTypes [c]) <> "\n" - <> pName <> " = _Newtype" - <> "\n" + pName <> forAll <> "Iso' " <> typName <> " " <> + mkTypeSig (constructorTypes [c]) <> + "\n" <> + pName <> + " = _Newtype" <> + "\n" (Left cs, _) -> - pName <> forAll <> "Prism' " <> typName <> " " <> mkTypeSig types <> "\n" - <> pName <> " = prism' " <> getter <> " f\n" - <> spaces 2 <> "where\n" - <> spaces 4 <> "f " <> mkF cs - <> otherConstructorFallThrough - <> "\n" - where - mkF [] = n <> " = Just unit\n" - mkF _ = "(" <> n <> " " <> T.unwords (map _recLabel types) <> ") = Just $ " <> mkFnArgs types <> "\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 = constructorTypes cs + pName <> forAll <> "Prism' " <> typName <> " " <> mkTypeSig types <> "\n" <> + pName <> + " = prism' " <> + getter <> + " f\n" <> + spaces 2 <> + "where\n" <> + spaces 4 <> + "f " <> + mkF cs <> + otherConstructorFallThrough <> + "\n" + where mkF [] = n <> " = Just unit\n" + mkF _ = + "(" <> n <> " " <> T.unwords (map _recLabel types) <> + ") = Just $ " <> + mkFnArgs types <> + "\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 = constructorTypes cs (Right rs, False) -> - pName <> forAll <> "Iso' " <> typName <> " { " <> recordSig rs <> "}\n" - <> pName <> " = _Newtype\n" - <> "\n" + pName <> forAll <> "Iso' " <> typName <> " { " <> recordSig rs <> "}\n" <> + pName <> + " = _Newtype\n" <> + "\n" (Right rs, True) -> - 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 - <> "\n" + 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 <> + "\n" where recordSig rs = T.intercalate ", " (map recordEntryToText rs) - constructorTypes cs = [RecordEntry (T.singleton label) t | (label, t) <- zip ['a'..] cs] + constructorTypes cs = + [RecordEntry (T.singleton label) t | (label, t) <- zip ['a' ..] cs] (typName, forAll) = typeNameAndForall typeInfo pName = "_" <> n - otherConstructorFallThrough | otherConstructors = spaces 4 <> "f _ = Nothing" - | otherwise = "" + otherConstructorFallThrough + | otherConstructors = spaces 4 <> "f _ = Nothing" + | otherwise = "" 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 "" + then lensName <> forAll <> "Lens' " <> typName <> " " <> recType <> "\n" <> + lensName <> + " = _Newtype <<< prop (SProxy :: SProxy \"" <> + recName <> + "\")\n" + else "" where (typName, forAll) = typeNameAndForall (st ^. sumTypeInfo) recName = e ^. recLabel lensName = T.drop 1 recName recType = typeInfoToText False (e ^. recValue) - hasUnderscore = e ^. recLabel.to (T.isPrefixOf "_") + hasUnderscore = e ^. recLabel . to (T.isPrefixOf "_") recordEntryToText :: RecordEntry 'PureScript -> Text -recordEntryToText e = _recLabel e <> " :: " <> typeInfoToText True (e ^. recValue) - +recordEntryToText e = + _recLabel e <> " :: " <> typeInfoToText True (e ^. recValue) typeInfoToText :: Bool -> PSType -> Text -typeInfoToText topLevel t = if needParens then "(" <> inner <> ")" else inner +typeInfoToText topLevel t = + if needParens + then "(" <> inner <> ")" + else inner where - inner = _typeName t <> + inner = + _typeName t <> if pLength > 0 then " " <> T.intercalate " " textParameters else "" @@ -330,8 +438,7 @@ typeInfoToText topLevel t = if needParens then "(" <> inner <> ")" else inner textParameters = map (typeInfoToText False) params mergedTypeInfoToText :: PSType -> Text -mergedTypeInfoToText t = - _typeName t <> T.concat textParameters +mergedTypeInfoToText t = _typeName t <> T.concat textParameters where params = _typeParameters t textParameters = map mergedTypeInfoToText params @@ -340,43 +447,52 @@ sumTypesToModules :: Modules -> [SumType 'PureScript] -> Modules sumTypesToModules = foldr sumTypeToModule sumTypeToModule :: SumType 'PureScript -> Modules -> Modules -sumTypeToModule st@(SumType t _ _) = Map.alter (Just . updateModule) (_typeModule t) +sumTypeToModule st@(SumType t _ _) = + Map.alter (Just . updateModule) (_typeModule t) where - updateModule Nothing = PSModule { - psModuleName = _typeModule t - , psImportLines = dropSelf $ typesToImportLines Map.empty (getUsedTypes st) + updateModule Nothing = + PSModule + { psModuleName = _typeModule t + , psImportLines = + dropSelf $ typesToImportLines Map.empty (getUsedTypes st) , psTypes = [st] } - updateModule (Just m) = m { - psImportLines = dropSelf $ typesToImportLines (psImportLines m) (getUsedTypes st) - , psTypes = st : psTypes m - } + updateModule (Just m) = + m + { psImportLines = + dropSelf $ typesToImportLines (psImportLines m) (getUsedTypes st) + , psTypes = st : psTypes m + } dropSelf = Map.delete (_typeModule t) typesToImportLines :: ImportLines -> Set PSType -> ImportLines typesToImportLines = foldr typeToImportLines typeToImportLines :: PSType -> ImportLines -> ImportLines -typeToImportLines t ls = typesToImportLines (update ls) (Set.fromList (_typeParameters t)) +typeToImportLines t ls = + typesToImportLines (update ls) (Set.fromList (_typeParameters t)) where - update = if not (T.null (_typeModule t)) - then Map.alter (Just . updateLine) (_typeModule t) - else id - - updateLine Nothing = ImportLine (_typeModule t) (Set.singleton (_typeName t)) - updateLine (Just (ImportLine m types)) = ImportLine m $ Set.insert (_typeName t) types + update = + if not (T.null (_typeModule t)) + then Map.alter (Just . updateLine) (_typeModule t) + else id + updateLine Nothing = + ImportLine (_typeModule t) (Set.singleton (_typeName t)) + updateLine (Just (ImportLine m types)) = + ImportLine m $ Set.insert (_typeName t) types importsFromList :: [ImportLine] -> Map Text ImportLine -importsFromList ls = let - pairs = zip (map importModule ls) ls - merge a b = ImportLine (importModule a) (importTypes a `Set.union` importTypes b) - in - Map.fromListWith merge pairs +importsFromList ls = + let pairs = zip (map importModule ls) ls + merge a b = + ImportLine (importModule a) (importTypes a `Set.union` importTypes b) + in Map.fromListWith merge pairs mergeImportLines :: ImportLines -> ImportLines -> ImportLines mergeImportLines = Map.unionWith mergeLines where - mergeLines a b = ImportLine (importModule a) (importTypes a `Set.union` importTypes b) + mergeLines a b = + ImportLine (importModule a) (importTypes a `Set.union` importTypes b) unlessM :: Monad m => m Bool -> m () -> m () unlessM mbool action = mbool >>= flip unless action diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 36e22ec3..b25d50e2 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -2,75 +2,104 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverloadedStrings #-} -module Language.PureScript.Bridge.SumType ( - SumType (..) -, mkSumType -, equal, order -, DataConstructor (..) -, RecordEntry (..) -, Instance(..) -, nootype -, getUsedTypes -, constructorToTypes -, sigConstructor -, sigValues -, sumTypeInfo -, sumTypeConstructors -, recLabel -, recValue -) where - -import Control.Lens hiding (from, to) -import Data.List (nub) -import Data.Maybe (maybeToList) +module Language.PureScript.Bridge.SumType + ( SumType(..) + , mkSumType + , equal + , order + , DataConstructor(..) + , RecordEntry(..) + , Instance(..) + , nootype + , getUsedTypes + , constructorToTypes + , sigConstructor + , sigValues + , sumTypeInfo + , sumTypeConstructors + , recLabel + , recValue + ) where + +import Control.Lens hiding (from, to) +import Data.List (nub) +import Data.Maybe (maybeToList) import Data.Proxy -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T import Data.Typeable import Generics.Deriving import Language.PureScript.Bridge.TypeInfo -- | Generic representation of your Haskell types. -data SumType (lang :: Language) = SumType (TypeInfo lang) [DataConstructor lang] [Instance] deriving (Show, Eq) +data SumType (lang :: Language) = + SumType (TypeInfo lang) [DataConstructor lang] [Instance] + deriving (Show, Eq) -- | TypInfo lens for 'SumType'. -sumTypeInfo :: Functor f => (TypeInfo lang -> f (TypeInfo lang) ) -> SumType lang -> f (SumType lang) -sumTypeInfo inj (SumType info constrs is) = (\ti -> SumType ti constrs is) <$> inj info +sumTypeInfo :: + Functor f + => (TypeInfo lang -> f (TypeInfo lang)) + -> SumType lang + -> f (SumType lang) +sumTypeInfo inj (SumType info constrs is) = + (\ti -> SumType ti constrs is) <$> inj info -- | DataConstructor lens for 'SumType'. -sumTypeConstructors :: Functor f => ([DataConstructor lang] -> f [DataConstructor lang]) -> SumType lang -> f (SumType lang) -sumTypeConstructors inj (SumType info constrs is) = (\cs -> SumType info cs is) <$> inj constrs +sumTypeConstructors :: + Functor f + => ([DataConstructor lang] -> f [DataConstructor lang]) + -> SumType lang + -> f (SumType lang) +sumTypeConstructors inj (SumType info constrs is) = + (\cs -> SumType info cs is) <$> inj constrs -- | Create a representation of your sum (and product) types, -- for doing type translations and writing it out to your PureScript modules. -- 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 (Encode : Decode : Generic : maybeToList (nootype constructors)) +mkSumType :: + forall t. (Generic t, Typeable t, GDataConstructor (Rep t)) + => Proxy t + -> SumType 'Haskell +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 = Encode | Decode | 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. nootype :: [DataConstructor lang] -> Maybe Instance -nootype cs = case cs of - [constr] | either isSingletonList (const True) (_sigValues constr) -> Just Newtype - | otherwise -> Nothing - _ -> Nothing - where isSingletonList [_] = True - isSingletonList _ = False +nootype cs = + case cs of + [constr] + | either isSingletonList (const True) (_sigValues constr) -> Just Newtype + | otherwise -> Nothing + _ -> Nothing + where + isSingletonList [_] = True + isSingletonList _ = False -- | Ensure that an `Eq` instance is generated for your type. equal :: Eq a => Proxy a -> SumType t -> SumType t @@ -81,15 +110,18 @@ order :: Ord a => Proxy a -> SumType t -> SumType t order _ (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is data DataConstructor (lang :: Language) = - DataConstructor { _sigConstructor :: !Text -- ^ e.g. `Left`/`Right` for `Either` - , _sigValues :: !(Either [TypeInfo lang] [RecordEntry lang]) - } deriving (Show, Eq) - + DataConstructor + { _sigConstructor :: !Text -- ^ e.g. `Left`/`Right` for `Either` + , _sigValues :: !(Either [TypeInfo lang] [RecordEntry lang]) + } + deriving (Show, Eq) data RecordEntry (lang :: Language) = - RecordEntry { _recLabel :: !Text -- ^ e.g. `runState` for `State` - , _recValue :: !(TypeInfo lang) - } deriving (Show, Eq) + RecordEntry + { _recLabel :: !Text -- ^ e.g. `runState` for `State` + , _recValue :: !(TypeInfo lang) + } + deriving (Show, Eq) class GDataConstructor f where gToConstructors :: f a -> [DataConstructor 'Haskell] @@ -97,36 +129,37 @@ class GDataConstructor f where class GRecordEntry f where gToRecordEntries :: f a -> [RecordEntry 'Haskell] -instance (Datatype a, GDataConstructor c) => GDataConstructor (D1 a c) where +instance (Datatype a, GDataConstructor c) => GDataConstructor (D1 a c) where gToConstructors (M1 c) = gToConstructors c -instance (GDataConstructor a, GDataConstructor b) => GDataConstructor (a :+: b) where - gToConstructors (_ :: (a :+: b) f) = gToConstructors (undefined :: a f) - ++ gToConstructors (undefined :: b f) +instance (GDataConstructor a, GDataConstructor b) => + GDataConstructor (a :+: b) where + gToConstructors (_ :: (a :+: b) f) = + gToConstructors (undefined :: a f) ++ gToConstructors (undefined :: b f) instance (Constructor a, GRecordEntry b) => GDataConstructor (C1 a b) where - gToConstructors c@(M1 r) = [ DataConstructor { _sigConstructor = constructor - , _sigValues = values } - ] + gToConstructors c@(M1 r) = + [DataConstructor {_sigConstructor = constructor, _sigValues = values}] where constructor = T.pack $ conName c - values = if conIsRecord c - then Right $ gToRecordEntries r - else Left $ map _recValue $ gToRecordEntries r + values = + if conIsRecord c + then Right $ gToRecordEntries r + else Left $ map _recValue $ gToRecordEntries r instance (GRecordEntry a, GRecordEntry b) => GRecordEntry (a :*: b) where - gToRecordEntries (_ :: (a :*: b) f) = gToRecordEntries (undefined :: a f) - ++ gToRecordEntries (undefined :: b f) - + gToRecordEntries (_ :: (a :*: b) f) = + gToRecordEntries (undefined :: a f) ++ gToRecordEntries (undefined :: b f) instance GRecordEntry U1 where gToRecordEntries _ = [] instance (Selector a, Typeable t) => GRecordEntry (S1 a (K1 R t)) where - gToRecordEntries e = [ - RecordEntry { _recLabel = T.pack (selName e) - , _recValue = mkTypeInfo (Proxy :: Proxy t) - } + gToRecordEntries e = + [ RecordEntry + { _recLabel = T.pack (selName e) + , _recValue = mkTypeInfo (Proxy :: Proxy t) + } ] -- | Get all used types in a sum type. @@ -136,12 +169,14 @@ instance (Selector a, Typeable t) => GRecordEntry (S1 a (K1 R t)) where getUsedTypes :: SumType lang -> Set (TypeInfo lang) getUsedTypes (SumType _ cs _) = foldr constructorToTypes Set.empty cs -constructorToTypes :: DataConstructor lang -> Set (TypeInfo lang) -> Set (TypeInfo lang) +constructorToTypes :: + DataConstructor lang -> Set (TypeInfo lang) -> Set (TypeInfo lang) constructorToTypes (DataConstructor _ (Left myTs)) ts = Set.fromList (concatMap flattenTypeInfo myTs) `Set.union` ts -constructorToTypes (DataConstructor _ (Right rs)) ts = +constructorToTypes (DataConstructor _ (Right rs)) ts = Set.fromList (concatMap (flattenTypeInfo . _recValue) rs) `Set.union` ts -- Lenses: makeLenses ''DataConstructor + makeLenses ''RecordEntry diff --git a/src/Language/PureScript/Bridge/Tuple.hs b/src/Language/PureScript/Bridge/Tuple.hs index 686f5e5b..332cafc3 100644 --- a/src/Language/PureScript/Bridge/Tuple.hs +++ b/src/Language/PureScript/Bridge/Tuple.hs @@ -1,22 +1,24 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Bridge.Tuple where -import qualified Data.Text as T - - -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.PSTypes (psTuple) -import Language.PureScript.Bridge.TypeInfo +import qualified Data.Text as T +import Language.PureScript.Bridge.Builder +import Language.PureScript.Bridge.PSTypes (psTuple) +import Language.PureScript.Bridge.TypeInfo tupleBridge :: BridgePart tupleBridge = doCheck haskType isTuple >> psTuple - -data TupleParserState = - Start | OpenFound | ColonFound | Tuple | NoTuple deriving (Eq, Show) +data TupleParserState + = Start + | OpenFound + | ColonFound + | Tuple + | NoTuple + deriving (Eq, Show) step :: TupleParserState -> Char -> TupleParserState step Start '(' = OpenFound diff --git a/src/Language/PureScript/Bridge/TypeInfo.hs b/src/Language/PureScript/Bridge/TypeInfo.hs index af1c854c..a01b924d 100644 --- a/src/Language/PureScript/Bridge/TypeInfo.hs +++ b/src/Language/PureScript/Bridge/TypeInfo.hs @@ -1,46 +1,48 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} - - -module Language.PureScript.Bridge.TypeInfo ( - TypeInfo (..) - , PSType - , HaskellType - , mkTypeInfo - , mkTypeInfo' - , Language (..) - , typePackage - , typeModule - , typeName - , typeParameters - , HasHaskType - , haskType - , flattenTypeInfo -) where - - -import Control.Lens -import Data.Proxy -import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable - -data Language = Haskell | PureScript +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Language.PureScript.Bridge.TypeInfo + ( TypeInfo(..) + , PSType + , HaskellType + , mkTypeInfo + , mkTypeInfo' + , Language(..) + , typePackage + , typeModule + , typeName + , typeParameters + , HasHaskType + , haskType + , flattenTypeInfo + ) where + +import Control.Lens +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable + +data Language + = Haskell + | PureScript -- | Basic info about a data type: -data TypeInfo (lang :: Language) = TypeInfo { +data TypeInfo (lang :: Language) = + TypeInfo -- | Hackage package - _typePackage :: !Text + { _typePackage :: !Text -- | Full Module path -, _typeModule :: !Text -, _typeName :: !Text -, _typeParameters :: ![TypeInfo lang] -} deriving (Eq, Ord, Show) + , _typeModule :: !Text + , _typeName :: !Text + , _typeParameters :: ![TypeInfo lang] + } + deriving (Eq, Ord, Show) makeLenses ''TypeInfo @@ -50,7 +52,6 @@ type PSType = TypeInfo 'PureScript -- | For convenience: type HaskellType = TypeInfo 'Haskell - -- | Types that have a lens for accessing a 'TypeInfo Haskell'. class HasHaskType t where haskType :: Lens' t HaskellType @@ -59,19 +60,18 @@ class HasHaskType t where instance HasHaskType HaskellType where haskType inj = inj - mkTypeInfo :: Typeable t => Proxy t -> HaskellType mkTypeInfo = mkTypeInfo' . typeRep mkTypeInfo' :: TypeRep -> HaskellType -mkTypeInfo' rep = let - con = typeRepTyCon rep - in TypeInfo { - _typePackage = T.pack $ tyConPackage con - , _typeModule = T.pack $ tyConModule con - , _typeName = T.pack $ tyConName con - , _typeParameters = map mkTypeInfo' (typeRepArgs rep) - } +mkTypeInfo' rep = + let con = typeRepTyCon rep + in TypeInfo + { _typePackage = T.pack $ tyConPackage con + , _typeModule = T.pack $ tyConModule con + , _typeName = T.pack $ tyConName con + , _typeParameters = map mkTypeInfo' (typeRepArgs rep) + } -- | Put the TypeInfo in a list together with all its '_typeParameters' (recursively) flattenTypeInfo :: TypeInfo lang -> [TypeInfo lang] diff --git a/src/Language/PureScript/Bridge/TypeParameters.hs b/src/Language/PureScript/Bridge/TypeParameters.hs index 9bfa4383..0f032dc2 100644 --- a/src/Language/PureScript/Bridge/TypeParameters.hs +++ b/src/Language/PureScript/Bridge/TypeParameters.hs @@ -18,35 +18,58 @@ -- -- st = mkSumType ('Proxy' :: 'Proxy' (Maybe' A)) -- Note that we use "Maybe' A" instead of just Maybe - which would not work. -- @ - module Language.PureScript.Bridge.TypeParameters where - data A + data B + data C + data D + data E + data F + data G + data H + data I + data J + data K + data L + data M + data N + data O + data P + data Q + data R + data S + data T + data U + data V + data W + data X + data Y + data Z -- | You can use those if your type parameters are actually type constructors as well: @@ -54,28 +77,53 @@ data Z -- st = mkSumType (Proxy :: Proxy ('ReaderT' R M1 A)) -- @ data A1 a + data B1 a + data C1 a + data D1 a + data E1 a + data F1 a + data G1 a + data H1 a + data I1 a + data J1 a + data K1 a + data L1 a + data M1 a + data N1 a + data O1 a + data P1 a + data Q1 a + data R1 a + data S1 a + data T1 a + data U1 a + data V1 a + data W1 a + data X1 a + data Y1 a + data Z1 a From 02de37e39b3f3f0842c9a57df6ddb6125e8ecd09 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Mon, 20 May 2019 14:58:09 +0100 Subject: [PATCH 005/111] Refactoring the code to use a structured printing library. --- purescript-bridge.cabal | 2 + src/Language/PureScript/Bridge/Printer.hs | 412 +++++----- test/Spec.hs | 949 +++++++++++++--------- 3 files changed, 773 insertions(+), 590 deletions(-) diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index f2b33b59..5ac78a3a 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -79,6 +79,7 @@ library , lens , text , transformers + , wl-pprint-text , generic-deriving ghc-options: -Wall @@ -98,6 +99,7 @@ Test-Suite tests , containers , purescript-bridge , text + , wl-pprint-text , hspec , hspec-expectations-pretty-diff diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index da5310f8..8bf24c25 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -36,11 +36,28 @@ import Language.PureScript.Bridge.TypeInfo (Language (PureScrip _typeName, _typePackage, _typeParameters) + import System.Directory (createDirectoryIfMissing, doesDirectoryExist) import System.FilePath (joinPath, takeDirectory, ()) +import Text.PrettyPrint.Leijen.Text (Doc, align, cat, + comma, + displayTStrict, + encloseSep, hcat, + hsep, indent, + lbrace, line, + linebreak, lparen, + parens, punctuate, + rbrace, + renderPretty, + rparen, space, + textStrict, vsep, + (<+>), ()) + +renderText :: Doc -> Text +renderText = displayTStrict . renderPretty 0.4 200 data Module (lang :: Language) = PSModule @@ -85,9 +102,9 @@ moduleToText settings m = T.unlines $ "-- File auto generated by purescript-bridge! --" : "module " <> psModuleName m <> " where\n" : - map importLineToText allImports <> + (importLineToText <$> allImports) <> ["", "import Prelude", ""] <> - map (sumTypeToText settings) (psTypes m) + (renderText . sumTypeToDoc settings <$> psTypes m) where otherImports = importsFromList @@ -132,22 +149,32 @@ importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")" where typeList = T.intercalate ", " (Set.toList (importTypes l)) -sumTypeToText :: Switches.Settings -> SumType 'PureScript -> Text -sumTypeToText settings st = sumTypeToTypeDecls settings st <> additionalCode +sumTypeToDoc :: Switches.Settings -> SumType 'PureScript -> Doc +sumTypeToDoc settings st = 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 "-" + lenses = vsep [dashes, sumTypeToOptics st, dashes] + dashes = textStrict $ T.replicate 80 "-" -sumTypeToTypeDecls :: Switches.Settings -> SumType 'PureScript -> Text +sumTypeToTypeDecls :: Switches.Settings -> SumType 'PureScript -> Doc sumTypeToTypeDecls settings (SumType t cs is) = - T.unlines $ dataOrNewtype <> " " <> typeInfoToText True t <> " =" : " " <> - T.intercalate "\n | " (map (constructorToText 4) cs) <> - "\n" : - instances settings (SumType t cs (filter genForeign is)) + vsep $ + concat + [ [ dataOrNewtype <+> typeInfoToDoc True t + , indent + 2 + (encloseVsep + ("=" <> space) + mempty + ("|" <> space) + (constructorToDoc <$> cs)) + ] + , [line] + , instances settings (SumType t cs (filter genForeign is)) + ] where dataOrNewtype = if isJust (nootype cs) @@ -159,81 +186,62 @@ sumTypeToTypeDecls settings (SumType t cs is) = -- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. -instances :: Switches.Settings -> SumType 'PureScript -> [Text] -instances settings st@(SumType t _ is) = map go is +instances :: Switches.Settings -> SumType 'PureScript -> [Doc] +instances settings st@(SumType t _ is) = go <$> is where - recordUpdateString :: [(Text, Text)] -> Text - recordUpdateString args = - "{ " <> T.intercalate ", " (map (\(k, v) -> k <> " = " <> v) args) <> " }" - go :: Instance -> Text + go :: Instance -> Doc go Encode = - "instance encode" <> _typeName t <> " :: " <> extras <> "Encode " <> - typeInfoToText False t <> - " where\n" <> - " encode = genericEncode $ defaultOptions" <> - encodeOpts + "instance encode" <> textStrict (_typeName t) <+> "::" <+> extras <+> + "Encode" <+> + typeInfoToDoc False t <+> + "where" <> + linebreak <> + indent + 2 + ("encode = genericEncode" <+> parens ("defaultOptions" <+> align (jsonOpts settings))) where - encodeOpts = - case Switches.generateForeign settings of - Nothing -> "" - Just fopts -> - recordUpdateString - [ ( "unwrapSingleConstructors" - , (T.toLower . T.pack . show . - Switches.unwrapSingleConstructors) - fopts) - , ("sumEncoding", "aesonSumEncoding") - ] stpLength = length sumTypeParameters extras | stpLength == 0 = mempty - | otherwise = bracketWrap constraintsInner <> " => " + | otherwise = + constraintsInner (instanceBody <$> sumTypeParameters) <+> "=> " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st - constraintsInner = T.intercalate ", " $ map instances sumTypeParameters - instances params = - genericInstance settings params <> ", " <> encodeInstance params - bracketWrap x = "(" <> x <> ")" + instanceBody params = + genericInstance settings params <> comma <+> encodeInstance params go Decode = - "instance decode" <> _typeName t <> " :: " <> extras <> "Decode " <> - typeInfoToText False t <> - " where\n" <> - " decode = genericDecode $ defaultOptions" <> - decodeOpts + "instance decode" <> textStrict (_typeName t) <+> "::" <+> extras <+> + "Decode" <+> + typeInfoToDoc False t <+> + "where" <> + linebreak <> + indent + 2 + ("decode = genericDecode" <+> parens ("defaultOptions" <+> align (jsonOpts settings))) where - decodeOpts = - case Switches.generateForeign settings of - Nothing -> "" - Just fopts -> - recordUpdateString - [ ( "unwrapSingleConstructors" - , (T.toLower . T.pack . show . - Switches.unwrapSingleConstructors) - fopts) - , ("sumEncoding", "aesonSumEncoding") - ] stpLength = length sumTypeParameters extras | stpLength == 0 = mempty - | otherwise = bracketWrap constraintsInner <> " => " + | otherwise = + constraintsInner (instanceBody <$> sumTypeParameters) <+> "=> " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st - constraintsInner = T.intercalate ", " $ map instances sumTypeParameters - instances params = + instanceBody params = genericInstance settings params <> ", " <> decodeInstance params - bracketWrap x = "(" <> x <> ")" go i = - "derive instance " <> T.toLower c <> _typeName t <> " :: " <> extras i <> - c <> - " " <> - typeInfoToText False t <> + "derive instance " <> textStrict (T.toLower c) <> + textStrict (_typeName t) <+> + "::" <+> + extras i <> + textStrict c <+> + typeInfoToDoc False t <> postfix i where c = T.pack $ show i extras Generic | stpLength == 0 = mempty - | stpLength == 1 = genericConstraintsInner <> " => " - | otherwise = bracketWrap genericConstraintsInner <> " => " + | stpLength == 1 = genericConstraintsInner <+> text "=> " + | otherwise = parens genericConstraintsInner <+> text "=> " extras _ = "" postfix Newtype = " _" postfix Generic @@ -244,41 +252,62 @@ instances settings st@(SumType t _ is) = map go is sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st genericConstraintsInner = - T.intercalate ", " $ map (genericInstance settings) sumTypeParameters - bracketWrap x = "(" <> x <> ")" + hsep $ + punctuate (text ",") (genericInstance settings <$> sumTypeParameters) + +recordUpdateDoc :: [(Doc, Doc)] -> Doc +recordUpdateDoc = recordFields . fmap recordUpdateItem + where + recordUpdateItem (k, v) = k <+> "=" <+> v + +jsonOpts :: Switches.Settings -> Doc +jsonOpts settings = + case Switches.generateForeign settings of + Nothing -> mempty + Just fopts -> + recordUpdateDoc + [ ( "unwrapSingleConstructors" + , textStrict . T.toLower . T.pack . show . + Switches.unwrapSingleConstructors $ + fopts) + , ("sumEncoding", "aesonSumEncoding") + ] + +constraintsInner :: [Doc] -> Doc +constraintsInner = encloseSep lparen rparen ("," <> space) isTypeParam :: PSType -> PSType -> Bool isTypeParam t typ = _typeName typ `elem` map _typeName (_typeParameters t) -encodeInstance :: PSType -> Text -encodeInstance params = "Encode " <> typeInfoToText False params +encodeInstance :: PSType -> Doc +encodeInstance params = "Encode" <+> typeInfoToDoc False params -decodeInstance :: PSType -> Text -decodeInstance params = "Decode " <> typeInfoToText False params +decodeInstance :: PSType -> Doc +decodeInstance params = "Decode" <+> typeInfoToDoc False params -genericInstance :: Switches.Settings -> PSType -> Text +genericInstance :: Switches.Settings -> PSType -> Doc genericInstance settings params = if not (Switches.genericsGenRep settings) - then "Generic " <> typeInfoToText False params - else "Generic " <> typeInfoToText False params <> " r" <> - mergedTypeInfoToText params + then "Generic" <+> typeInfoToDoc False params + else "Generic" <+> typeInfoToDoc False params <+> "r" <> + mergedTypeInfoToDoc params -sumTypeToOptics :: SumType 'PureScript -> Text -sumTypeToOptics st = constructorOptics st <> recordOptics st +sumTypeToOptics :: SumType 'PureScript -> Doc +sumTypeToOptics st = + vsep $ punctuate line $ constructorOptics st <> recordOptics st -constructorOptics :: SumType 'PureScript -> Text +constructorOptics :: SumType 'PureScript -> [Doc] constructorOptics st = case st ^. sumTypeConstructors of - [] -> mempty -- No work required. - [c] -> constructorToOptic False typeInfo c - cs -> T.unlines $ map (constructorToOptic True typeInfo) cs + [] -> [] -- No work required. + [c] -> [constructorToOptic False typeInfo c] + cs -> constructorToOptic True typeInfo <$> cs where typeInfo = st ^. sumTypeInfo -recordOptics :: SumType 'PureScript -> Text +recordOptics :: SumType 'PureScript -> [Doc] -- Match on SumTypes with a single DataConstructor (that's a list of a single element) -recordOptics st@(SumType _ [_] _) = - T.unlines $ recordEntryToLens st <$> dcRecords +recordOptics st@(SumType _ [_] _) = recordEntryToLens st <$> dcRecords where cs = st ^. sumTypeConstructors dcRecords = @@ -288,160 +317,163 @@ recordOptics st@(SumType _ [_] _) = 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" <> spaces (indentation + 2) <> - T.intercalate intercalation (map recordEntryToText rs) <> - "\n" <> - spaces indentation <> - "}" - where - intercalation = "\n" <> spaces indentation <> "," <> " " - -spaces :: Int -> Text -spaces c = T.replicate c " " - -typeNameAndForall :: TypeInfo 'PureScript -> (Text, Text) +recordOptics _ = mempty + +constructorToDoc :: DataConstructor 'PureScript -> Doc +constructorToDoc (DataConstructor n (Left [])) = textStrict n +constructorToDoc (DataConstructor n (Left ts)) = + textStrict n <+> hsep (typeInfoToDoc False <$> ts) +constructorToDoc (DataConstructor n (Right rs)) = + textStrict n <> line <> indent 4 (recordFields (recordEntryToDoc <$> rs)) + +recordFields :: [Doc] -> Doc +recordFields = encloseVsep (lbrace <> space) (line <> rbrace) (comma <> space) + +encloseVsep :: Doc -> Doc -> Doc -> [Doc] -> Doc +encloseVsep left right sp ds = + case ds of + [] -> left <> right + [d] -> left <> d <> right + _ -> (vsep (zipWith (<>) (left : repeat sp) ds) <> right) + +typeNameAndForall :: TypeInfo 'PureScript -> (Doc, Doc) typeNameAndForall typeInfo = (typName, forAll) where - typName = typeInfoToText False typeInfo + typName = typeInfoToDoc False typeInfo forAllParams = - typeInfo ^.. typeParameters . traversed . to (typeInfoToText False) + typeInfo ^.. typeParameters . traversed . to (typeInfoToDoc False) forAll = + " :: " <> case forAllParams of - [] -> " :: " - cs -> " :: forall " <> T.intercalate " " cs <> ". " + [] -> mempty + cs -> "forall" <+> hsep cs <> ". " -fromEntries :: (RecordEntry a -> Text) -> [RecordEntry a] -> Text -fromEntries mkElem rs = "{ " <> inners <> " }" - where - inners = T.intercalate ", " $ map mkElem rs +fromEntries :: (RecordEntry a -> Doc) -> [RecordEntry a] -> Doc +fromEntries mkElem rs = + encloseSep (lbrace <> space) (space <> rbrace) ("," <> space) (mkElem <$> rs) -mkFnArgs :: [RecordEntry 'PureScript] -> Text -mkFnArgs [r] = r ^. recLabel +mkFnArgs :: [RecordEntry 'PureScript] -> Doc +mkFnArgs [r] = textStrict $ r ^. recLabel mkFnArgs rs = - fromEntries (\recE -> recE ^. recLabel <> ": " <> recE ^. recLabel) rs + fromEntries + (\recE -> + textStrict (recE ^. recLabel) <> ":" <+> textStrict (recE ^. recLabel)) + rs -mkTypeSig :: [RecordEntry 'PureScript] -> Text +mkTypeSig :: [RecordEntry 'PureScript] -> Doc mkTypeSig [] = "Unit" -mkTypeSig [r] = typeInfoToText False $ r ^. recValue -mkTypeSig rs = fromEntries recordEntryToText rs +mkTypeSig [r] = typeInfoToDoc False $ r ^. recValue +mkTypeSig rs = fromEntries recordEntryToDoc rs constructorToOptic :: - Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Text -constructorToOptic otherConstructors typeInfo (DataConstructor n args) = - case (args, otherConstructors) of + Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Doc +constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = + case (args, hasOtherConstructors) of (Left [c], False) -> - pName <> forAll <> "Iso' " <> typName <> " " <> - mkTypeSig (constructorTypes [c]) <> - "\n" <> - pName <> - " = _Newtype" <> - "\n" + vsep + [ pName <> forAll <> "Iso'" <+> typName <+> + mkTypeSig (constructorTypes [c]) + , pName <+> "= _Newtype" + ] (Left cs, _) -> - pName <> forAll <> "Prism' " <> typName <> " " <> mkTypeSig types <> "\n" <> - pName <> - " = prism' " <> - getter <> - " f\n" <> - spaces 2 <> - "where\n" <> - spaces 4 <> - "f " <> - mkF cs <> - otherConstructorFallThrough <> - "\n" - where mkF [] = n <> " = Just unit\n" + vsep + [ pName <> forAll <> "Prism'" <+> typName <+> mkTypeSig types + , pName <+> "= prism'" <+> getter <+> "f" <> line <> + indent + 2 + ("where" <> linebreak <> + indent 2 (vsep ["f" <+> mkF cs, otherConstructorFallThrough])) + ] + where mkF [] = textStrict n <+> "= Just unit" mkF _ = - "(" <> n <> " " <> T.unwords (map _recLabel types) <> - ") = Just $ " <> - mkFnArgs types <> - "\n" + parens + (textStrict n <> space <> + textStrict (T.unwords (_recLabel <$> types))) <+> + "= Just $" <+> + mkFnArgs types + getter :: Doc getter - | null cs = "(\\_ -> " <> n <> ")" - | length cs == 1 = n + | null cs = parens ("\\_ ->" <+> textStrict n) + | length cs == 1 = textStrict n | otherwise = - "(\\{ " <> T.intercalate ", " cArgs <> " } -> " <> n <> " " <> - T.intercalate " " cArgs <> - ")" + parens + ("\\{" <+> (cat $ punctuate (", ") cArgs) <+> "} ->" <+> + textStrict n <+> + (cat $ punctuate space cArgs)) where - cArgs = map (T.singleton . fst) $ zip ['a' ..] cs + cArgs = textStrict . T.singleton . fst <$> zip ['a' ..] cs types = constructorTypes cs (Right rs, False) -> - pName <> forAll <> "Iso' " <> typName <> " { " <> recordSig rs <> "}\n" <> - pName <> - " = _Newtype\n" <> - "\n" + vsep + [ pName <> forAll <> "Iso'" <+> typName <+> + fromEntries recordEntryToDoc rs + , pName <+> "= _Newtype" + ] (Right rs, True) -> - 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 <> - "\n" + vsep + [ pName <> forAll <> "Prism'" <+> typName <+> + fromEntries recordEntryToDoc rs + , pName <+> "= prism'" <+> textStrict n <+> "f" <> line <> + indent + 2 + ("where" <> linebreak <> + indent + 2 + ("f (" <> textStrict n <+> "r) = Just r" <> line <> + otherConstructorFallThrough)) + ] where - 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 + pName = "_" <> textStrict n otherConstructorFallThrough - | otherConstructors = spaces 4 <> "f _ = Nothing" - | otherwise = "" + | hasOtherConstructors = "f _ = Nothing" + | otherwise = mempty -recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Text +recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Doc recordEntryToLens st e = if hasUnderscore - then lensName <> forAll <> "Lens' " <> typName <> " " <> recType <> "\n" <> - lensName <> - " = _Newtype <<< prop (SProxy :: SProxy \"" <> - recName <> - "\")\n" - else "" + then vsep + [ textStrict lensName <> forAll <> "Lens'" <+> typName <+> recType + , textStrict lensName <+> "= _Newtype <<< prop" <+> + parens ("SProxy :: SProxy \"" <> textStrict recName <> "\"") + ] + else mempty where (typName, forAll) = typeNameAndForall (st ^. sumTypeInfo) recName = e ^. recLabel lensName = T.drop 1 recName - recType = typeInfoToText False (e ^. recValue) + recType = typeInfoToDoc False (e ^. recValue) hasUnderscore = e ^. recLabel . to (T.isPrefixOf "_") -recordEntryToText :: RecordEntry 'PureScript -> Text -recordEntryToText e = - _recLabel e <> " :: " <> typeInfoToText True (e ^. recValue) +recordEntryToDoc :: RecordEntry 'PureScript -> Doc +recordEntryToDoc e = + textStrict (_recLabel e) <+> "::" <+> typeInfoToDoc True (e ^. recValue) typeInfoToText :: Bool -> PSType -> Text -typeInfoToText topLevel t = +typeInfoToText topLevel = renderText . typeInfoToDoc topLevel + +typeInfoToDoc :: Bool -> PSType -> Doc +typeInfoToDoc topLevel t = if needParens - then "(" <> inner <> ")" + then parens inner else inner where inner = - _typeName t <> if pLength > 0 - then " " <> T.intercalate " " textParameters - else "" + then textStrict (_typeName t) <+> hsep textParameters + else textStrict (_typeName t) params = _typeParameters t pLength = length params needParens = not topLevel && pLength > 0 - textParameters = map (typeInfoToText False) params + textParameters = typeInfoToDoc False <$> params -mergedTypeInfoToText :: PSType -> Text -mergedTypeInfoToText t = _typeName t <> T.concat textParameters +mergedTypeInfoToDoc :: PSType -> Doc +mergedTypeInfoToDoc t = textStrict (_typeName t) <> hcat textParameters where params = _typeParameters t - textParameters = map mergedTypeInfoToText params + textParameters = mergedTypeInfoToDoc <$> params sumTypesToModules :: Modules -> [SumType 'PureScript] -> Modules sumTypesToModules = foldr sumTypeToModule @@ -483,7 +515,7 @@ typeToImportLines t ls = importsFromList :: [ImportLine] -> Map Text ImportLine importsFromList ls = - let pairs = zip (map importModule ls) ls + let pairs = zip (importModule <$> ls) ls merge a b = ImportLine (importModule a) (importTypes a `Set.union` importTypes b) in Map.fromListWith merge pairs diff --git a/test/Spec.hs b/test/Spec.hs index 70124dd4..d819641a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,460 +7,609 @@ {-# LANGUAGE TypeSynonymInstances #-} module Main where -import qualified Data.Map as Map -import Data.Monoid ((<>)) + +import qualified Data.Map as Map +import Data.Monoid ((<>)) import Data.Proxy -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.Bridge -import Language.PureScript.Bridge.TypeParameters import Language.PureScript.Bridge.CodeGenSwitches -import Test.Hspec (Spec, describe, - hspec, it) +import Language.PureScript.Bridge.TypeParameters +import Test.Hspec (Spec, describe, + hspec, it) import Test.Hspec.Expectations.Pretty import TestData +import Text.PrettyPrint.Leijen.Text (Doc, cat, + linebreak, + punctuate, vsep) main :: IO () main = hspec allTests - allTests :: Spec allTests = do describe "buildBridge for purescript 0.11" $ do let settings = purs_0_11_settings it "tests with Int" $ let bst = buildBridge defaultBridge (mkTypeInfo (Proxy :: Proxy Int)) - ti = TypeInfo { _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Int" - , _typeParameters = []} + ti = + TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Int" + , _typeParameters = [] + } in bst `shouldBe` ti it "tests with custom type Foo" $ let prox = Proxy :: Proxy Foo - bst = bridgeSumType (buildBridge defaultBridge) (order prox $ mkSumType prox) - st = SumType - TypeInfo { _typePackage = "" , _typeModule = "TestData" , _typeName = "Foo" , _typeParameters = [] } - [ DataConstructor { _sigConstructor = "Foo" , _sigValues = Left [] } - , DataConstructor + bst = + bridgeSumType + (buildBridge defaultBridge) + (order prox $ mkSumType prox) + st = + SumType + TypeInfo + { _typePackage = "" + , _typeModule = "TestData" + , _typeName = "Foo" + , _typeParameters = [] + } + [ DataConstructor {_sigConstructor = "Foo", _sigValues = Left []} + , DataConstructor { _sigConstructor = "Bar" - , _sigValues = Left [ TypeInfo { _typePackage = "" , _typeModule = "Prim" , _typeName = "Int" , _typeParameters = [] } ] + , _sigValues = + Left + [ TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Int" + , _typeParameters = [] + } + ] } - , DataConstructor + , DataConstructor { _sigConstructor = "FooBar" - , _sigValues = Left [ TypeInfo { _typePackage = "" , _typeModule = "Prim" , _typeName = "Int" , _typeParameters = [] } - , TypeInfo { _typePackage = "" , _typeModule = "Prim" , _typeName = "String" , _typeParameters = [] } - ] + , _sigValues = + Left + [ TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Int" + , _typeParameters = [] + } + , TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "String" + , _typeParameters = [] + } + ] } - ] - [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 - recType = bridgeSumType (buildBridge defaultBridge) (order prox $ mkSumType prox) - recTypeText = sumTypeToText settings recType - txt = T.stripEnd $ - 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" - , "" - , "--------------------------------------------------------------------------------" - , "_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 + let prox = Proxy :: Proxy Foo + recType = + bridgeSumType + (buildBridge defaultBridge) + (order prox $ mkSumType prox) + recTypeText = sumTypeToDoc 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" + , "--------------------------------------------------------------------------------" + , "_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 `shouldRender` txt it "tests the generation of a whole (dummy) module" $ - let advanced = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C))) + 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 (class Generic)" - , "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" - , "" - , "data Bar a b m c =" - , " Bar1 (Maybe a)" - , " | Bar2 (Either a b)" - , " | Bar3 a" - , " | Bar4 {" - , " myMonadicResult :: m b" - , " }" - , "" - , "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" - , " where" - , " f (Bar1 a) = Just $ a" - , " f _ = Nothing" - , "" - , "_Bar2 :: forall a b m c. Prism' (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. Prism' (Bar a b m c) a" - , "_Bar3 = prism' Bar3 f" - , " where" - , " f (Bar3 a) = Just $ a" - , " f _ = Nothing" - , "" - , "_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" - , " f _ = Nothing" - , "" - , "--------------------------------------------------------------------------------" - ] - in m `shouldBe` txt + txt = + T.unlines + [ "-- File auto generated by purescript-bridge! --" + , "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)" + , "import Data.Maybe (Maybe, Maybe(..))" + , "import Data.Newtype (class Newtype)" + , "import Data.Symbol (SProxy(SProxy))" + , "" + , "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, 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" + , " where" + , " f (Bar1 a) = Just $ a" + , " f _ = Nothing" + , "" + , "_Bar2 :: forall a b m c. Prism' (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. Prism' (Bar a b m c) a" + , "_Bar3 = prism' Bar3 f" + , " where" + , " f (Bar3 a) = Just $ a" + , " f _ = Nothing" + , "" + , "_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" + , " f _ = Nothing" + , "--------------------------------------------------------------------------------" + ] + in m `shouldBe` txt 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)) + let bar = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy (Bar A B M1 C))) + foo = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy 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" - , " where" - , " f (Bar1 a) = Just $ a" - , " f _ = Nothing" - , "" - , "_Bar2 :: forall a b m c. Prism' (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. Prism' (Bar a b m c) a" - , "_Bar3 = prism' Bar3 f" - , " where" - , " f (Bar3 a) = Just $ a" - , " f _ = Nothing" - , "" - , "_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" - , " f _ = Nothing" - , "" - , "_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 (barOptics <> fooOptics) `shouldBe` txt + txt = + T.unlines + [ "_Bar1 :: forall a b m c. Prism' (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. Prism' (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. Prism' (Bar a b m c) a" + , "_Bar3 = prism' Bar3 f" + , " where" + , " f (Bar3 a) = Just $ a" + , " f _ = Nothing" + , "" + , "_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" + , " f _ = Nothing" + , "" + , "_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 (vsep $ punctuate linebreak $ barOptics <> fooOptics) `shouldRender` + 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))) + let recType = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy (SingleRecord A B))) + bar = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy (Bar A B M1 C))) barOptics = recordOptics bar recTypeOptics = recordOptics recType - txt = T.unlines [ - "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 (barOptics <> recTypeOptics) `shouldBe` txt + txt = + T.unlines + [ "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 (cat $ punctuate linebreak $ barOptics <> recTypeOptics) `shouldRender` + 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.stripEnd $ - T.unlines [ "newtype SingleRecord a b =" - , " SingleRecord {" - , " _a :: a" - , " , _b :: b" - , " , c :: String" - , " }" - , "" - , "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 + let recType = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy (SingleRecord A B))) + recTypeText = sumTypeToDoc settings recType + txt = + T.unlines + [ "newtype SingleRecord a b" + , " = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "" + , "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 `shouldRender` txt it "tests generation of newtypes for haskell newtype" $ - let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy SomeNewtype)) - recTypeText = sumTypeToText settings 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 + let recType = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy SomeNewtype)) + recTypeText = sumTypeToDoc settings recType + txt = + T.unlines + [ "newtype SomeNewtype" + , " = SomeNewtype Int" + , "" + , "" + , "derive instance genericSomeNewtype :: Generic SomeNewtype" + , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" + , "--------------------------------------------------------------------------------" + , "_SomeNewtype :: Iso' SomeNewtype Int" + , "_SomeNewtype = _Newtype" + , "--------------------------------------------------------------------------------" + ] + in recTypeText `shouldRender` 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.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 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.stripEnd $ - T.unlines [ "data SingleProduct =" - , " SingleProduct String Int" - , "" - , "derive instance genericSingleProduct :: Generic SingleProduct" - , "" - , "--------------------------------------------------------------------------------" - , "_SingleProduct :: Prism' SingleProduct { a :: String, b :: Int }" - , "_SingleProduct = prism' (\\{ a, b } -> SingleProduct a b) f" - , " where" - , " f (SingleProduct a b) = Just $ { a: a, b: b }" - , "" - , "--------------------------------------------------------------------------------" - ] - 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)) + let recType = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy SingleValueConstr)) + recTypeText = sumTypeToDoc settings recType + txt = + T.unlines + [ "newtype SingleValueConstr" + , " = SingleValueConstr Int" + , "" + , "" + , "derive instance genericSingleValueConstr :: Generic SingleValueConstr" + , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" + , "--------------------------------------------------------------------------------" + , "_SingleValueConstr :: Iso' SingleValueConstr Int" + , "_SingleValueConstr = _Newtype" + , "--------------------------------------------------------------------------------" + ] + in recTypeText `shouldRender` txt + it + "tests generation for haskell data type with one constructor, two arguments" $ + let recType = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy SingleProduct)) + recTypeText = sumTypeToDoc settings recType + txt = + T.unlines + [ "data SingleProduct" + , " = SingleProduct String Int" + , "" + , "" + , "derive instance genericSingleProduct :: Generic SingleProduct" + , "--------------------------------------------------------------------------------" + , "_SingleProduct :: Prism' SingleProduct { a :: String, b :: Int }" + , "_SingleProduct = prism' (\\{ a, b } -> SingleProduct a b) f" + , " where" + , " f (SingleProduct a b) = Just $ { a: a, b: b }" + , "--------------------------------------------------------------------------------" + ] + in recTypeText `shouldRender` 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 - + in vsep recTypeOptics `shouldRender` "" -- No record optics for multi-constructors 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) - 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 + recType = + bridgeSumType + (buildBridge defaultBridge) + (order proxy $ mkSumType proxy) + recTypeText = sumTypeToDoc 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 `shouldRender` txt it "tests the generation of a whole (dummy) module" $ - let advanced' = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C))) + 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 (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, Generic b, Generic (m b)) => Generic (Bar a b m c)" - , "" - ] - in m `shouldBe` txt + txt = + T.unlines + [ "-- File auto generated by purescript-bridge! --" + , "module TestData where" + , "" + , "import Data.Either (Either)" + , "import Data.Generic (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, Generic b, Generic (m b)) => 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, Generic b) => Generic (SingleRecord a b)" - , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" - ] - in recTypeText `shouldBe` txt + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy (SingleRecord A B))) + recTypeText = sumTypeToDoc settings recType' + txt = + T.unlines + [ "newtype SingleRecord a b" + , " = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "" + , "derive instance genericSingleRecord :: (Generic a, Generic b) => Generic (SingleRecord a b)" + , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + ] + in recTypeText `shouldRender` 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 + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy SomeNewtype)) + recTypeText = sumTypeToDoc settings recType' + txt = + T.unlines + [ "newtype SomeNewtype" + , " = SomeNewtype Int" + , "" + , "" + , "derive instance genericSomeNewtype :: Generic SomeNewtype" + , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" + ] + in recTypeText `shouldRender` 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 - - + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy SingleValueConstr)) + recTypeText = sumTypeToDoc settings recType' + txt = + T.unlines + [ "newtype SingleValueConstr" + , " = SingleValueConstr Int" + , "" + , "" + , "derive instance genericSingleValueConstr :: Generic SingleValueConstr" + , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" + ] + in recTypeText `shouldRender` txt + it + "tests generation for haskell data type with one constructor, two arguments" $ + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy SingleProduct)) + recTypeText = sumTypeToDoc settings recType' + txt = + T.unlines + [ "data SingleProduct" + , " = SingleProduct String Int" + , "" + , "" + , "derive instance genericSingleProduct :: Generic SingleProduct" + ] + in recTypeText `shouldRender` 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 + recType = + bridgeSumType + (buildBridge defaultBridge) + (order proxy $ mkSumType proxy) + recTypeText = sumTypeToDoc 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 `shouldRender` txt it "tests the generation of a whole (dummy) module" $ - let advanced' = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C))) + 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 + 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 + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy (SingleRecord A B))) + recTypeText = sumTypeToDoc 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 `shouldRender` 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 + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy SomeNewtype)) + recTypeText = sumTypeToDoc settings recType' + txt = + T.unlines + [ "newtype SomeNewtype" + , " = SomeNewtype Int" + , "" + , "" + , "derive instance genericSomeNewtype :: Generic SomeNewtype _" + , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" + ] + in recTypeText `shouldRender` 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 - + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy SingleValueConstr)) + recTypeText = sumTypeToDoc settings recType' + txt = + T.unlines + [ "newtype SingleValueConstr" + , " = SingleValueConstr Int" + , "" + , "" + , "derive instance genericSingleValueConstr :: Generic SingleValueConstr _" + , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" + ] + in recTypeText `shouldRender` txt + it + "tests generation for haskell data type with one constructor, two arguments" $ + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType (Proxy :: Proxy SingleProduct)) + recTypeText = sumTypeToDoc settings recType' + txt = + T.unlines + [ "data SingleProduct" + , " = SingleProduct String Int" + , "" + , "" + , "derive instance genericSingleProduct :: Generic SingleProduct _" + ] + in recTypeText `shouldRender` txt + +shouldRender :: Doc -> Text -> Expectation +shouldRender actual expected = renderText actual `shouldBe` T.stripEnd expected From d9bf17a1ebae0f30ee95987b56af251ec1bc291a Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Tue, 21 May 2019 12:57:57 +0100 Subject: [PATCH 006/111] Bugfix for Encode/Decode constraints. For generic decoding, `Decode (Foo a)` needs a `Decode a` constraint, but it *doesn't* need a `Generic a` constraint. Adding in this unnecessary constraint creates needless problems like, "there isn't an instance for `Generic String _`." --- src/Language/PureScript/Bridge/Printer.hs | 22 ++++------------------ 1 file changed, 4 insertions(+), 18 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 8bf24c25..c67bd9ce 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -204,11 +204,10 @@ instances settings st@(SumType t _ is) = go <$> is extras | stpLength == 0 = mempty | otherwise = - constraintsInner (instanceBody <$> sumTypeParameters) <+> "=> " + constraintsInner (instanceConstraints <$> sumTypeParameters) <+> "=> " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceBody params = - genericInstance settings params <> comma <+> encodeInstance params + instanceConstraints params = encodeInstance params go Decode = "instance decode" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Decode" <+> @@ -223,37 +222,24 @@ instances settings st@(SumType t _ is) = go <$> is extras | stpLength == 0 = mempty | otherwise = - constraintsInner (instanceBody <$> sumTypeParameters) <+> "=> " + constraintsInner (instanceConstraints <$> sumTypeParameters) <+> "=> " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceBody params = - genericInstance settings params <> ", " <> decodeInstance params + instanceConstraints params = decodeInstance params go i = "derive instance " <> textStrict (T.toLower c) <> textStrict (_typeName t) <+> "::" <+> - extras i <> textStrict c <+> typeInfoToDoc False t <> postfix i where c = T.pack $ show i - extras Generic - | stpLength == 0 = mempty - | stpLength == 1 = genericConstraintsInner <+> text "=> " - | otherwise = parens genericConstraintsInner <+> text "=> " - extras _ = "" postfix Newtype = " _" postfix Generic | Switches.genericsGenRep settings = " _" | otherwise = "" postfix _ = "" - stpLength = length sumTypeParameters - sumTypeParameters = - filter (isTypeParam t) . Set.toList $ getUsedTypes st - genericConstraintsInner = - hsep $ - punctuate (text ",") (genericInstance settings <$> sumTypeParameters) recordUpdateDoc :: [(Doc, Doc)] -> Doc recordUpdateDoc = recordFields . fmap recordUpdateItem From 8eace905c25159877f46608e8dd2d8f5f780e1ba Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Wed, 22 May 2019 14:35:43 +0100 Subject: [PATCH 007/111] Bugfix for decode/encode instances on recursive types. PureScript isn't happy with eta-reduced typeclass instances on recursive types. We have to make the function application explicit. --- src/Language/PureScript/Bridge/Printer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index c67bd9ce..baa7e361 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -198,7 +198,7 @@ instances settings st@(SumType t _ is) = go <$> is linebreak <> indent 2 - ("encode = genericEncode" <+> parens ("defaultOptions" <+> align (jsonOpts settings))) + ("encode value = genericEncode" <+> parens ("defaultOptions" <+> align (jsonOpts settings)) <+> "value") where stpLength = length sumTypeParameters extras @@ -216,7 +216,7 @@ instances settings st@(SumType t _ is) = go <$> is linebreak <> indent 2 - ("decode = genericDecode" <+> parens ("defaultOptions" <+> align (jsonOpts settings))) + ("decode value = genericDecode" <+> parens ("defaultOptions" <+> align (jsonOpts settings)) <+> "value") where stpLength = length sumTypeParameters extras From 4ef961c16d0a32c209a4d169ee5e3a615d1b3498 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 23 May 2019 13:22:13 +0100 Subject: [PATCH 008/111] You can now generate `Eq` instances for something like `Proxy :: Proxy (Container A)`. The generated code will include an `Eq a =>` constraint. --- src/Language/PureScript/Bridge/Printer.hs | 19 ++++++++++++++++++- .../PureScript/Bridge/TypeParameters.hs | 3 +++ 2 files changed, 21 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index baa7e361..268c6269 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.SumType (DataConstructor (DataConstructor), - Instance (Decode, Encode, Generic, Newtype), + Instance (Decode, Encode, Eq, Generic, Newtype), RecordEntry (RecordEntry), SumType (SumType), getUsedTypes, @@ -226,6 +226,20 @@ instances settings st@(SumType t _ is) = go <$> is sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints params = decodeInstance params + go Eq = + "derive instance eq" <> textStrict (_typeName t) <+> "::" <+> extras <+> + "Eq" <+> + typeInfoToDoc False t + where + stpLength = length sumTypeParameters + extras + | stpLength == 0 = mempty + | otherwise = + constraintsInner (instanceConstraints <$> sumTypeParameters) <+> + "=> " + sumTypeParameters = + filter (isTypeParam t) . Set.toList $ getUsedTypes st + instanceConstraints params = eqInstance params go i = "derive instance " <> textStrict (T.toLower c) <> textStrict (_typeName t) <+> @@ -271,6 +285,9 @@ encodeInstance params = "Encode" <+> typeInfoToDoc False params decodeInstance :: PSType -> Doc decodeInstance params = "Decode" <+> typeInfoToDoc False params +eqInstance :: PSType -> Doc +eqInstance params = "Eq" <+> typeInfoToDoc False params + genericInstance :: Switches.Settings -> PSType -> Doc genericInstance settings params = if not (Switches.genericsGenRep settings) diff --git a/src/Language/PureScript/Bridge/TypeParameters.hs b/src/Language/PureScript/Bridge/TypeParameters.hs index 0f032dc2..d01d56d7 100644 --- a/src/Language/PureScript/Bridge/TypeParameters.hs +++ b/src/Language/PureScript/Bridge/TypeParameters.hs @@ -22,6 +22,9 @@ module Language.PureScript.Bridge.TypeParameters where data A +instance Eq A where + _ == _ = True + data B data C From 05b5b62ec0f976ceae3b337b9f7f116feca8c910 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 23 May 2019 13:22:44 +0100 Subject: [PATCH 009/111] Whitespace changes. --- src/Language/PureScript/Bridge/Printer.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 268c6269..285063ac 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -198,13 +198,16 @@ instances settings st@(SumType t _ is) = go <$> is linebreak <> indent 2 - ("encode value = genericEncode" <+> parens ("defaultOptions" <+> align (jsonOpts settings)) <+> "value") + ("encode value = genericEncode" <+> + parens ("defaultOptions" <+> align (jsonOpts settings)) <+> + "value") where stpLength = length sumTypeParameters extras | stpLength == 0 = mempty | otherwise = - constraintsInner (instanceConstraints <$> sumTypeParameters) <+> "=> " + constraintsInner (instanceConstraints <$> sumTypeParameters) <+> + "=> " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints params = encodeInstance params @@ -216,13 +219,16 @@ instances settings st@(SumType t _ is) = go <$> is linebreak <> indent 2 - ("decode value = genericDecode" <+> parens ("defaultOptions" <+> align (jsonOpts settings)) <+> "value") + ("decode value = genericDecode" <+> + parens ("defaultOptions" <+> align (jsonOpts settings)) <+> + "value") where stpLength = length sumTypeParameters extras | stpLength == 0 = mempty | otherwise = - constraintsInner (instanceConstraints <$> sumTypeParameters) <+> "=> " + constraintsInner (instanceConstraints <$> sumTypeParameters) <+> + "=> " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints params = decodeInstance params @@ -241,8 +247,7 @@ instances settings st@(SumType t _ is) = go <$> is filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints params = eqInstance params go i = - "derive instance " <> textStrict (T.toLower c) <> - textStrict (_typeName t) <+> + "derive instance " <> textStrict (T.toLower c) <> textStrict (_typeName t) <+> "::" <+> textStrict c <+> typeInfoToDoc False t <> From 72fbe2dfd6888ace97a8dedf7b353e6da6c6a4d7 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 23 May 2019 13:22:49 +0100 Subject: [PATCH 010/111] You can now generate a `Show` instance based on `genericShow`. --- src/Language/PureScript/Bridge/Printer.hs | 12 ++++++++++-- src/Language/PureScript/Bridge/SumType.hs | 6 ++++++ 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 285063ac..df02c35d 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.SumType (DataConstructor (DataConstructor), - Instance (Decode, Encode, Eq, Generic, Newtype), + Instance (Decode, Encode, Eq, Generic, GenericShow, Newtype), RecordEntry (RecordEntry), SumType (SumType), getUsedTypes, @@ -115,7 +115,9 @@ moduleToText settings m = _genericsImports :: Switches.Settings -> [ImportLine] _genericsImports settings | Switches.genericsGenRep settings = - [ImportLine "Data.Generic.Rep" $ Set.fromList ["class Generic"]] + [ ImportLine "Data.Generic.Rep" $ Set.fromList ["class Generic"] + , ImportLine "Data.Generic.Rep.Show" $ Set.fromList ["genericShow"] + ] | otherwise = [ImportLine "Data.Generic" $ Set.fromList ["class Generic"]] _lensImports :: Switches.Settings -> [ImportLine] @@ -232,6 +234,12 @@ instances settings st@(SumType t _ is) = go <$> is sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints params = decodeInstance params + go GenericShow = + "instance show" <> textStrict (_typeName t) <+> "::" <+> "Show" <+> + typeInfoToDoc False t <+> + "where" <> + linebreak <> + indent 2 ("show = genericShow") go Eq = "derive instance eq" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Eq" <+> diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index b25d50e2..855d8417 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -11,6 +11,7 @@ module Language.PureScript.Bridge.SumType ( SumType(..) , mkSumType + , genericShow , equal , order , DataConstructor(..) @@ -83,6 +84,7 @@ data Instance = Encode | Decode | Generic + | GenericShow | Newtype | Eq | Ord @@ -101,6 +103,10 @@ nootype cs = isSingletonList [_] = True isSingletonList _ = False +-- | Ensure that a generic `Show` instance is generated for your type. +genericShow :: Proxy a -> SumType t -> SumType t +genericShow _ (SumType ti dc is) = SumType ti dc . nub $ GenericShow : is + -- | Ensure that an `Eq` instance is generated for your type. equal :: Eq a => Proxy a -> SumType t -> SumType t equal _ (SumType ti dc is) = SumType ti dc . nub $ Eq : is From a7069a515800135ce932742e995f3a96bc1c7129 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 24 May 2019 10:01:07 +0100 Subject: [PATCH 011/111] Aeson-compatible encodings for Enums*. * Sum types where every constructor has zero arguments. Aeson has special handling for these. --- src/Language/PureScript/Bridge/Printer.hs | 33 +++++++++++++++-------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index df02c35d..356daf17 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -142,6 +142,9 @@ _foreignImports settings [ ImportLine "Foreign.Generic" $ Set.fromList ["defaultOptions", "genericDecode", "genericEncode", "aesonSumEncoding"] + , ImportLine "Foreign.Generic.EnumEncoding" $ + Set.fromList + ["defaultGenericEnumOptions", "genericDecodeEnum", "genericEncodeEnum"] , ImportLine "Foreign.Class" $ Set.fromList ["class Decode", "class Encode"] ] | otherwise = [] @@ -189,7 +192,7 @@ sumTypeToTypeDecls settings (SumType t cs is) = -- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. instances :: Switches.Settings -> SumType 'PureScript -> [Doc] -instances settings st@(SumType t _ is) = go <$> is +instances settings st@(SumType t cs is) = go <$> is where go :: Instance -> Doc go Encode = @@ -198,12 +201,15 @@ instances settings st@(SumType t _ is) = go <$> is typeInfoToDoc False t <+> "where" <> linebreak <> - indent - 2 - ("encode value = genericEncode" <+> - parens ("defaultOptions" <+> align (jsonOpts settings)) <+> - "value") + indent 2 encodeInstanceBody where + encodeInstanceBody = + "encode value =" <+> + (if isEnum + then "genericEncodeEnum defaultGenericEnumOptions value" + else "genericEncode" <+> + parens ("defaultOptions" <+> align (jsonOpts settings)) <+> + "value") stpLength = length sumTypeParameters extras | stpLength == 0 = mempty @@ -219,12 +225,15 @@ instances settings st@(SumType t _ is) = go <$> is typeInfoToDoc False t <+> "where" <> linebreak <> - indent - 2 - ("decode value = genericDecode" <+> - parens ("defaultOptions" <+> align (jsonOpts settings)) <+> - "value") + indent 2 decodeInstanceBody where + decodeInstanceBody = + "decode value =" <+> + (if isEnum + then "genericDecodeEnum defaultGenericEnumOptions value" + else ("genericDecode" <+> + parens ("defaultOptions" <+> align (jsonOpts settings)) <+> + "value")) stpLength = length sumTypeParameters extras | stpLength == 0 = mempty @@ -267,6 +276,8 @@ instances settings st@(SumType t _ is) = go <$> is | Switches.genericsGenRep settings = " _" | otherwise = "" postfix _ = "" + isEnum = all isNoArgConstructor cs + isNoArgConstructor c = (c ^. sigValues) == Left [] recordUpdateDoc :: [(Doc, Doc)] -> Doc recordUpdateDoc = recordFields . fmap recordUpdateItem From 02bd0994bbf88e42b9052cdc040721dd52b8efc0 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Tue, 21 May 2019 12:57:57 +0100 Subject: [PATCH 012/111] Bugfix for Encode/Decode constraints. For generic decoding, `Decode (Foo a)` needs a `Decode a` constraint, but it *doesn't* need a `Generic a` constraint. Adding in this unnecessary constraint creates needless problems like, "there isn't an instance for `Generic String _`." --- test/Spec.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index d819641a..fa572203 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -160,7 +160,7 @@ allTests = do , " }" , "" , "" - , "derive instance genericBar :: (Generic a, Generic b, Generic (m b)) => Generic (Bar a b m c)" + , "derive instance genericBar :: Generic (Bar a b m c)" , "--------------------------------------------------------------------------------" , "_Bar1 :: forall a b m c. Prism' (Bar a b m c) (Maybe a)" , "_Bar1 = prism' Bar1 f" @@ -282,7 +282,7 @@ allTests = do , " }" , "" , "" - , "derive instance genericSingleRecord :: (Generic a, Generic b) => Generic (SingleRecord a b)" + , "derive instance genericSingleRecord :: Generic (SingleRecord a b)" , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" , "--------------------------------------------------------------------------------" , "_SingleRecord :: forall a b. Iso' (SingleRecord a b) { _a :: a" @@ -418,7 +418,7 @@ allTests = do , " }" , "" , "" - , "derive instance genericBar :: (Generic a, Generic b, Generic (m b)) => Generic (Bar a b m c)" + , "derive instance genericBar :: Generic (Bar a b m c)" ] in m `shouldBe` txt it "tests generation of newtypes for record data type" $ @@ -437,7 +437,7 @@ allTests = do , " }" , "" , "" - , "derive instance genericSingleRecord :: (Generic a, Generic b) => Generic (SingleRecord a b)" + , "derive instance genericSingleRecord :: Generic (SingleRecord a b)" , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" ] in recTypeText `shouldRender` txt @@ -539,7 +539,7 @@ allTests = do , " }" , "" , "" - , "derive instance genericBar :: (Generic a ra, Generic b rb, Generic (m b) rmb) => Generic (Bar a b m c) _" + , "derive instance genericBar :: Generic (Bar a b m c) _" ] in m `shouldBe` txt it "tests generation of newtypes for record data type" $ @@ -558,7 +558,7 @@ allTests = do , " }" , "" , "" - , "derive instance genericSingleRecord :: (Generic a ra, Generic b rb) => Generic (SingleRecord a b) _" + , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" ] in recTypeText `shouldRender` txt From de2574e81fdff461117cc990f7c5cb40fabffa7d Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 23 May 2019 13:22:49 +0100 Subject: [PATCH 013/111] You can now generate a `Show` instance based on `genericShow`. --- test/Spec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Spec.hs b/test/Spec.hs index fa572203..b761113c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -525,6 +525,7 @@ allTests = do , "" , "import Data.Either (Either)" , "import Data.Generic.Rep (class Generic)" + , "import Data.Generic.Rep.Show (genericShow)" , "import Data.Maybe (Maybe, Maybe(..))" , "import Data.Newtype (class Newtype)" , "" From b310e6a3b154d532a26d3e5ac9e1b319be68309f Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 20 Sep 2019 09:42:19 +0100 Subject: [PATCH 014/111] Applying hlint suggestions. --- src/Language/PureScript/Bridge/Printer.hs | 14 +++++++------- test/Spec.hs | 5 ++--- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 356daf17..147b9e6e 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -218,7 +218,7 @@ instances settings st@(SumType t cs is) = go <$> is "=> " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceConstraints params = encodeInstance params + instanceConstraints = encodeInstance go Decode = "instance decode" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Decode" <+> @@ -242,13 +242,13 @@ instances settings st@(SumType t cs is) = go <$> is "=> " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceConstraints params = decodeInstance params + instanceConstraints = decodeInstance go GenericShow = "instance show" <> textStrict (_typeName t) <+> "::" <+> "Show" <+> typeInfoToDoc False t <+> "where" <> linebreak <> - indent 2 ("show = genericShow") + indent 2 "show = genericShow" go Eq = "derive instance eq" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Eq" <+> @@ -262,7 +262,7 @@ instances settings st@(SumType t cs is) = go <$> is "=> " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceConstraints params = eqInstance params + instanceConstraints = eqInstance go i = "derive instance " <> textStrict (T.toLower c) <> textStrict (_typeName t) <+> "::" <+> @@ -361,7 +361,7 @@ encloseVsep left right sp ds = case ds of [] -> left <> right [d] -> left <> d <> right - _ -> (vsep (zipWith (<>) (left : repeat sp) ds) <> right) + _ -> vsep (zipWith (<>) (left : repeat sp) ds) <> right typeNameAndForall :: TypeInfo 'PureScript -> (Doc, Doc) typeNameAndForall typeInfo = (typName, forAll) @@ -424,9 +424,9 @@ constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = | length cs == 1 = textStrict n | otherwise = parens - ("\\{" <+> (cat $ punctuate (", ") cArgs) <+> "} ->" <+> + ("\\{" <+> cat (punctuate ", " cArgs) <+> "} ->" <+> textStrict n <+> - (cat $ punctuate space cArgs)) + cat (punctuate space cArgs)) where cArgs = textStrict . T.singleton . fst <$> zip ['a' ..] cs types = constructorTypes cs diff --git a/test/Spec.hs b/test/Spec.hs index b761113c..14aa846e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,7 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} module Main where @@ -243,7 +242,7 @@ allTests = do , " f (FooBar a b) = Just $ { a: a, b: b }" , " f _ = Nothing" ] - in (vsep $ punctuate linebreak $ barOptics <> fooOptics) `shouldRender` + in vsep (punctuate linebreak $ barOptics <> fooOptics) `shouldRender` txt it "tests generation of record optics" $ let recType = @@ -264,7 +263,7 @@ allTests = do , "b :: forall a b. Lens' (SingleRecord a b) b" , "b = _Newtype <<< prop (SProxy :: SProxy \"_b\")" ] - in (cat $ punctuate linebreak $ barOptics <> recTypeOptics) `shouldRender` + in cat (punctuate linebreak $ barOptics <> recTypeOptics) `shouldRender` txt it "tests generation of newtypes for record data type" $ let recType = From 1fc332ded17262db904890e2e3d6a3a2f58cc6f4 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 20 Sep 2019 09:54:11 +0100 Subject: [PATCH 015/111] You can now generate `Ord` instances for something like `Proxy :: Proxy (Container A)`. The generated code will include an `Ord a =>` constraint. --- src/Language/PureScript/Bridge/Printer.hs | 25 +++++++-- .../PureScript/Bridge/TypeParameters.hs | 56 +++++++++---------- test/Spec.hs | 43 ++++++++++++++ test/TestData.hs | 2 +- 4 files changed, 92 insertions(+), 34 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 147b9e6e..e6dd1604 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.SumType (DataConstructor (DataConstructor), - Instance (Decode, Encode, Eq, Generic, GenericShow, Newtype), + Instance (Decode, Encode, Eq,Ord, Generic, GenericShow, Newtype), RecordEntry (RecordEntry), SumType (SumType), getUsedTypes, @@ -215,7 +215,7 @@ instances settings st@(SumType t cs is) = go <$> is | stpLength == 0 = mempty | otherwise = constraintsInner (instanceConstraints <$> sumTypeParameters) <+> - "=> " + "=>" sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints = encodeInstance @@ -239,7 +239,7 @@ instances settings st@(SumType t cs is) = go <$> is | stpLength == 0 = mempty | otherwise = constraintsInner (instanceConstraints <$> sumTypeParameters) <+> - "=> " + "=>" sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints = decodeInstance @@ -259,10 +259,24 @@ instances settings st@(SumType t cs is) = go <$> is | stpLength == 0 = mempty | otherwise = constraintsInner (instanceConstraints <$> sumTypeParameters) <+> - "=> " + "=>" sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints = eqInstance + go Ord = + "derive instance ord" <> textStrict (_typeName t) <+> "::" <+> extras <+> + "Ord" <+> + typeInfoToDoc False t + where + stpLength = length sumTypeParameters + extras + | stpLength == 0 = mempty + | otherwise = + constraintsInner (instanceConstraints <$> sumTypeParameters) <+> + "=>" + sumTypeParameters = + filter (isTypeParam t) . Set.toList $ getUsedTypes st + instanceConstraints = ordInstance go i = "derive instance " <> textStrict (T.toLower c) <> textStrict (_typeName t) <+> "::" <+> @@ -312,6 +326,9 @@ decodeInstance params = "Decode" <+> typeInfoToDoc False params eqInstance :: PSType -> Doc eqInstance params = "Eq" <+> typeInfoToDoc False params +ordInstance :: PSType -> Doc +ordInstance params = "Ord" <+> typeInfoToDoc False params + genericInstance :: Switches.Settings -> PSType -> Doc genericInstance settings params = if not (Switches.genericsGenRep settings) diff --git a/src/Language/PureScript/Bridge/TypeParameters.hs b/src/Language/PureScript/Bridge/TypeParameters.hs index d01d56d7..a931578e 100644 --- a/src/Language/PureScript/Bridge/TypeParameters.hs +++ b/src/Language/PureScript/Bridge/TypeParameters.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE EmptyDataDeriving #-} -- | As we translate types and not type constructors, we have to pass dummy types -- to any type constructor. -- @@ -20,60 +21,57 @@ -- @ module Language.PureScript.Bridge.TypeParameters where -data A +data A deriving (Eq, Ord) -instance Eq A where - _ == _ = True +data B deriving (Eq, Ord) -data B +data C deriving (Eq, Ord) -data C +data D deriving (Eq, Ord) -data D +data E deriving (Eq, Ord) -data E +data F deriving (Eq, Ord) -data F +data G deriving (Eq, Ord) -data G +data H deriving (Eq, Ord) -data H +data I deriving (Eq, Ord) -data I +data J deriving (Eq, Ord) -data J +data K deriving (Eq, Ord) -data K +data L deriving (Eq, Ord) -data L +data M deriving (Eq, Ord) -data M +data N deriving (Eq, Ord) -data N +data O deriving (Eq, Ord) -data O +data P deriving (Eq, Ord) -data P +data Q deriving (Eq, Ord) -data Q +data R deriving (Eq, Ord) -data R +data S deriving (Eq, Ord) -data S +data T deriving (Eq, Ord) -data T +data U deriving (Eq, Ord) -data U +data V deriving (Eq, Ord) -data V +data W deriving (Eq, Ord) -data W +data X deriving (Eq, Ord) -data X +data Y deriving (Eq, Ord) -data Y - -data Z +data Z deriving (Eq, Ord) -- | You can use those if your type parameters are actually type constructors as well: -- @ diff --git a/test/Spec.hs b/test/Spec.hs index 14aa846e..8532fede 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -610,6 +610,49 @@ allTests = do , "derive instance genericSingleProduct :: Generic SingleProduct _" ] in recTypeText `shouldRender` txt + it "tests generation Eq instances for polymorphic types" $ + let recType' = + bridgeSumType + (buildBridge defaultBridge) + ((equal <*> mkSumType) (Proxy :: Proxy (SingleRecord A B))) + recTypeText = sumTypeToDoc settings recType' + txt = + T.unlines + [ "newtype SingleRecord a b" + , " = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "" + , "derive instance eqSingleRecord :: (Eq a, Eq b) => Eq (SingleRecord a b)" + , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" + , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + ] + in recTypeText `shouldRender` txt + it "tests generation Ord instances for polymorphic types" $ + let recType' = + bridgeSumType + (buildBridge defaultBridge) + ((order <*> mkSumType) (Proxy :: Proxy (SingleRecord A B))) + recTypeText = sumTypeToDoc settings recType' + txt = + T.unlines + [ "newtype SingleRecord a b" + , " = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "" + , "derive instance eqSingleRecord :: (Eq a, Eq b) => Eq (SingleRecord a b)" + , "derive instance ordSingleRecord :: (Ord a, Ord b) => Ord (SingleRecord a b)" + , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" + , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + ] + in recTypeText `shouldRender` txt shouldRender :: Doc -> Text -> Expectation shouldRender actual expected = renderText actual `shouldBe` T.stripEnd expected diff --git a/test/TestData.hs b/test/TestData.hs index 4f567677..0893b2f7 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -48,7 +48,7 @@ data SingleRecord a b = SingleRecord { _a :: a , _b :: b , c :: String - } deriving(Generic, Typeable, Show) + } deriving(Generic, Eq, Ord, Typeable, Show) data TwoRecords = FirstRecord { From e68e46de7fbf326d32d19bb2bb2e6fc1314d5def Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 11 Jul 2019 12:31:06 +0100 Subject: [PATCH 016/111] Bugfix for genericShow. It turns out you can't eta-reduce typeclass instances for recursively-defined typeclasses in PureScript. That is: `show = genericShow` ...has to be replaced with: `show x = genericShow` ...to work reliably. See: https://github.com/purescript/purescript/issues/2975 --- src/Language/PureScript/Bridge/Printer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index e6dd1604..8cfb6543 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -248,7 +248,7 @@ instances settings st@(SumType t cs is) = go <$> is typeInfoToDoc False t <+> "where" <> linebreak <> - indent 2 "show = genericShow" + indent 2 "show x = genericShow x" go Eq = "derive instance eq" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Eq" <+> From 1e7ca3d39e88c8ae1894ae0fa550468b3ad68fe5 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 2 Aug 2019 15:20:13 +0100 Subject: [PATCH 017/111] genericShow now supports parameterised types. That is, `(genericShow <*> mkSumType) (Proxy @(Foo A))` will generate: ``` instance showFoo :: Show a => Show (Foo a) where show = genericShow ``` ...whereas before it would have missed out the `Show a` constraint. --- src/Language/PureScript/Bridge/Printer.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 8cfb6543..a243f098 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -244,11 +244,21 @@ instances settings st@(SumType t cs is) = go <$> is filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints = decodeInstance go GenericShow = - "instance show" <> textStrict (_typeName t) <+> "::" <+> "Show" <+> + "instance show" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Show" <+> typeInfoToDoc False t <+> "where" <> linebreak <> indent 2 "show x = genericShow x" + where + stpLength = length sumTypeParameters + extras + | stpLength == 0 = mempty + | otherwise = + constraintsInner (instanceConstraints <$> sumTypeParameters) <+> + "=> " + sumTypeParameters = + filter (isTypeParam t) . Set.toList $ getUsedTypes st + instanceConstraints params = showInstance params go Eq = "derive instance eq" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Eq" <+> @@ -329,6 +339,9 @@ eqInstance params = "Eq" <+> typeInfoToDoc False params ordInstance :: PSType -> Doc ordInstance params = "Ord" <+> typeInfoToDoc False params +showInstance :: PSType -> Doc +showInstance params = "Show" <+> typeInfoToDoc False params + genericInstance :: Switches.Settings -> PSType -> Doc genericInstance settings params = if not (Switches.genericsGenRep settings) From 5e25608ddccf3e8cd62ccdb12c0f41ee88675e58 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 9 Aug 2019 18:17:48 +0100 Subject: [PATCH 018/111] Adding Functor support. --- src/Language/PureScript/Bridge/Printer.hs | 8 ++++++-- src/Language/PureScript/Bridge/SumType.hs | 7 +++++++ test/Spec.hs | 25 +++++++++++++++++++++-- test/TestData.hs | 4 ++++ 4 files changed, 40 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index a243f098..a18aa382 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.SumType (DataConstructor (DataConstructor), - Instance (Decode, Encode, Eq,Ord, Generic, GenericShow, Newtype), + Instance (Decode, Encode, Eq, Ord, Functor, Generic, GenericShow, Newtype), RecordEntry (RecordEntry), SumType (SumType), getUsedTypes, @@ -255,10 +255,14 @@ instances settings st@(SumType t cs is) = go <$> is | stpLength == 0 = mempty | otherwise = constraintsInner (instanceConstraints <$> sumTypeParameters) <+> - "=> " + "=>" sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints params = showInstance params + go Functor = + "derive instance functor" <> name <+> "::" <+> "Functor" <+> name + where + name = textStrict (_typeName t) go Eq = "derive instance eq" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Eq" <+> diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 855d8417..9427be83 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -12,6 +12,7 @@ module Language.PureScript.Bridge.SumType ( SumType(..) , mkSumType , genericShow + , functor , equal , order , DataConstructor(..) @@ -86,6 +87,7 @@ data Instance | Generic | GenericShow | Newtype + | Functor | Eq | Ord deriving (Eq, Show) @@ -107,6 +109,11 @@ nootype cs = genericShow :: Proxy a -> SumType t -> SumType t genericShow _ (SumType ti dc is) = SumType ti dc . nub $ GenericShow : is +-- | Ensure that a functor instance is generated for your type. It it +-- your responsibility to ensure your type is a functor. +functor :: Proxy a -> SumType t -> SumType t +functor _ (SumType ti dc is) = SumType ti dc . nub $ Functor : is + -- | Ensure that an `Eq` instance is generated for your type. equal :: Eq a => Proxy a -> SumType t -> SumType t equal _ (SumType ti dc is) = SumType ti dc . nub $ Eq : is diff --git a/test/Spec.hs b/test/Spec.hs index 8532fede..2dc21490 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -490,12 +490,12 @@ allTests = do in recTypeText `shouldRender` txt describe "buildBridge without lens-code-gen and generics-rep" $ do let settings = getSettings (noLenses <> useGenRep) - it "tests generation of for custom type Foo" $ + it "tests generation of typeclasses for custom type Foo" $ let proxy = Proxy :: Proxy Foo recType = bridgeSumType (buildBridge defaultBridge) - (order proxy $ mkSumType proxy) + (genericShow proxy $ order proxy $ mkSumType proxy) recTypeText = sumTypeToDoc settings recType txt = T.unlines @@ -505,11 +505,32 @@ allTests = do , " | FooBar Int String" , "" , "" + , "instance showFoo :: Show Foo where" + , " show x = genericShow x" , "derive instance eqFoo :: Eq Foo" , "derive instance ordFoo :: Ord Foo" , "derive instance genericFoo :: Generic Foo _" ] in recTypeText `shouldRender` txt + it "tests generation of typeclasses for custom type Func" $ + let proxy = Proxy :: Proxy (Func A) + recType = + bridgeSumType + (buildBridge defaultBridge) + (functor proxy $ genericShow proxy $ mkSumType proxy) + recTypeText = sumTypeToDoc settings recType + txt = + T.unlines + [ "data Func a" + , " = Func Int a" + , "" + , "" + , "derive instance functorFunc :: Functor Func" + , "instance showFunc :: (Show a) => Show (Func a) where" + , " show x = genericShow x" + , "derive instance genericFunc :: Generic (Func a) _" + ] + in recTypeText `shouldRender` txt it "tests the generation of a whole (dummy) module" $ let advanced' = bridgeSumType diff --git a/test/TestData.hs b/test/TestData.hs index 0893b2f7..223d84fd 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -35,6 +36,9 @@ data Foo = Foo | FooBar Int Text deriving (Eq, Ord, Generic, Typeable, Show) +data Func a = Func Int a + deriving (Eq, Ord, Functor, Generic, Typeable, Show) + data Test = TestIntInt Int Int | TestBool {bool :: Bool} | TestVoid From 0c3dd2662b7e2d5ffa7522c3b835b63e2f68c32b Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 13 Sep 2019 12:11:39 +0100 Subject: [PATCH 019/111] fix haddock --- src/Language/PureScript/Bridge/Builder.hs | 6 ++---- src/Language/PureScript/Bridge/TypeInfo.hs | 6 ++---- 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Bridge/Builder.hs b/src/Language/PureScript/Bridge/Builder.hs index 3a42a749..58568b13 100644 --- a/src/Language/PureScript/Bridge/Builder.hs +++ b/src/Language/PureScript/Bridge/Builder.hs @@ -86,10 +86,8 @@ type FullBridge = HaskellType -> PSType data BridgeData = BridgeData - -- | The Haskell type to translate. - { _haskType :: HaskellType - -- | Reference to the bridge itself, needed for translation of type constructors. - , _fullBridge :: FullBridge + { _haskType :: HaskellType -- ^ The Haskell type to translate. + , _fullBridge :: FullBridge -- ^ Reference to the bridge itself, needed for translation of type constructors. } -- | By implementing the 'haskType' lens in the HasHaskType class, we are able diff --git a/src/Language/PureScript/Bridge/TypeInfo.hs b/src/Language/PureScript/Bridge/TypeInfo.hs index a01b924d..4c132be7 100644 --- a/src/Language/PureScript/Bridge/TypeInfo.hs +++ b/src/Language/PureScript/Bridge/TypeInfo.hs @@ -35,10 +35,8 @@ data Language -- | Basic info about a data type: data TypeInfo (lang :: Language) = TypeInfo - -- | Hackage package - { _typePackage :: !Text - -- | Full Module path - , _typeModule :: !Text + { _typePackage :: !Text -- ^ Hackage package + , _typeModule :: !Text -- ^ Full Module path , _typeName :: !Text , _typeParameters :: ![TypeInfo lang] } From 0042602f8a195b1fe185138f9ccca02020b8dd62 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Fri, 20 Sep 2019 09:55:15 +0100 Subject: [PATCH 020/111] Version 0.13.1.0. --- purescript-bridge.cabal | 2 +- shell.nix | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index 5ac78a3a..76dac0a6 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -10,7 +10,7 @@ name: purescript-bridge -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.13.0.0 +version: 0.13.1.0 -- A short (one-line) description of the package. synopsis: Generate PureScript data types from Haskell data types diff --git a/shell.nix b/shell.nix index 44d41aa0..7b718d92 100644 --- a/shell.nix +++ b/shell.nix @@ -9,7 +9,7 @@ let }: mkDerivation { pname = "purescript-bridge"; - version = "0.3.2.0"; + version = "0.13.1.0"; src = ./.; libraryHaskellDepends = [ base containers directory errors filepath generic-deriving lens mtl From fb8a038e4c9a97377834779ec6b2e0e7faf5b2a1 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Mon, 30 Sep 2019 15:22:09 +0100 Subject: [PATCH 021/111] Updating for PureScript 0.13. --- src/Language/PureScript/Bridge/Printer.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index a18aa382..5d459199 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -141,7 +141,10 @@ _foreignImports settings | (isJust . Switches.generateForeign) settings = [ ImportLine "Foreign.Generic" $ Set.fromList - ["defaultOptions", "genericDecode", "genericEncode", "aesonSumEncoding"] + ["defaultOptions", "genericDecode", "genericEncode"] + , ImportLine "Foreign.Generic.Class" $ + Set.fromList + ["aesonSumEncoding"] , ImportLine "Foreign.Generic.EnumEncoding" $ Set.fromList ["defaultGenericEnumOptions", "genericDecodeEnum", "genericEncodeEnum"] From a76b11993f3c31327a94ea1a2cd9c34a9e685d7f Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Wed, 20 Nov 2019 17:03:56 +0000 Subject: [PATCH 022/111] Adding support for Eq1 instances. --- src/Language/PureScript/Bridge/Printer.hs | 9 ++++++++- src/Language/PureScript/Bridge/SumType.hs | 8 ++++++++ test/Spec.hs | 6 +++++- test/TestData.hs | 5 ++++- 4 files changed, 25 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 5d459199..aeca0069 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.SumType (DataConstructor (DataConstructor), - Instance (Decode, Encode, Eq, Ord, Functor, Generic, GenericShow, Newtype), + Instance (Decode, Encode, Eq, Eq1, Functor, Generic, GenericShow, Newtype, Ord), RecordEntry (RecordEntry), SumType (SumType), getUsedTypes, @@ -109,6 +109,7 @@ moduleToText settings m = otherImports = importsFromList (_lensImports settings <> _genericsImports settings <> + _equalityImports settings <> _foreignImports settings) allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) @@ -120,6 +121,9 @@ _genericsImports settings ] | otherwise = [ImportLine "Data.Generic" $ Set.fromList ["class Generic"]] +_equalityImports :: Switches.Settings -> [ImportLine] +_equalityImports _ = [ImportLine "Data.Eq" $ Set.fromList ["class Eq1"]] + _lensImports :: Switches.Settings -> [ImportLine] _lensImports settings | Switches.generateLenses settings = @@ -280,6 +284,9 @@ instances settings st@(SumType t cs is) = go <$> is sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st instanceConstraints = eqInstance + go Eq1 = + "derive instance eq1" <> textStrict (_typeName t) <+> "::" <+> "Eq1" <+> + textStrict (_typeName t) go Ord = "derive instance ord" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Ord" <+> diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 9427be83..61674834 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} + {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} @@ -14,6 +15,7 @@ module Language.PureScript.Bridge.SumType , genericShow , functor , equal + , equal1 , order , DataConstructor(..) , RecordEntry(..) @@ -30,6 +32,7 @@ module Language.PureScript.Bridge.SumType ) where import Control.Lens hiding (from, to) +import Data.Functor.Classes (Eq1) import Data.List (nub) import Data.Maybe (maybeToList) import Data.Proxy @@ -89,6 +92,7 @@ data Instance | Newtype | Functor | Eq + | Eq1 | Ord deriving (Eq, Show) @@ -118,6 +122,10 @@ functor _ (SumType ti dc is) = SumType ti dc . nub $ Functor : is equal :: Eq a => Proxy a -> SumType t -> SumType t equal _ (SumType ti dc is) = SumType ti dc . nub $ Eq : is +-- | Ensure that an `Eq1` instance is generated for your type. +equal1 :: Eq1 f => Proxy (f a) -> SumType t -> SumType t +equal1 _ (SumType ti dc is) = SumType ti dc . nub $ Eq1 : is + -- | Ensure that both `Eq` and `Ord` instances are generated for your type. order :: Ord a => Proxy a -> SumType t -> SumType t order _ (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is diff --git a/test/Spec.hs b/test/Spec.hs index 2dc21490..e09806c6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -140,6 +140,7 @@ allTests = do , "module TestData where" , "" , "import Data.Either (Either)" + , "import Data.Eq (class Eq1)" , "import Data.Generic (class Generic)" , "import Data.Lens (Iso', Lens', Prism', lens, prism')" , "import Data.Lens.Iso.Newtype (_Newtype)" @@ -402,6 +403,7 @@ allTests = do , "module TestData where" , "" , "import Data.Either (Either)" + , "import Data.Eq (class Eq1)" , "import Data.Generic (class Generic)" , "import Data.Maybe (Maybe, Maybe(..))" , "import Data.Newtype (class Newtype)" @@ -517,7 +519,7 @@ allTests = do recType = bridgeSumType (buildBridge defaultBridge) - (functor proxy $ genericShow proxy $ mkSumType proxy) + (equal1 proxy $ functor proxy $ genericShow proxy $ mkSumType proxy) recTypeText = sumTypeToDoc settings recType txt = T.unlines @@ -525,6 +527,7 @@ allTests = do , " = Func Int a" , "" , "" + , "derive instance eq1Func :: Eq1 Func" , "derive instance functorFunc :: Functor Func" , "instance showFunc :: (Show a) => Show (Func a) where" , " show x = genericShow x" @@ -544,6 +547,7 @@ allTests = do , "module TestData where" , "" , "import Data.Either (Either)" + , "import Data.Eq (class Eq1)" , "import Data.Generic.Rep (class Generic)" , "import Data.Generic.Rep.Show (genericShow)" , "import Data.Maybe (Maybe, Maybe(..))" diff --git a/test/TestData.hs b/test/TestData.hs index 223d84fd..64d2c6d0 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -5,11 +5,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} module TestData where +import Data.Functor.Classes (Eq1(liftEq)) import Data.Proxy import Data.Text (Text) import Data.Typeable @@ -39,6 +39,9 @@ data Foo = Foo data Func a = Func Int a deriving (Eq, Ord, Functor, Generic, Typeable, Show) +instance Eq1 Func where + liftEq eq (Func n x) (Func m y) = n == m && x `eq` y + data Test = TestIntInt Int Int | TestBool {bool :: Bool} | TestVoid From 28c37771ef30b0d751960c061ef95627f05d290e Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Tue, 26 Nov 2019 15:57:14 +0000 Subject: [PATCH 023/111] Factoring out some duplicated code in the typeclass instance-generation. --- src/Language/PureScript/Bridge/Printer.hs | 101 +++++----------------- 1 file changed, 24 insertions(+), 77 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index aeca0069..39dc0c0d 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -144,11 +144,8 @@ _foreignImports :: Switches.Settings -> [ImportLine] _foreignImports settings | (isJust . Switches.generateForeign) settings = [ ImportLine "Foreign.Generic" $ - Set.fromList - ["defaultOptions", "genericDecode", "genericEncode"] - , ImportLine "Foreign.Generic.Class" $ - Set.fromList - ["aesonSumEncoding"] + Set.fromList ["defaultOptions", "genericDecode", "genericEncode"] + , ImportLine "Foreign.Generic.Class" $ Set.fromList ["aesonSumEncoding"] , ImportLine "Foreign.Generic.EnumEncoding" $ Set.fromList ["defaultGenericEnumOptions", "genericDecodeEnum", "genericEncodeEnum"] @@ -201,10 +198,18 @@ sumTypeToTypeDecls settings (SumType t cs is) = instances :: Switches.Settings -> SumType 'PureScript -> [Doc] instances settings st@(SumType t cs is) = go <$> is where + stpLength = length sumTypeParameters + sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st + extras instanceConstraints + | stpLength == 0 = mempty + | otherwise = + constraintsInner (instanceConstraints <$> sumTypeParameters) <+> "=>" + name = textStrict (_typeName t) + isEnum = all isNoArgConstructor cs + isNoArgConstructor c = (c ^. sigValues) == Left [] go :: Instance -> Doc go Encode = - "instance encode" <> textStrict (_typeName t) <+> "::" <+> extras <+> - "Encode" <+> + "instance encode" <> name <+> "::" <+> extras encodeInstance <+> "Encode" <+> typeInfoToDoc False t <+> "where" <> linebreak <> @@ -217,18 +222,8 @@ instances settings st@(SumType t cs is) = go <$> is else "genericEncode" <+> parens ("defaultOptions" <+> align (jsonOpts settings)) <+> "value") - stpLength = length sumTypeParameters - extras - | stpLength == 0 = mempty - | otherwise = - constraintsInner (instanceConstraints <$> sumTypeParameters) <+> - "=>" - sumTypeParameters = - filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceConstraints = encodeInstance go Decode = - "instance decode" <> textStrict (_typeName t) <+> "::" <+> extras <+> - "Decode" <+> + "instance decode" <> name <+> "::" <+> extras decodeInstance <+> "Decode" <+> typeInfoToDoc False t <+> "where" <> linebreak <> @@ -236,74 +231,28 @@ instances settings st@(SumType t cs is) = go <$> is where decodeInstanceBody = "decode value =" <+> - (if isEnum - then "genericDecodeEnum defaultGenericEnumOptions value" - else ("genericDecode" <+> - parens ("defaultOptions" <+> align (jsonOpts settings)) <+> - "value")) - stpLength = length sumTypeParameters - extras - | stpLength == 0 = mempty - | otherwise = - constraintsInner (instanceConstraints <$> sumTypeParameters) <+> - "=>" - sumTypeParameters = - filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceConstraints = decodeInstance + if isEnum + then "genericDecodeEnum defaultGenericEnumOptions value" + else "genericDecode" <+> + parens ("defaultOptions" <+> align (jsonOpts settings)) <+> + "value" go GenericShow = - "instance show" <> textStrict (_typeName t) <+> "::" <+> extras <+> "Show" <+> + "instance show" <> name <+> "::" <+> extras showInstance <+> "Show" <+> typeInfoToDoc False t <+> "where" <> linebreak <> indent 2 "show x = genericShow x" - where - stpLength = length sumTypeParameters - extras - | stpLength == 0 = mempty - | otherwise = - constraintsInner (instanceConstraints <$> sumTypeParameters) <+> - "=>" - sumTypeParameters = - filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceConstraints params = showInstance params go Functor = - "derive instance functor" <> name <+> "::" <+> "Functor" <+> name - where - name = textStrict (_typeName t) + "derive instance functor" <> name <+> "::" <+> "Functor" <+> name go Eq = - "derive instance eq" <> textStrict (_typeName t) <+> "::" <+> extras <+> - "Eq" <+> + "derive instance eq" <> name <+> "::" <+> extras eqInstance <+> "Eq" <+> typeInfoToDoc False t - where - stpLength = length sumTypeParameters - extras - | stpLength == 0 = mempty - | otherwise = - constraintsInner (instanceConstraints <$> sumTypeParameters) <+> - "=>" - sumTypeParameters = - filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceConstraints = eqInstance - go Eq1 = - "derive instance eq1" <> textStrict (_typeName t) <+> "::" <+> "Eq1" <+> - textStrict (_typeName t) + go Eq1 = "derive instance eq1" <> name <+> "::" <+> "Eq1" <+> name go Ord = - "derive instance ord" <> textStrict (_typeName t) <+> "::" <+> extras <+> - "Ord" <+> + "derive instance ord" <> name <+> "::" <+> extras ordInstance <+> "Ord" <+> typeInfoToDoc False t - where - stpLength = length sumTypeParameters - extras - | stpLength == 0 = mempty - | otherwise = - constraintsInner (instanceConstraints <$> sumTypeParameters) <+> - "=>" - sumTypeParameters = - filter (isTypeParam t) . Set.toList $ getUsedTypes st - instanceConstraints = ordInstance go i = - "derive instance " <> textStrict (T.toLower c) <> textStrict (_typeName t) <+> - "::" <+> + "derive instance " <> textStrict (T.toLower c) <> name <+> "::" <+> textStrict c <+> typeInfoToDoc False t <> postfix i @@ -314,8 +263,6 @@ instances settings st@(SumType t cs is) = go <$> is | Switches.genericsGenRep settings = " _" | otherwise = "" postfix _ = "" - isEnum = all isNoArgConstructor cs - isNoArgConstructor c = (c ^. sigValues) == Left [] recordUpdateDoc :: [(Doc, Doc)] -> Doc recordUpdateDoc = recordFields . fmap recordUpdateItem From 6a92d7853ea514be8b70bab5e72077bf5a510596 Mon Sep 17 00:00:00 2001 From: David Smith Date: Fri, 5 Feb 2021 16:58:48 +0000 Subject: [PATCH 024/111] use a newer stackage --- stack-8.0.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-8.0.yaml b/stack-8.0.yaml index 26d3ef57..601b3954 100644 --- a/stack-8.0.yaml +++ b/stack-8.0.yaml @@ -1,4 +1,4 @@ -resolver: lts-13.15 +resolver: nightly-2020-08-17 packages: - '.' extra-deps: [] From 808d12c9ead887567a99f9a90c6bca60ff27f174 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 5 Oct 2021 12:18:56 -0400 Subject: [PATCH 025/111] run lorri init --- .envrc | 1 + 1 file changed, 1 insertion(+) create mode 100644 .envrc diff --git a/.envrc b/.envrc new file mode 100644 index 00000000..051d09d2 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +eval "$(lorri direnv)" From 62ead0a8996106b112dee4eb1a2de5815d019a05 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 5 Oct 2021 12:46:38 -0400 Subject: [PATCH 026/111] Add flake.nix --- flake.lock | 310 +++++++++++++++++++++++++++++++++++++++++++++++++++++ flake.nix | 40 +++++++ shell.nix | 36 ++----- 3 files changed, 358 insertions(+), 28 deletions(-) create mode 100644 flake.lock create mode 100644 flake.nix diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..8f0ffe97 --- /dev/null +++ b/flake.lock @@ -0,0 +1,310 @@ +{ + "nodes": { + "HTTP": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, + "cabal-32": { + "flake": false, + "locked": { + "lastModified": 1603716527, + "narHash": "sha256-sDbrmur9Zfp4mPKohCD8IDZfXJ0Tjxpmr2R+kg5PpSY=", + "owner": "haskell", + "repo": "cabal", + "rev": "94aaa8e4720081f9c75497e2735b90f6a819b08e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.2", + "repo": "cabal", + "type": "github" + } + }, + "cabal-34": { + "flake": false, + "locked": { + "lastModified": 1622475795, + "narHash": "sha256-chwTL304Cav+7p38d9mcb+egABWmxo2Aq+xgVBgEb/U=", + "owner": "haskell", + "repo": "cabal", + "rev": "b086c1995cdd616fc8d91f46a21e905cc50a1049", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.4", + "repo": "cabal", + "type": "github" + } + }, + "cardano-shell": { + "flake": false, + "locked": { + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "cardano-shell", + "type": "github" + } + }, + "flake-utils": { + "locked": { + "lastModified": 1631561581, + "narHash": "sha256-3VQMV5zvxaVLvqqUrNz3iJelLw30mIVSfZmAaauM3dA=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "7e5bf3925f6fbdfaf50a2a7ca0be2879c4261d19", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_2": { + "locked": { + "lastModified": 1623875721, + "narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "f7e004a55b120c02ecb6219596820fcd32ca8772", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "ghc-8.6.5-iohk": { + "flake": false, + "locked": { + "lastModified": 1600920045, + "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", + "owner": "input-output-hk", + "repo": "ghc", + "rev": "95713a6ecce4551240da7c96b6176f980af75cae", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "release/8.6.5-iohk", + "repo": "ghc", + "type": "github" + } + }, + "hackage": { + "flake": false, + "locked": { + "lastModified": 1633396333, + "narHash": "sha256-mq7OoYa7ODDoKzUxR8xuEtQ0F0LO9I5uZG9DTZY+A/U=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "0b33cf7ca5f152a6b3acda375433a6bc86f8d3e7", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "haskellNix": { + "inputs": { + "HTTP": "HTTP", + "cabal-32": "cabal-32", + "cabal-34": "cabal-34", + "cardano-shell": "cardano-shell", + "flake-utils": "flake-utils_2", + "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "hackage": "hackage", + "hpc-coveralls": "hpc-coveralls", + "nix-tools": "nix-tools", + "nixpkgs": [ + "haskellNix", + "nixpkgs-2105" + ], + "nixpkgs-2003": "nixpkgs-2003", + "nixpkgs-2009": "nixpkgs-2009", + "nixpkgs-2105": "nixpkgs-2105", + "nixpkgs-unstable": "nixpkgs-unstable", + "old-ghc-nix": "old-ghc-nix", + "stackage": "stackage" + }, + "locked": { + "lastModified": 1633435111, + "narHash": "sha256-0wYA9+2BZXFGj241f4W66nbvP2s+bbikOa39CZQP05A=", + "owner": "input-output-hk", + "repo": "haskell.nix", + "rev": "56f22053e647efcad0b5ee9c32334d5d4214bcde", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "haskell.nix", + "type": "github" + } + }, + "hpc-coveralls": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "nix-tools": { + "flake": false, + "locked": { + "lastModified": 1627889534, + "narHash": "sha256-9eEbK2nrRp6rYGQoBv6LO9IA/ANZpofwAkxMuGBD45Y=", + "owner": "input-output-hk", + "repo": "nix-tools", + "rev": "15d2e4b61cb63ff351f3c490c12c4d89eafd31a1", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "nix-tools", + "type": "github" + } + }, + "nixpkgs-2003": { + "locked": { + "lastModified": 1620055814, + "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-20.03-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2009": { + "locked": { + "lastModified": 1624271064, + "narHash": "sha256-qns/uRW7MR2EfVf6VEeLgCsCp7pIOjDeR44JzTF09MA=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "46d1c3f28ca991601a53e9a14fdd53fcd3dd8416", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-20.09-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2105": { + "locked": { + "lastModified": 1630481079, + "narHash": "sha256-leWXLchbAbqOlLT6tju631G40SzQWPqaAXQG3zH1Imw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "110a2c9ebbf5d4a94486854f18a37a938cfacbbb", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-21.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-unstable": { + "locked": { + "lastModified": 1628785280, + "narHash": "sha256-2B5eMrEr6O8ff2aQNeVxTB+9WrGE80OB4+oM6T7fOcc=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "6525bbc06a39f26750ad8ee0d40000ddfdc24acb", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "old-ghc-nix": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "haskellNix": "haskellNix", + "nixpkgs": [ + "haskellNix", + "nixpkgs-unstable" + ] + } + }, + "stackage": { + "flake": false, + "locked": { + "lastModified": 1633224172, + "narHash": "sha256-Hw2jWJiS6ky0D5BhSyaw5PItzmTpRni4BUcCJmbESWk=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "948c9bde3d0b3aa452e0b19c34ae6385ac563160", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..761db28d --- /dev/null +++ b/flake.nix @@ -0,0 +1,40 @@ +{ + description = "Generate PureScript data types from Haskell data types"; + inputs.haskellNix.url = "github:input-output-hk/haskell.nix"; + inputs.nixpkgs.follows = "haskellNix/nixpkgs-unstable"; + inputs.flake-utils.url = "github:numtide/flake-utils"; + outputs = { self, nixpkgs, flake-utils, haskellNix }: + flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system: + let + overlays = [ haskellNix.overlay + (final: prev: { + # This overlay adds our project to pkgs + purescript-bridge = + final.haskell-nix.project' { + src = ./.; + compiler-nix-name = "ghc8107"; + }; + }) + ]; + pkgs = import nixpkgs { inherit system overlays; inherit (haskellNix) config; }; + flake = pkgs.purescript-bridge.flake {}; + in flake // { + # Built by `nix build .` + defaultPackage = flake.packages."purescript-bridge:test:purescript-bridge"; + devShell = pkgs.purescript-bridge.shellFor { + withHoogle = true; + tools = { + cabal = "latest"; + hlint = "latest"; + haskell-language-server = "latest"; + }; + + exactDeps = true; + + buildInputs = with pkgs; [ + nixpkgs-fmt + ghcid + ]; + }; + }); +} diff --git a/shell.nix b/shell.nix index 7b718d92..b3ef3bf1 100644 --- a/shell.nix +++ b/shell.nix @@ -1,30 +1,10 @@ -{ nixpkgs ? import {}, compiler ? "default" }: +{ nixpkgs ? import {} }: -let +(import ( + fetchTarball { + url = "https://github.com/edolstra/flake-compat/archive/99f1c2157fba4bfe6211a321fd0ee43199025dbf.tar.gz"; + sha256 = "0x2jn3vrawwv9xp15674wjz9pixwjyj3j771izayl962zziivbx2"; } +) { + src = ./.; +}).shellNix.default - inherit (nixpkgs) pkgs; - - f = { mkDerivation, base, containers, directory, errors, filepath - , generic-deriving, lens, mtl, stdenv, text, transformers - }: - mkDerivation { - pname = "purescript-bridge"; - version = "0.13.1.0"; - src = ./.; - libraryHaskellDepends = [ - base containers directory errors filepath generic-deriving lens mtl - text transformers - ]; - description = "Generate PureScript data types from Haskell data types"; - license = stdenv.lib.licenses.bsd3; - }; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - drv = haskellPackages.callPackage f {}; - -in - - if pkgs.lib.inNixShell then drv.env else drv From 2276c49de51e6c00551521906dd7ee11c20c80b8 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 5 Oct 2021 14:15:07 -0400 Subject: [PATCH 027/111] Update import module for genericShow --- src/Language/PureScript/Bridge/Printer.hs | 2 +- test/Spec.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 39dc0c0d..e42cba7e 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -117,7 +117,7 @@ _genericsImports :: Switches.Settings -> [ImportLine] _genericsImports settings | Switches.genericsGenRep settings = [ ImportLine "Data.Generic.Rep" $ Set.fromList ["class Generic"] - , ImportLine "Data.Generic.Rep.Show" $ Set.fromList ["genericShow"] + , ImportLine "Data.Show.Generic" $ Set.fromList ["genericShow"] ] | otherwise = [ImportLine "Data.Generic" $ Set.fromList ["class Generic"]] diff --git a/test/Spec.hs b/test/Spec.hs index e09806c6..c9694b43 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -549,9 +549,9 @@ allTests = do , "import Data.Either (Either)" , "import Data.Eq (class Eq1)" , "import Data.Generic.Rep (class Generic)" - , "import Data.Generic.Rep.Show (genericShow)" , "import Data.Maybe (Maybe, Maybe(..))" , "import Data.Newtype (class Newtype)" + , "import Data.Show.Generic (genericShow)" , "" , "import Prelude" , "" From 13381aa69862343da2f11ed37c1047ccf37e8a72 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 5 Oct 2021 14:16:48 -0400 Subject: [PATCH 028/111] 0.14.0.0 --- purescript-bridge.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index 76dac0a6..5e9a1df0 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -10,7 +10,7 @@ name: purescript-bridge -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.13.1.0 +version: 0.14.0.0 -- A short (one-line) description of the package. synopsis: Generate PureScript data types from Haskell data types From c867392c829e43e680a38d8caab0f0fb8201bf53 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 5 Oct 2021 15:44:01 -0400 Subject: [PATCH 029/111] Remove shell params --- shell.nix | 2 -- 1 file changed, 2 deletions(-) diff --git a/shell.nix b/shell.nix index b3ef3bf1..3f54dc34 100644 --- a/shell.nix +++ b/shell.nix @@ -1,5 +1,3 @@ -{ nixpkgs ? import {} }: - (import ( fetchTarball { url = "https://github.com/edolstra/flake-compat/archive/99f1c2157fba4bfe6211a321fd0ee43199025dbf.tar.gz"; From 0240a545256f98514b496d8337a16d1044f55a89 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Fri, 8 Oct 2021 14:05:43 -0400 Subject: [PATCH 030/111] Replace foreign-generic with Argonaut --- src/Language/PureScript/Bridge.hs | 12 ++- .../PureScript/Bridge/CodeGenSwitches.hs | 24 ++--- src/Language/PureScript/Bridge/Printer.hs | 98 ++++++------------- src/Language/PureScript/Bridge/SumType.hs | 7 +- test/Spec.hs | 2 +- 5 files changed, 56 insertions(+), 87 deletions(-) diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index 8c2b84d6..92962822 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -14,6 +14,7 @@ module Language.PureScript.Bridge import Control.Applicative import qualified Data.Map as M +import Data.Maybe (isJust) import qualified Data.Set as Set import qualified Data.Text.IO as T @@ -101,10 +102,13 @@ writePSTypesWith switch root bridge sts = do bridged = map (bridgeSumType bridge) sts modules = M.elems $ sumTypesToModules M.empty bridged packages = - if Switches.generateLenses settings - then Set.insert "purescript-profunctor-lenses" $ - sumTypesToNeededPackages bridged - else sumTypesToNeededPackages bridged + sumTypesToNeededPackages bridged + <> Set.filter + (const $ Switches.generateLenses settings) + (Set.singleton "purescript-profunctor-lenses") + <> Set.filter + (const $ isJust $ Switches.generateArgonaut settings) + (Set.fromList ["purescript-argonaut-core", "purescript-argonaut-generic"]) -- | Translate all 'TypeInfo' values in a 'SumType' to PureScript types. -- diff --git a/src/Language/PureScript/Bridge/CodeGenSwitches.hs b/src/Language/PureScript/Bridge/CodeGenSwitches.hs index c88a73b1..2c4cb335 100644 --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ b/src/Language/PureScript/Bridge/CodeGenSwitches.hs @@ -1,7 +1,7 @@ -- | General switches for the code generation, such as generating profunctor-lenses or not module Language.PureScript.Bridge.CodeGenSwitches ( Settings(..) - , ForeignOptions(..) + , ArgonautOptions(..) , defaultSettings , purs_0_11_settings , Switch @@ -11,8 +11,8 @@ module Language.PureScript.Bridge.CodeGenSwitches , genLenses , useGen , useGenRep - , genForeign - , noForeign + , genArgonaut + , noArgonaut ) where import Data.Monoid (Endo(..)) @@ -22,14 +22,14 @@ 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 + , generateArgonaut :: Maybe ArgonautOptions -- ^generate Argonaut EncodeJson and DecodeJson instances } deriving (Eq, Show) -data ForeignOptions = - ForeignOptions - { unwrapSingleConstructors :: Bool - } +data ArgonautOptions = + ArgonautOptions + -- { unwrapSingleConstructors :: Bool + -- } deriving (Eq, Show) -- | Settings to generate Lenses @@ -67,8 +67,8 @@ useGenRep = Endo $ \settings -> settings {genericsGenRep = True} useGen :: Switch useGen = Endo $ \settings -> settings {genericsGenRep = False} -genForeign :: ForeignOptions -> Switch -genForeign opts = Endo $ \settings -> settings {generateForeign = Just opts} +genArgonaut :: ArgonautOptions -> Switch +genArgonaut opts = Endo $ \settings -> settings {generateArgonaut = Just opts} -noForeign :: Switch -noForeign = Endo $ \settings -> settings {generateForeign = Nothing} +noArgonaut :: Switch +noArgonaut = Endo $ \settings -> settings {generateArgonaut = Nothing} diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index e42cba7e..b40eedb9 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.SumType (DataConstructor (DataConstructor), - Instance (Decode, Encode, Eq, Eq1, Functor, Generic, GenericShow, Newtype, Ord), + Instance (Eq, Eq1, Functor, Generic, GenericShow, Newtype, Ord, Json), RecordEntry (RecordEntry), SumType (SumType), getUsedTypes, @@ -42,7 +42,7 @@ import System.Directory (createDirectoryIfMi import System.FilePath (joinPath, takeDirectory, ()) -import Text.PrettyPrint.Leijen.Text (Doc, align, cat, +import Text.PrettyPrint.Leijen.Text (Doc, cat, comma, displayTStrict, encloseSep, hcat, @@ -110,7 +110,7 @@ moduleToText settings m = importsFromList (_lensImports settings <> _genericsImports settings <> _equalityImports settings <> - _foreignImports settings) + _argonautImports settings) allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) _genericsImports :: Switches.Settings -> [ImportLine] @@ -140,16 +140,17 @@ _lensImports settings , 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.Generic.Class" $ Set.fromList ["aesonSumEncoding"] - , ImportLine "Foreign.Generic.EnumEncoding" $ - Set.fromList - ["defaultGenericEnumOptions", "genericDecodeEnum", "genericEncodeEnum"] - , ImportLine "Foreign.Class" $ Set.fromList ["class Decode", "class Encode"] +_argonautImports :: Switches.Settings -> [ImportLine] +_argonautImports settings + | (isJust . Switches.generateArgonaut) settings = + [ ImportLine "Data.Argonaut.Decode" $ + Set.fromList ["class DecodeJson", "decodeJson"] + , ImportLine "Data.Argonaut.Decode.Generic" $ + Set.fromList ["genericDecodeJsonWith"] + , ImportLine "Data.Argonaut.Encode" $ + Set.fromList ["class EncodeJson", "encodeJson"] + , ImportLine "Data.Argonaut.Decode.Generic" $ + Set.fromList ["genericEncodeJsonWith"] ] | otherwise = [] @@ -182,21 +183,20 @@ sumTypeToTypeDecls settings (SumType t cs is) = (constructorToDoc <$> cs)) ] , [line] - , instances settings (SumType t cs (filter genForeign is)) + , instances settings (SumType t cs (filter genArgonaut 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 + genArgonaut Json = (isJust . Switches.generateArgonaut) settings + genArgonaut _ = True -- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. instances :: Switches.Settings -> SumType 'PureScript -> [Doc] -instances settings st@(SumType t cs is) = go <$> is +instances settings st@(SumType t _ is) = go <$> is where stpLength = length sumTypeParameters sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st @@ -205,37 +205,21 @@ instances settings st@(SumType t cs is) = go <$> is | otherwise = constraintsInner (instanceConstraints <$> sumTypeParameters) <+> "=>" name = textStrict (_typeName t) - isEnum = all isNoArgConstructor cs - isNoArgConstructor c = (c ^. sigValues) == Left [] + -- isEnum = all isNoArgConstructor cs + -- isNoArgConstructor c = (c ^. sigValues) == Left [] go :: Instance -> Doc - go Encode = - "instance encode" <> name <+> "::" <+> extras encodeInstance <+> "Encode" <+> + go Json = + "instance encodeJson" <> name <+> "::" <+> extras encodeJsonInstance <+> "EncodeJson" <+> typeInfoToDoc False t <+> "where" <> linebreak <> - indent 2 encodeInstanceBody - where - encodeInstanceBody = - "encode value =" <+> - (if isEnum - then "genericEncodeEnum defaultGenericEnumOptions value" - else "genericEncode" <+> - parens ("defaultOptions" <+> align (jsonOpts settings)) <+> - "value") - go Decode = - "instance decode" <> name <+> "::" <+> extras decodeInstance <+> "Decode" <+> + indent 2 "encodeJson = genericEncodeJsonWith defaultEncoding { valuesKey = \"contents\", unwrapSingleArguments = true }" <> + linebreak <> + "instance decodeJson" <> name <+> "::" <+> extras decodeJsonInstance <+> "DecodeJson" <+> typeInfoToDoc False t <+> "where" <> linebreak <> - indent 2 decodeInstanceBody - where - decodeInstanceBody = - "decode value =" <+> - if isEnum - then "genericDecodeEnum defaultGenericEnumOptions value" - else "genericDecode" <+> - parens ("defaultOptions" <+> align (jsonOpts settings)) <+> - "value" + indent 2 "decodeJson = genericDecodeJsonWith defaultEncoding { valuesKey = \"contents\", unwrapSingleArguments = true }" go GenericShow = "instance show" <> name <+> "::" <+> extras showInstance <+> "Show" <+> typeInfoToDoc False t <+> @@ -264,36 +248,12 @@ instances settings st@(SumType t cs is) = go <$> is | otherwise = "" postfix _ = "" -recordUpdateDoc :: [(Doc, Doc)] -> Doc -recordUpdateDoc = recordFields . fmap recordUpdateItem - where - recordUpdateItem (k, v) = k <+> "=" <+> v - -jsonOpts :: Switches.Settings -> Doc -jsonOpts settings = - case Switches.generateForeign settings of - Nothing -> mempty - Just fopts -> - recordUpdateDoc - [ ( "unwrapSingleConstructors" - , textStrict . T.toLower . T.pack . show . - Switches.unwrapSingleConstructors $ - fopts) - , ("sumEncoding", "aesonSumEncoding") - ] - constraintsInner :: [Doc] -> Doc constraintsInner = encloseSep lparen rparen ("," <> space) isTypeParam :: PSType -> PSType -> Bool isTypeParam t typ = _typeName typ `elem` map _typeName (_typeParameters t) -encodeInstance :: PSType -> Doc -encodeInstance params = "Encode" <+> typeInfoToDoc False params - -decodeInstance :: PSType -> Doc -decodeInstance params = "Decode" <+> typeInfoToDoc False params - eqInstance :: PSType -> Doc eqInstance params = "Eq" <+> typeInfoToDoc False params @@ -303,6 +263,12 @@ ordInstance params = "Ord" <+> typeInfoToDoc False params showInstance :: PSType -> Doc showInstance params = "Show" <+> typeInfoToDoc False params +decodeJsonInstance :: PSType -> Doc +decodeJsonInstance params = "DecodeJson" <+> typeInfoToDoc False params + +encodeJsonInstance :: PSType -> Doc +encodeJsonInstance params = "EncodeJson" <+> typeInfoToDoc False params + genericInstance :: Switches.Settings -> PSType -> Doc genericInstance settings params = if not (Switches.genericsGenRep settings) diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 61674834..c1e898b4 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -79,16 +79,15 @@ mkSumType p = SumType (mkTypeInfo p) constructors - (Encode : Decode : Generic : maybeToList (nootype constructors)) + (Json : Generic : maybeToList (nootype constructors)) where constructors = gToConstructors (from (undefined :: t)) -- | Purescript typeclass instances that can be generated for your Haskell types. data Instance - = Encode - | Decode - | Generic + = Generic | GenericShow + | Json | Newtype | Functor | Eq diff --git a/test/Spec.hs b/test/Spec.hs index c9694b43..a11f2509 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -86,7 +86,7 @@ allTests = do ] } ] - [Eq, Ord, Encode, Decode, Generic] + [Eq, Ord, Json, Generic] in bst `shouldBe` st it "tests generation of for custom type Foo" $ let prox = Proxy :: Proxy Foo From 542274f06524c596f291d3dae803c5061e664f69 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Fri, 8 Oct 2021 18:31:23 -0400 Subject: [PATCH 031/111] Add roundtrip test project --- .gitignore | 3 +- flake.lock | 17 + flake.nix | 13 +- test/RoundTrip/app/.gitignore | 10 + test/RoundTrip/app/packages.dhall | 4 + test/RoundTrip/app/spago.dhall | 18 + test/RoundTrip/app/src/Main.purs | 10 + test/RoundTrip/app/src/RoundTrip/Types.purs | 404 ++++++++++++++++++++ 8 files changed, 475 insertions(+), 4 deletions(-) create mode 100644 test/RoundTrip/app/.gitignore create mode 100644 test/RoundTrip/app/packages.dhall create mode 100644 test/RoundTrip/app/spago.dhall create mode 100644 test/RoundTrip/app/src/Main.purs create mode 100644 test/RoundTrip/app/src/RoundTrip/Types.purs diff --git a/.gitignore b/.gitignore index 0e290f52..652b5d68 100644 --- a/.gitignore +++ b/.gitignore @@ -21,4 +21,5 @@ dist dist-* shell.nix stack.yaml -.dir-locals.el \ No newline at end of file +.dir-locals.el +.psc-ide-port diff --git a/flake.lock b/flake.lock index 8f0ffe97..88ad8b1f 100644 --- a/flake.lock +++ b/flake.lock @@ -66,6 +66,22 @@ "type": "github" } }, + "easy-ps": { + "flake": false, + "locked": { + "lastModified": 1631961521, + "narHash": "sha256-1yPjUdOYzw1+UGFzBXbyZqEbsM6XZu/6+v8W35qFdLo=", + "owner": "justinwoo", + "repo": "easy-purescript-nix", + "rev": "d9a37c75ed361372e1545f6efbc08d819b3c28c8", + "type": "github" + }, + "original": { + "owner": "justinwoo", + "repo": "easy-purescript-nix", + "type": "github" + } + }, "flake-utils": { "locked": { "lastModified": 1631561581, @@ -280,6 +296,7 @@ }, "root": { "inputs": { + "easy-ps": "easy-ps", "flake-utils": "flake-utils", "haskellNix": "haskellNix", "nixpkgs": [ diff --git a/flake.nix b/flake.nix index 761db28d..0b21af6c 100644 --- a/flake.nix +++ b/flake.nix @@ -3,7 +3,11 @@ inputs.haskellNix.url = "github:input-output-hk/haskell.nix"; inputs.nixpkgs.follows = "haskellNix/nixpkgs-unstable"; inputs.flake-utils.url = "github:numtide/flake-utils"; - outputs = { self, nixpkgs, flake-utils, haskellNix }: + inputs.easy-ps = { + url = "github:justinwoo/easy-purescript-nix"; + flake = false; + }; + outputs = { self, nixpkgs, flake-utils, haskellNix, easy-ps }: flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system: let overlays = [ haskellNix.overlay @@ -31,9 +35,12 @@ exactDeps = true; - buildInputs = with pkgs; [ - nixpkgs-fmt + buildInputs = with pkgs; with import easy-ps { inherit pkgs; }; [ ghcid + nixpkgs-fmt + purs + purescript-language-server + spago ]; }; }); diff --git a/test/RoundTrip/app/.gitignore b/test/RoundTrip/app/.gitignore new file mode 100644 index 00000000..30efe199 --- /dev/null +++ b/test/RoundTrip/app/.gitignore @@ -0,0 +1,10 @@ +/bower_components/ +/node_modules/ +/.pulp-cache/ +/output/ +/generated-docs/ +/.psc-package/ +/.psc* +/.purs* +/.psa* +/.spago diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall new file mode 100644 index 00000000..da4058d0 --- /dev/null +++ b/test/RoundTrip/app/packages.dhall @@ -0,0 +1,4 @@ +let upstream = + https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20211005/packages.dhall sha256:2ec351f17be14b3f6421fbba36f4f01d1681e5c7f46e0c981465c4cf222de5be + +in upstream diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall new file mode 100644 index 00000000..66603c7f --- /dev/null +++ b/test/RoundTrip/app/spago.dhall @@ -0,0 +1,18 @@ +{ name = "my-project" +, dependencies = + [ "argonaut-codecs" + , "argonaut-core" + , "argonaut-generic" + , "console" + , "effect" + , "either" + , "maybe" + , "newtype" + , "prelude" + , "profunctor-lenses" + , "psci-support" + , "tuples" + ] +, packages = ./packages.dhall +, sources = [ "src/**/*.purs" ] +} diff --git a/test/RoundTrip/app/src/Main.purs b/test/RoundTrip/app/src/Main.purs new file mode 100644 index 00000000..5c18dca5 --- /dev/null +++ b/test/RoundTrip/app/src/Main.purs @@ -0,0 +1,10 @@ +module Main where + +import Prelude + +import Effect (Effect) +import Effect.Console (log) + +main :: Effect Unit +main = do + log "🍝" diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs new file mode 100644 index 00000000..cdfd8f46 --- /dev/null +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -0,0 +1,404 @@ +-- File auto generated by purescript-bridge! -- +module RoundTrip.Types where + +import Prelude +import Data.Argonaut.Decode (class DecodeJson) +import Data.Argonaut.Decode.Generic (genericDecodeJsonWith) +import Data.Argonaut.Encode (class EncodeJson) +import Data.Argonaut.Encode.Generic (genericEncodeJsonWith) +import Data.Argonaut.Types.Generic (defaultEncoding) +import Data.Either (Either) +import Data.Functor (class Functor) +import Data.Generic.Rep (class Generic) +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.Show.Generic (genericShow) +import Data.Symbol (SProxy(SProxy)) +import Data.Tuple (Tuple) +import Data.Tuple.Nested (Tuple3, Tuple4) + +data TestData + = Maybe (Maybe TestSum) + | Either (Either String TestSum) + +instance encodeJsonTestData :: EncodeJson TestData where + encodeJson = + genericEncodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } +instance decodeJsonTestData :: DecodeJson TestData where + decodeJson = + genericDecodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + +derive instance eqTestData :: Eq TestData + +instance showTestData :: Show TestData where + show x = genericShow x + +derive instance ordTestData :: Ord TestData + +derive instance genericTestData :: Generic TestData _ + +-------------------------------------------------------------------------------- + +_Maybe :: Prism' TestData (Maybe TestSum) +_Maybe = prism' Maybe f + where + f (Maybe a) = Just $ a + f _ = Nothing + +_Either :: Prism' TestData (Either String TestSum) +_Either = prism' Either f + where + f (Either a) = Just $ a + f _ = Nothing + +-------------------------------------------------------------------------------- +data TestSum + = Nullary + | Bool Boolean + | Int Int + | Number Number + | String String + | Array (Array String) + | Record (TestRecord Int) + | NestedRecord (TestRecord (TestRecord Int)) + | NT TestNewtype + | NTRecord TestNewtypeRecord + | Unit Unit + | Pair (Tuple Int String) + | Triple (Tuple3 Int String Boolean) + | Quad (Tuple4 Int String Boolean Number) + | NestedSum TestNestedSum + | Enum TestEnum + +instance encodeJsonTestSum :: EncodeJson TestSum where + encodeJson = + genericEncodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } +instance decodeJsonTestSum :: DecodeJson TestSum where + decodeJson = + genericDecodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + +derive instance eqTestSum :: Eq TestSum + +instance showTestSum :: Show TestSum where + show x = genericShow x + +derive instance ordTestSum :: Ord TestSum + +derive instance genericTestSum :: Generic TestSum _ + +-------------------------------------------------------------------------------- + +_Nullary :: Prism' TestSum Unit +_Nullary = prism' (\_ -> Nullary) f + where + f Nullary = Just unit + f _ = Nothing + +_Bool :: Prism' TestSum Boolean +_Bool = prism' Bool f + where + f (Bool a) = Just $ a + f _ = Nothing + +_Int :: Prism' TestSum Int +_Int = prism' Int f + where + f (Int a) = Just $ a + f _ = Nothing + +_Number :: Prism' TestSum Number +_Number = prism' Number f + where + f (Number a) = Just $ a + f _ = Nothing + +_String :: Prism' TestSum String +_String = prism' String f + where + f (String a) = Just $ a + f _ = Nothing + +_Array :: Prism' TestSum (Array String) +_Array = prism' Array f + where + f (Array a) = Just $ a + f _ = Nothing + +_Record :: Prism' TestSum (TestRecord Int) +_Record = prism' Record f + where + f (Record a) = Just $ a + f _ = Nothing + +_NestedRecord :: Prism' TestSum (TestRecord (TestRecord Int)) +_NestedRecord = prism' NestedRecord f + where + f (NestedRecord a) = Just $ a + f _ = Nothing + +_NT :: Prism' TestSum TestNewtype +_NT = prism' NT f + where + f (NT a) = Just $ a + f _ = Nothing + +_NTRecord :: Prism' TestSum TestNewtypeRecord +_NTRecord = prism' NTRecord f + where + f (NTRecord a) = Just $ a + f _ = Nothing + +_Unit :: Prism' TestSum Unit +_Unit = prism' Unit f + where + f (Unit a) = Just $ a + f _ = Nothing + +_Pair :: Prism' TestSum (Tuple Int String) +_Pair = prism' Pair f + where + f (Pair a) = Just $ a + f _ = Nothing + +_Triple :: Prism' TestSum (Tuple3 Int String Boolean) +_Triple = prism' Triple f + where + f (Triple a) = Just $ a + f _ = Nothing + +_Quad :: Prism' TestSum (Tuple4 Int String Boolean Number) +_Quad = prism' Quad f + where + f (Quad a) = Just $ a + f _ = Nothing + +_NestedSum :: Prism' TestSum TestNestedSum +_NestedSum = prism' NestedSum f + where + f (NestedSum a) = Just $ a + f _ = Nothing + +_Enum :: Prism' TestSum TestEnum +_Enum = prism' Enum f + where + f (Enum a) = Just $ a + f _ = Nothing + +-------------------------------------------------------------------------------- +newtype TestRecord a + = TestRecord + { field1 :: String + , field2 :: a + } + +instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where + encodeJson = + genericEncodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } +instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) where + decodeJson = + genericDecodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + +derive instance functorTestRecord :: Functor TestRecord + +derive instance eqTestRecord :: (Eq a) => Eq (TestRecord a) + +instance showTestRecord :: (Show a) => Show (TestRecord a) where + show x = genericShow x + +derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) + +derive instance genericTestRecord :: Generic (TestRecord a) _ + +derive instance newtypeTestRecord :: Newtype (TestRecord a) _ + +-------------------------------------------------------------------------------- + +_TestRecord :: forall a. Iso' (TestRecord a) { field1 :: String, field2 :: a } +_TestRecord = _Newtype + +-------------------------------------------------------------------------------- +newtype TestNewtype + = TestNewtype (TestRecord String) + +instance encodeJsonTestNewtype :: EncodeJson TestNewtype where + encodeJson = + genericEncodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } +instance decodeJsonTestNewtype :: DecodeJson TestNewtype where + decodeJson = + genericDecodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + +derive instance eqTestNewtype :: Eq TestNewtype + +instance showTestNewtype :: Show TestNewtype where + show x = genericShow x + +derive instance ordTestNewtype :: Ord TestNewtype + +derive instance genericTestNewtype :: Generic TestNewtype _ + +derive instance newtypeTestNewtype :: Newtype TestNewtype _ + +-------------------------------------------------------------------------------- + +_TestNewtype :: Iso' TestNewtype (TestRecord String) +_TestNewtype = _Newtype + +-------------------------------------------------------------------------------- +newtype TestNewtypeRecord + = TestNewtypeRecord + { unTestNewtypeRecord :: TestNewtype + } + +instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where + encodeJson = + genericEncodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } +instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where + decodeJson = + genericDecodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + +derive instance eqTestNewtypeRecord :: Eq TestNewtypeRecord + +instance showTestNewtypeRecord :: Show TestNewtypeRecord where + show x = genericShow x + +derive instance ordTestNewtypeRecord :: Ord TestNewtypeRecord + +derive instance genericTestNewtypeRecord :: Generic TestNewtypeRecord _ + +derive instance newtypeTestNewtypeRecord :: Newtype TestNewtypeRecord _ + +-------------------------------------------------------------------------------- + +_TestNewtypeRecord :: Iso' TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } +_TestNewtypeRecord = _Newtype + +-------------------------------------------------------------------------------- +data TestNestedSum + = Case1 String + | Case2 Int + | Case3 (TestRecord Int) + +instance encodeJsonTestNestedSum :: EncodeJson TestNestedSum where + encodeJson = + genericEncodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } +instance decodeJsonTestNestedSum :: DecodeJson TestNestedSum where + decodeJson = + genericDecodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + +derive instance eqTestNestedSum :: Eq TestNestedSum + +instance showTestNestedSum :: Show TestNestedSum where + show x = genericShow x + +derive instance ordTestNestedSum :: Ord TestNestedSum + +derive instance genericTestNestedSum :: Generic TestNestedSum _ + +-------------------------------------------------------------------------------- + +_Case1 :: Prism' TestNestedSum String +_Case1 = prism' Case1 f + where + f (Case1 a) = Just $ a + f _ = Nothing + +_Case2 :: Prism' TestNestedSum Int +_Case2 = prism' Case2 f + where + f (Case2 a) = Just $ a + f _ = Nothing + +_Case3 :: Prism' TestNestedSum (TestRecord Int) +_Case3 = prism' Case3 f + where + f (Case3 a) = Just $ a + f _ = Nothing + +-------------------------------------------------------------------------------- +data TestEnum + = Mon + | Tue + | Wed + | Thu + | Fri + | Sat + | Sun + +instance encodeJsonTestEnum :: EncodeJson TestEnum where + encodeJson = + genericEncodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } +instance decodeJsonTestEnum :: DecodeJson TestEnum where + decodeJson = + genericDecodeJsonWith + defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + +derive instance eqTestEnum :: Eq TestEnum + +instance showTestEnum :: Show TestEnum where + show x = genericShow x + +derive instance ordTestEnum :: Ord TestEnum + +derive instance genericTestEnum :: Generic TestEnum _ + +-------------------------------------------------------------------------------- + +_Mon :: Prism' TestEnum Unit +_Mon = prism' (\_ -> Mon) f + where + f Mon = Just unit + f _ = Nothing + +_Tue :: Prism' TestEnum Unit +_Tue = prism' (\_ -> Tue) f + where + f Tue = Just unit + f _ = Nothing + +_Wed :: Prism' TestEnum Unit +_Wed = prism' (\_ -> Wed) f + where + f Wed = Just unit + f _ = Nothing + +_Thu :: Prism' TestEnum Unit +_Thu = prism' (\_ -> Thu) f + where + f Thu = Just unit + f _ = Nothing + +_Fri :: Prism' TestEnum Unit +_Fri = prism' (\_ -> Fri) f + where + f Fri = Just unit + f _ = Nothing + +_Sat :: Prism' TestEnum Unit +_Sat = prism' (\_ -> Sat) f + where + f Sat = Just unit + f _ = Nothing + +_Sun :: Prism' TestEnum Unit +_Sun = prism' (\_ -> Sun) f + where + f Sun = Just unit + f _ = Nothing + +-------------------------------------------------------------------------------- From 38b502a43945ec6e5ecd7dab279efa2260474aa5 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Fri, 8 Oct 2021 18:31:36 -0400 Subject: [PATCH 032/111] Add compile test --- purescript-bridge.cabal | 12 +- src/Language/PureScript/Bridge.hs | 16 +- .../PureScript/Bridge/CodeGenSwitches.hs | 20 +- src/Language/PureScript/Bridge/Printer.hs | 195 ++++--- src/Language/PureScript/Bridge/SumType.hs | 35 +- test/RoundTrip/Spec.hs | 52 ++ test/RoundTrip/Types.hs | 99 ++++ test/Spec.hs | 529 ++---------------- test/TestData.hs | 3 +- 9 files changed, 353 insertions(+), 608 deletions(-) create mode 100644 test/RoundTrip/Spec.hs create mode 100644 test/RoundTrip/Types.hs diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index 5e9a1df0..22c169c0 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -95,13 +95,19 @@ Test-Suite tests type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: TestData - build-depends: base + , RoundTrip.Spec + , RoundTrip.Types + build-depends: aeson + , HUnit + , base , containers + , directory + , hspec + , hspec-expectations-pretty-diff + , process , purescript-bridge , text , wl-pprint-text - , hspec - , hspec-expectations-pretty-diff hs-source-dirs: test default-language: Haskell2010 diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index 92962822..f7bd7d95 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -99,8 +99,8 @@ writePSTypesWith switch root bridge sts = do T.putStrLn "\nSuccessfully created your PureScript modules!" where settings = Switches.getSettings switch - bridged = map (bridgeSumType bridge) sts - modules = M.elems $ sumTypesToModules M.empty bridged + bridged = map (bridgeSumType bridge settings) sts + modules = M.elems $ sumTypesToModules bridged packages = sumTypesToNeededPackages bridged <> Set.filter @@ -108,7 +108,7 @@ writePSTypesWith switch root bridge sts = do (Set.singleton "purescript-profunctor-lenses") <> Set.filter (const $ isJust $ Switches.generateArgonaut settings) - (Set.fromList ["purescript-argonaut-core", "purescript-argonaut-generic"]) + (Set.fromList ["purescript-argonaut-codecs", "purescript-argonaut-core", "purescript-argonaut-generic"]) -- | Translate all 'TypeInfo' values in a 'SumType' to PureScript types. -- @@ -117,9 +117,13 @@ writePSTypesWith switch root bridge sts = do -- > data Foo = Foo | Bar Int | FooBar Int Text deriving (Generic, Typeable, Show) -- -- > bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo)) -bridgeSumType :: FullBridge -> SumType 'Haskell -> SumType 'PureScript -bridgeSumType br (SumType t cs is) = - SumType (br t) (map (bridgeConstructor br) cs) is +bridgeSumType :: FullBridge -> Settings -> SumType 'Haskell -> SumType 'PureScript +bridgeSumType br settings (SumType t cs is) = + SumType + (br t) + (map (bridgeConstructor br) cs) + $ maybe is (const $ Json : is) + $ Switches.generateArgonaut settings -- | Default bridge for mapping primitive/common types: -- You can append your own bridges like this: diff --git a/src/Language/PureScript/Bridge/CodeGenSwitches.hs b/src/Language/PureScript/Bridge/CodeGenSwitches.hs index 2c4cb335..4179b224 100644 --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ b/src/Language/PureScript/Bridge/CodeGenSwitches.hs @@ -3,14 +3,11 @@ module Language.PureScript.Bridge.CodeGenSwitches ( Settings(..) , ArgonautOptions(..) , defaultSettings - , purs_0_11_settings , Switch , getSettings , defaultSwitch , noLenses , genLenses - , useGen - , useGenRep , genArgonaut , noArgonaut ) where @@ -21,7 +18,6 @@ import Data.Monoid (Endo(..)) 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 , generateArgonaut :: Maybe ArgonautOptions -- ^generate Argonaut EncodeJson and DecodeJson instances } deriving (Eq, Show) @@ -34,11 +30,7 @@ data ArgonautOptions = -- | Settings to generate Lenses defaultSettings :: Settings -defaultSettings = Settings True True Nothing - --- |settings for purescript 0.11.x -purs_0_11_settings :: Settings -purs_0_11_settings = Settings True False Nothing +defaultSettings = Settings True Nothing -- | you can `mappend` switches to control the code generation type Switch = Endo Settings @@ -59,16 +51,10 @@ noLenses = Endo $ \settings -> settings {generateLenses = False} 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} - +-- | Switch on the generatation of argonaut decode and encode instances genArgonaut :: ArgonautOptions -> Switch genArgonaut opts = Endo $ \settings -> settings {generateArgonaut = Just opts} +-- | Switch off the generatation of argonaut decode and encode instances noArgonaut :: Switch noArgonaut = Endo $ \settings -> settings {generateArgonaut = Nothing} diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index b40eedb9..5a987a34 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -54,7 +54,7 @@ import Text.PrettyPrint.Leijen.Text (Doc, cat, renderPretty, rparen, space, textStrict, vsep, - (<+>), ()) + (<+>)) renderText :: Doc -> Text renderText = displayTStrict . renderPretty 0.4 200 @@ -62,7 +62,7 @@ renderText = displayTStrict . renderPretty 0.4 200 data Module (lang :: Language) = PSModule { psModuleName :: !Text - , psImportLines :: !(Map Text ImportLine) + , psImportLines :: !ImportLines , psTypes :: ![SumType lang] } deriving (Show) @@ -102,27 +102,19 @@ moduleToText settings m = T.unlines $ "-- File auto generated by purescript-bridge! --" : "module " <> psModuleName m <> " where\n" : + "import Prelude" : (importLineToText <$> allImports) <> - ["", "import Prelude", ""] <> + [""] <> (renderText . sumTypeToDoc settings <$> psTypes m) where otherImports = importsFromList - (_lensImports settings <> _genericsImports settings <> - _equalityImports settings <> - _argonautImports settings) + (_lensImports settings <> _genericsImports <> _argonautImports settings) allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) -_genericsImports :: Switches.Settings -> [ImportLine] -_genericsImports settings - | Switches.genericsGenRep settings = - [ ImportLine "Data.Generic.Rep" $ Set.fromList ["class Generic"] - , ImportLine "Data.Show.Generic" $ Set.fromList ["genericShow"] - ] - | otherwise = [ImportLine "Data.Generic" $ Set.fromList ["class Generic"]] - -_equalityImports :: Switches.Settings -> [ImportLine] -_equalityImports _ = [ImportLine "Data.Eq" $ Set.fromList ["class Eq1"]] +_genericsImports :: [ImportLine] +_genericsImports = + [ ImportLine "Data.Generic.Rep" $ Set.singleton "class Generic" ] _lensImports :: Switches.Settings -> [ImportLine] _lensImports settings @@ -133,24 +125,16 @@ _lensImports settings , 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"] - ] + [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] ] _argonautImports :: Switches.Settings -> [ImportLine] _argonautImports settings | (isJust . Switches.generateArgonaut) settings = - [ ImportLine "Data.Argonaut.Decode" $ - Set.fromList ["class DecodeJson", "decodeJson"] - , ImportLine "Data.Argonaut.Decode.Generic" $ - Set.fromList ["genericDecodeJsonWith"] - , ImportLine "Data.Argonaut.Encode" $ - Set.fromList ["class EncodeJson", "encodeJson"] - , ImportLine "Data.Argonaut.Decode.Generic" $ - Set.fromList ["genericEncodeJsonWith"] + [ ImportLine "Data.Argonaut.Decode.Generic" $ Set.singleton "genericDecodeJsonWith" + , ImportLine "Data.Argonaut.Encode.Generic" $ Set.singleton "genericEncodeJsonWith" + , ImportLine "Data.Argonaut.Types.Generic" $ Set.singleton "defaultEncoding" ] | otherwise = [] @@ -160,31 +144,28 @@ importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")" typeList = T.intercalate ", " (Set.toList (importTypes l)) sumTypeToDoc :: Switches.Settings -> SumType 'PureScript -> Doc -sumTypeToDoc settings st = sumTypeToTypeDecls settings st additionalCode +sumTypeToDoc settings st = vsep $ punctuate line [sumTypeToTypeDecls settings st, additionalCode] where additionalCode = if Switches.generateLenses settings then lenses - else mempty - lenses = vsep [dashes, sumTypeToOptics st, dashes] - dashes = textStrict $ T.replicate 80 "-" + else dashes + lenses = vsep $ punctuate line [dashes, sumTypeToOptics st, dashes] + dashes = textStrict (T.replicate 80 "-") sumTypeToTypeDecls :: Switches.Settings -> SumType 'PureScript -> Doc sumTypeToTypeDecls settings (SumType t cs is) = - vsep $ - concat - [ [ dataOrNewtype <+> typeInfoToDoc True t - , indent - 2 - (encloseVsep - ("=" <> space) - mempty - ("|" <> space) - (constructorToDoc <$> cs)) - ] - , [line] - , instances settings (SumType t cs (filter genArgonaut is)) - ] + vsep $ punctuate line $ + (dataOrNewtype <+> typeInfoToDoc True t + <> line + <> indent + 2 + (encloseVsep + ("=" <> space) + mempty + ("|" <> space) + (constructorToDoc <$> cs)) + ) : instances (SumType t cs (filter genArgonaut is)) where dataOrNewtype = if isJust (nootype cs) @@ -195,8 +176,8 @@ sumTypeToTypeDecls settings (SumType t cs is) = -- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. -instances :: Switches.Settings -> SumType 'PureScript -> [Doc] -instances settings st@(SumType t _ is) = go <$> is +instances :: SumType 'PureScript -> [Doc] +instances st@(SumType t _ is) = go <$> is where stpLength = length sumTypeParameters sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st @@ -213,13 +194,21 @@ instances settings st@(SumType t _ is) = go <$> is typeInfoToDoc False t <+> "where" <> linebreak <> - indent 2 "encodeJson = genericEncodeJsonWith defaultEncoding { valuesKey = \"contents\", unwrapSingleArguments = true }" <> + vsep + [ indent 2 "encodeJson =" + , indent 4 "genericEncodeJsonWith" + , indent 6 "defaultEncoding { valuesKey = \"contents\", unwrapSingleArguments = true }" + ] <> linebreak <> "instance decodeJson" <> name <+> "::" <+> extras decodeJsonInstance <+> "DecodeJson" <+> typeInfoToDoc False t <+> "where" <> linebreak <> - indent 2 "decodeJson = genericDecodeJsonWith defaultEncoding { valuesKey = \"contents\", unwrapSingleArguments = true }" + vsep + [ indent 2 "decodeJson =" + , indent 4 "genericDecodeJsonWith" + , indent 6 "defaultEncoding { valuesKey = \"contents\", unwrapSingleArguments = true }" + ] go GenericShow = "instance show" <> name <+> "::" <+> extras showInstance <+> "Show" <+> typeInfoToDoc False t <+> @@ -243,9 +232,7 @@ instances settings st@(SumType t _ is) = go <$> is where c = T.pack $ show i postfix Newtype = " _" - postfix Generic - | Switches.genericsGenRep settings = " _" - | otherwise = "" + postfix Generic = " _" postfix _ = "" constraintsInner :: [Doc] -> Doc @@ -269,12 +256,9 @@ decodeJsonInstance params = "DecodeJson" <+> typeInfoToDoc False params encodeJsonInstance :: PSType -> Doc encodeJsonInstance params = "EncodeJson" <+> typeInfoToDoc False params -genericInstance :: Switches.Settings -> PSType -> Doc -genericInstance settings params = - if not (Switches.genericsGenRep settings) - then "Generic" <+> typeInfoToDoc False params - else "Generic" <+> typeInfoToDoc False params <+> "r" <> - mergedTypeInfoToDoc params +genericInstance :: PSType -> Doc +genericInstance params = + "Generic" <+> typeInfoToDoc False params <+> "r" <> mergedTypeInfoToDoc params sumTypeToOptics :: SumType 'PureScript -> Doc sumTypeToOptics st = @@ -459,43 +443,68 @@ mergedTypeInfoToDoc t = textStrict (_typeName t) <> hcat textParameters params = _typeParameters t textParameters = mergedTypeInfoToDoc <$> params -sumTypesToModules :: Modules -> [SumType 'PureScript] -> Modules -sumTypesToModules = foldr sumTypeToModule - -sumTypeToModule :: SumType 'PureScript -> Modules -> Modules -sumTypeToModule st@(SumType t _ _) = - Map.alter (Just . updateModule) (_typeModule t) +sumTypesToModules :: [SumType 'PureScript] -> Modules +sumTypesToModules = foldr (Map.unionWith unionModules) Map.empty . fmap sumTypeToModule + +unionModules :: PSModule -> PSModule -> PSModule +unionModules m1 m2 = + m1 + { psImportLines = unionImportLines (psImportLines m1) (psImportLines m2) + , psTypes = psTypes m1 <> psTypes m2 + } + +sumTypeToModule :: SumType 'PureScript -> Modules +sumTypeToModule st@(SumType t _ is) = + Map.singleton + (_typeModule t) + $ PSModule + { psModuleName = _typeModule t + , psImportLines = + dropEmpty $ + dropPrelude $ + dropPrim $ + dropSelf $ + unionImportLines + (typesToImportLines (getUsedTypes st)) + (instancesToImportLines is) + , psTypes = [st] + } where - updateModule Nothing = - PSModule - { psModuleName = _typeModule t - , psImportLines = - dropSelf $ typesToImportLines Map.empty (getUsedTypes st) - , psTypes = [st] - } - updateModule (Just m) = - m - { psImportLines = - dropSelf $ typesToImportLines (psImportLines m) (getUsedTypes st) - , psTypes = st : psTypes m - } + dropEmpty = Map.delete "" + dropPrelude = Map.delete "Prelude" + dropPrim = Map.delete "Prim" dropSelf = Map.delete (_typeModule t) -typesToImportLines :: ImportLines -> Set PSType -> ImportLines -typesToImportLines = foldr typeToImportLines - -typeToImportLines :: PSType -> ImportLines -> ImportLines -typeToImportLines t ls = - typesToImportLines (update ls) (Set.fromList (_typeParameters t)) - where - update = - if not (T.null (_typeModule t)) - then Map.alter (Just . updateLine) (_typeModule t) - else id - updateLine Nothing = - ImportLine (_typeModule t) (Set.singleton (_typeName t)) - updateLine (Just (ImportLine m types)) = - ImportLine m $ Set.insert (_typeName t) types +unionImportLines :: ImportLines -> ImportLines -> ImportLines +unionImportLines = Map.unionWith unionImportLine + +unionImportLine :: ImportLine -> ImportLine -> ImportLine +unionImportLine l1 l2 = + l1 { importTypes = Set.union (importTypes l1) (importTypes l2) } + +typesToImportLines :: Set PSType -> ImportLines +typesToImportLines = + foldr unionImportLines Map.empty . fmap typeToImportLines . Set.toList + +typeToImportLines :: PSType -> ImportLines +typeToImportLines t = + unionImportLines (typesToImportLines $ Set.fromList (_typeParameters t)) $ + importsFromList [ImportLine (_typeModule t) (Set.singleton (_typeName t))] + +instancesToImportLines :: [Instance] -> ImportLines +instancesToImportLines = + foldr unionImportLines Map.empty . fmap instanceToImportLines + +instanceToImportLines :: Instance -> ImportLines +instanceToImportLines GenericShow = + importsFromList [ ImportLine "Data.Show.Generic" $ Set.singleton "genericShow" ] +instanceToImportLines Json = + importsFromList + [ ImportLine "Data.Argonaut.Decode.Generic" $ Set.singleton "genericDecodeJsonWith" + , ImportLine "Data.Argonaut.Encode.Generic" $ Set.singleton "genericEncodeJsonWith" + , ImportLine "Data.Argonaut.Types.Generic" $ Set.singleton "defaultEncoding" + ] +instanceToImportLines _ = Map.empty importsFromList :: [ImportLine] -> Map Text ImportLine importsFromList ls = diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index c1e898b4..29e56a92 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -79,7 +79,7 @@ mkSumType p = SumType (mkTypeInfo p) constructors - (Json : Generic : maybeToList (nootype constructors)) + (Generic : maybeToList (nootype constructors)) where constructors = gToConstructors (from (undefined :: t)) @@ -187,14 +187,35 @@ instance (Selector a, Typeable t) => GRecordEntry (S1 a (K1 R t)) where -- This includes all types found at the right hand side of a sum type -- definition, not the type parameters of the sum type itself getUsedTypes :: SumType lang -> Set (TypeInfo lang) -getUsedTypes (SumType _ cs _) = foldr constructorToTypes Set.empty cs +getUsedTypes (SumType _ cs is) = foldMap constructorToTypes cs <> foldMap instanceToTypes is constructorToTypes :: - DataConstructor lang -> Set (TypeInfo lang) -> Set (TypeInfo lang) -constructorToTypes (DataConstructor _ (Left myTs)) ts = - Set.fromList (concatMap flattenTypeInfo myTs) `Set.union` ts -constructorToTypes (DataConstructor _ (Right rs)) ts = - Set.fromList (concatMap (flattenTypeInfo . _recValue) rs) `Set.union` ts + DataConstructor lang -> Set (TypeInfo lang) +constructorToTypes (DataConstructor _ (Left myTs)) = + Set.fromList (concatMap flattenTypeInfo myTs) +constructorToTypes (DataConstructor _ (Right rs)) = + Set.fromList (concatMap (flattenTypeInfo . _recValue) rs) + +instanceToTypes :: Instance -> Set (TypeInfo lang) +instanceToTypes Generic = + Set.singleton $ TypeInfo "purescript-prelude" "Data.Generic.Rep" "class Generic" [] +instanceToTypes GenericShow = + Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Show" [] +instanceToTypes Json = + Set.fromList + [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "class DecodeJson" [] + , TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "class EncodeJson" [] + ] +instanceToTypes Newtype = + Set.singleton $ TypeInfo "purescript-newtype" "Data.Newtype" "class Newtype" [] +instanceToTypes Functor = + Set.singleton $ TypeInfo "purescript-functor" "Data.Functor" "class Functor" [] +instanceToTypes Eq = + Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Eq" [] +instanceToTypes Eq1 = + Set.singleton $ TypeInfo "purescript-prelude" "Data.Eq" "class Eq1" [] +instanceToTypes Ord = + Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Ord" [] -- Lenses: makeLenses ''DataConstructor diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs new file mode 100644 index 00000000..ef9349af --- /dev/null +++ b/test/RoundTrip/Spec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module RoundTrip.Spec where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, mkSumType, writePSTypes, writePSTypesWith, equal, order, genericShow, functor) +import Language.PureScript.Bridge.CodeGenSwitches (ArgonautOptions (ArgonautOptions), genArgonaut) +import Language.PureScript.Bridge.TypeParameters (A) +import RoundTrip.Types +import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) +import System.Exit (ExitCode (ExitSuccess)) +import System.Process (readProcessWithExitCode) +import Test.HUnit (assertEqual) +import Test.Hspec (Spec, aroundAll_, describe, it) +import Test.Hspec.Expectations.Pretty (shouldBe) + +myBridge :: BridgePart +myBridge = defaultBridge + +myTypes :: [SumType 'Haskell] +myTypes = + [ equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestData, + equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestSum, + functor <*> (equal <*> (genericShow <*> (order <*> mkSumType))) $ Proxy @(TestRecord A), + equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestNewtype, + equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestNewtypeRecord, + equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestNestedSum, + equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestEnum + ] + +roundtripSpec :: Spec +roundtripSpec = do + aroundAll_ withProject $ + describe "writePSTypesWith" $ + it "should be buildable" do + (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" + assertEqual (stdout <> stderr) exitCode ExitSuccess + where + withProject runSpec = + withCurrentDirectory "test/RoundTrip/app" $ generate *> runSpec + + generate = do + writePSTypesWith + (defaultSwitch <> genArgonaut ArgonautOptions) + "src" + (buildBridge myBridge) + myTypes diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs new file mode 100644 index 00000000..43324d73 --- /dev/null +++ b/test/RoundTrip/Types.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module RoundTrip.Types where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, mkSumType, writePSTypes, writePSTypesWith, defaultSwitch) +import Language.PureScript.Bridge.CodeGenSwitches (genArgonaut, ArgonautOptions (ArgonautOptions)) +import Language.PureScript.Bridge.TypeParameters (A) +import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) +import System.Exit (ExitCode (ExitSuccess)) +import System.Process (readProcessWithExitCode) +import Test.HUnit (assertEqual) +import Test.Hspec (Spec, aroundAll_, describe, it) +import Test.Hspec.Expectations.Pretty (shouldBe) + +data TestData + = Maybe (Maybe TestSum) + | Either (Either String TestSum) + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TestData + +instance ToJSON TestData + +data TestSum + = Nullary + | Bool Bool + | Int Int + | Number Double + | String String + | Array [String] + | Record (TestRecord Int) + | NestedRecord (TestRecord (TestRecord Int)) + | NT TestNewtype + | NTRecord TestNewtypeRecord + | Unit () + | Pair (Int, String) + | Triple (Int, String, Bool) + | Quad (Int, String, Bool, Double) + | NestedSum TestNestedSum + | Enum TestEnum + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TestSum + +instance ToJSON TestSum + +data TestRecord a = TestRecord + { field1 :: String, + field2 :: a + } + deriving (Show, Eq, Ord, Generic) + +instance (FromJSON a) => FromJSON (TestRecord a) + +instance (ToJSON a) => ToJSON (TestRecord a) + +newtype TestNewtype = TestNewtype (TestRecord String) + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TestNewtype + +instance ToJSON TestNewtype + +newtype TestNewtypeRecord = TestNewtypeRecord {unTestNewtypeRecord :: TestNewtype} + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TestNewtypeRecord + +instance ToJSON TestNewtypeRecord + +data TestNestedSum + = Case1 String + | Case2 Int + | Case3 (TestRecord Int) + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TestNestedSum + +instance ToJSON TestNestedSum + +data TestEnum + = Mon + | Tue + | Wed + | Thu + | Fri + | Sat + | Sun + deriving (Show, Eq, Ord, Bounded, Enum, Generic) + +instance FromJSON TestEnum + +instance ToJSON TestEnum diff --git a/test/Spec.hs b/test/Spec.hs index a11f2509..36c40faf 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -22,481 +22,21 @@ import TestData import Text.PrettyPrint.Leijen.Text (Doc, cat, linebreak, punctuate, vsep) +import RoundTrip.Spec (roundtripSpec) main :: IO () -main = hspec allTests +main = hspec $ allTests *> roundtripSpec allTests :: Spec allTests = do - describe "buildBridge for purescript 0.11" $ do - let settings = purs_0_11_settings - it "tests with Int" $ - let bst = buildBridge defaultBridge (mkTypeInfo (Proxy :: Proxy Int)) - ti = - TypeInfo - { _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Int" - , _typeParameters = [] - } - in bst `shouldBe` ti - it "tests with custom type Foo" $ - let prox = Proxy :: Proxy Foo - bst = - bridgeSumType - (buildBridge defaultBridge) - (order prox $ mkSumType prox) - st = - SumType - TypeInfo - { _typePackage = "" - , _typeModule = "TestData" - , _typeName = "Foo" - , _typeParameters = [] - } - [ DataConstructor {_sigConstructor = "Foo", _sigValues = Left []} - , DataConstructor - { _sigConstructor = "Bar" - , _sigValues = - Left - [ TypeInfo - { _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Int" - , _typeParameters = [] - } - ] - } - , DataConstructor - { _sigConstructor = "FooBar" - , _sigValues = - Left - [ TypeInfo - { _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Int" - , _typeParameters = [] - } - , TypeInfo - { _typePackage = "" - , _typeModule = "Prim" - , _typeName = "String" - , _typeParameters = [] - } - ] - } - ] - [Eq, Ord, Json, Generic] - in bst `shouldBe` st - it "tests generation of for custom type Foo" $ - let prox = Proxy :: Proxy Foo - recType = - bridgeSumType - (buildBridge defaultBridge) - (order prox $ mkSumType prox) - recTypeText = sumTypeToDoc 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" - , "--------------------------------------------------------------------------------" - , "_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 `shouldRender` 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.Eq (class Eq1)" - , "import Data.Generic (class Generic)" - , "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" - , "" - , "data Bar a b m c" - , " = Bar1 (Maybe a)" - , " | Bar2 (Either a b)" - , " | Bar3 a" - , " | Bar4" - , " { myMonadicResult :: m b" - , " }" - , "" - , "" - , "derive instance genericBar :: Generic (Bar a b m c)" - , "--------------------------------------------------------------------------------" - , "_Bar1 :: forall a b m c. Prism' (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. Prism' (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. Prism' (Bar a b m c) a" - , "_Bar3 = prism' Bar3 f" - , " where" - , " f (Bar3 a) = Just $ a" - , " f _ = Nothing" - , "" - , "_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" - , " f _ = Nothing" - , "--------------------------------------------------------------------------------" - ] - in m `shouldBe` txt - 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)) - 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" - , " where" - , " f (Bar1 a) = Just $ a" - , " f _ = Nothing" - , "" - , "_Bar2 :: forall a b m c. Prism' (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. Prism' (Bar a b m c) a" - , "_Bar3 = prism' Bar3 f" - , " where" - , " f (Bar3 a) = Just $ a" - , " f _ = Nothing" - , "" - , "_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" - , " f _ = Nothing" - , "" - , "_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 vsep (punctuate linebreak $ barOptics <> fooOptics) `shouldRender` - 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))) - barOptics = recordOptics bar - recTypeOptics = recordOptics recType - txt = - T.unlines - [ "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 cat (punctuate linebreak $ barOptics <> recTypeOptics) `shouldRender` - txt - it "tests generation of newtypes for record data type" $ - let recType = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType (Proxy :: Proxy (SingleRecord A B))) - recTypeText = sumTypeToDoc settings recType - txt = - T.unlines - [ "newtype SingleRecord a b" - , " = SingleRecord" - , " { _a :: a" - , " , _b :: b" - , " , c :: String" - , " }" - , "" - , "" - , "derive instance genericSingleRecord :: 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 `shouldRender` txt - it "tests generation of newtypes for haskell newtype" $ - let recType = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType (Proxy :: Proxy SomeNewtype)) - recTypeText = sumTypeToDoc settings recType - txt = - T.unlines - [ "newtype SomeNewtype" - , " = SomeNewtype Int" - , "" - , "" - , "derive instance genericSomeNewtype :: Generic SomeNewtype" - , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" - , "--------------------------------------------------------------------------------" - , "_SomeNewtype :: Iso' SomeNewtype Int" - , "_SomeNewtype = _Newtype" - , "--------------------------------------------------------------------------------" - ] - in recTypeText `shouldRender` txt - it "tests generation of newtypes for haskell data type with one argument" $ - let recType = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType (Proxy :: Proxy SingleValueConstr)) - recTypeText = sumTypeToDoc settings recType - txt = - T.unlines - [ "newtype SingleValueConstr" - , " = SingleValueConstr Int" - , "" - , "" - , "derive instance genericSingleValueConstr :: Generic SingleValueConstr" - , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" - , "--------------------------------------------------------------------------------" - , "_SingleValueConstr :: Iso' SingleValueConstr Int" - , "_SingleValueConstr = _Newtype" - , "--------------------------------------------------------------------------------" - ] - in recTypeText `shouldRender` txt - it - "tests generation for haskell data type with one constructor, two arguments" $ - let recType = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType (Proxy :: Proxy SingleProduct)) - recTypeText = sumTypeToDoc settings recType - txt = - T.unlines - [ "data SingleProduct" - , " = SingleProduct String Int" - , "" - , "" - , "derive instance genericSingleProduct :: Generic SingleProduct" - , "--------------------------------------------------------------------------------" - , "_SingleProduct :: Prism' SingleProduct { a :: String, b :: Int }" - , "_SingleProduct = prism' (\\{ a, b } -> SingleProduct a b) f" - , " where" - , " f (SingleProduct a b) = Just $ { a: a, b: b }" - , "--------------------------------------------------------------------------------" - ] - in recTypeText `shouldRender` 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 vsep recTypeOptics `shouldRender` "" -- No record optics for multi-constructors - 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) - recTypeText = sumTypeToDoc 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 `shouldRender` 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.Eq (class Eq1)" - , "import Data.Generic (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 (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 = sumTypeToDoc settings recType' - txt = - T.unlines - [ "newtype SingleRecord a b" - , " = SingleRecord" - , " { _a :: a" - , " , _b :: b" - , " , c :: String" - , " }" - , "" - , "" - , "derive instance genericSingleRecord :: Generic (SingleRecord a b)" - , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" - ] - in recTypeText `shouldRender` txt - it "tests generation of newtypes for haskell newtype" $ - let recType' = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType (Proxy :: Proxy SomeNewtype)) - recTypeText = sumTypeToDoc settings recType' - txt = - T.unlines - [ "newtype SomeNewtype" - , " = SomeNewtype Int" - , "" - , "" - , "derive instance genericSomeNewtype :: Generic SomeNewtype" - , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" - ] - in recTypeText `shouldRender` txt - it "tests generation of newtypes for haskell data type with one argument" $ - let recType' = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType (Proxy :: Proxy SingleValueConstr)) - recTypeText = sumTypeToDoc settings recType' - txt = - T.unlines - [ "newtype SingleValueConstr" - , " = SingleValueConstr Int" - , "" - , "" - , "derive instance genericSingleValueConstr :: Generic SingleValueConstr" - , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" - ] - in recTypeText `shouldRender` txt - it - "tests generation for haskell data type with one constructor, two arguments" $ - let recType' = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType (Proxy :: Proxy SingleProduct)) - recTypeText = sumTypeToDoc settings recType' - txt = - T.unlines - [ "data SingleProduct" - , " = SingleProduct String Int" - , "" - , "" - , "derive instance genericSingleProduct :: Generic SingleProduct" - ] - in recTypeText `shouldRender` txt - describe "buildBridge without lens-code-gen and generics-rep" $ do - let settings = getSettings (noLenses <> useGenRep) + describe "buildBridge without lens-code-gen" $ do + let settings = getSettings noLenses it "tests generation of typeclasses for custom type Foo" $ let proxy = Proxy :: Proxy Foo recType = bridgeSumType (buildBridge defaultBridge) + settings (genericShow proxy $ order proxy $ mkSumType proxy) recTypeText = sumTypeToDoc settings recType txt = @@ -506,12 +46,16 @@ allTests = do , " | Bar Int" , " | FooBar Int String" , "" - , "" , "instance showFoo :: Show Foo where" , " show x = genericShow x" + , "" , "derive instance eqFoo :: Eq Foo" + , "" , "derive instance ordFoo :: Ord Foo" + , "" , "derive instance genericFoo :: Generic Foo _" + , "" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldRender` txt it "tests generation of typeclasses for custom type Func" $ @@ -519,6 +63,7 @@ allTests = do recType = bridgeSumType (buildBridge defaultBridge) + settings (equal1 proxy $ functor proxy $ genericShow proxy $ mkSumType proxy) recTypeText = sumTypeToDoc settings recType txt = @@ -526,34 +71,35 @@ allTests = do [ "data Func a" , " = Func Int a" , "" - , "" , "derive instance eq1Func :: Eq1 Func" + , "" , "derive instance functorFunc :: Functor Func" + , "" , "instance showFunc :: (Show a) => Show (Func a) where" , " show x = genericShow x" + , "" , "derive instance genericFunc :: Generic (Func a) _" + , "" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldRender` txt it "tests the generation of a whole (dummy) module" $ let advanced' = bridgeSumType (buildBridge defaultBridge) + settings (mkSumType (Proxy :: Proxy (Bar A B M1 C))) - modules = sumTypeToModule advanced' Map.empty + modules = sumTypeToModule advanced' m = head . map (moduleToText settings) . Map.elems $ modules txt = T.unlines [ "-- File auto generated by purescript-bridge! --" , "module TestData where" , "" + , "import Prelude" , "import Data.Either (Either)" - , "import Data.Eq (class Eq1)" , "import Data.Generic.Rep (class Generic)" , "import Data.Maybe (Maybe, Maybe(..))" - , "import Data.Newtype (class Newtype)" - , "import Data.Show.Generic (genericShow)" - , "" - , "import Prelude" , "" , "data Bar a b m c" , " = Bar1 (Maybe a)" @@ -563,14 +109,16 @@ allTests = do , " { myMonadicResult :: m b" , " }" , "" - , "" , "derive instance genericBar :: Generic (Bar a b m c) _" + , "" + , "--------------------------------------------------------------------------------" ] in m `shouldBe` txt it "tests generation of newtypes for record data type" $ let recType' = bridgeSumType (buildBridge defaultBridge) + settings (mkSumType (Proxy :: Proxy (SingleRecord A B))) recTypeText = sumTypeToDoc settings recType' txt = @@ -582,15 +130,18 @@ allTests = do , " , c :: String" , " }" , "" - , "" , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" + , "" , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + , "" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldRender` txt it "tests generation of newtypes for haskell newtype" $ let recType' = bridgeSumType (buildBridge defaultBridge) + settings (mkSumType (Proxy :: Proxy SomeNewtype)) recTypeText = sumTypeToDoc settings recType' txt = @@ -598,15 +149,18 @@ allTests = do [ "newtype SomeNewtype" , " = SomeNewtype Int" , "" - , "" , "derive instance genericSomeNewtype :: Generic SomeNewtype _" + , "" , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" + , "" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldRender` txt it "tests generation of newtypes for haskell data type with one argument" $ let recType' = bridgeSumType (buildBridge defaultBridge) + settings (mkSumType (Proxy :: Proxy SingleValueConstr)) recTypeText = sumTypeToDoc settings recType' txt = @@ -614,9 +168,11 @@ allTests = do [ "newtype SingleValueConstr" , " = SingleValueConstr Int" , "" - , "" , "derive instance genericSingleValueConstr :: Generic SingleValueConstr _" + , "" , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" + , "" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldRender` txt it @@ -624,6 +180,7 @@ allTests = do let recType' = bridgeSumType (buildBridge defaultBridge) + settings (mkSumType (Proxy :: Proxy SingleProduct)) recTypeText = sumTypeToDoc settings recType' txt = @@ -631,14 +188,16 @@ allTests = do [ "data SingleProduct" , " = SingleProduct String Int" , "" - , "" , "derive instance genericSingleProduct :: Generic SingleProduct _" + , "" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldRender` txt it "tests generation Eq instances for polymorphic types" $ let recType' = bridgeSumType (buildBridge defaultBridge) + settings ((equal <*> mkSumType) (Proxy :: Proxy (SingleRecord A B))) recTypeText = sumTypeToDoc settings recType' txt = @@ -650,16 +209,20 @@ allTests = do , " , c :: String" , " }" , "" - , "" , "derive instance eqSingleRecord :: (Eq a, Eq b) => Eq (SingleRecord a b)" + , "" , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" + , "" , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + , "" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldRender` txt - it "tests generation Ord instances for polymorphic types" $ + it "tests generation of Ord instances for polymorphic types" $ let recType' = bridgeSumType (buildBridge defaultBridge) + settings ((order <*> mkSumType) (Proxy :: Proxy (SingleRecord A B))) recTypeText = sumTypeToDoc settings recType' txt = @@ -671,11 +234,15 @@ allTests = do , " , c :: String" , " }" , "" - , "" , "derive instance eqSingleRecord :: (Eq a, Eq b) => Eq (SingleRecord a b)" + , "" , "derive instance ordSingleRecord :: (Ord a, Ord b) => Ord (SingleRecord a b)" + , "" , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" + , "" , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + , "" + , "--------------------------------------------------------------------------------" ] in recTypeText `shouldRender` txt diff --git a/test/TestData.hs b/test/TestData.hs index 64d2c6d0..b1dfcf06 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -16,6 +16,7 @@ import Data.Typeable import GHC.Generics (Generic) import Language.PureScript.Bridge import Language.PureScript.Bridge.PSTypes +import Language.PureScript.Bridge.CodeGenSwitches (defaultSettings) @@ -91,4 +92,4 @@ b = mkSumType (Proxy :: Proxy (Either String Int)) t :: TypeInfo 'PureScript cs :: [DataConstructor 'PureScript] psB :: SumType 'PureScript -psB@(SumType t cs _) = bridgeSumType (buildBridge defaultBridge) b +psB@(SumType t cs _) = bridgeSumType (buildBridge defaultBridge) defaultSettings b From 6c5c39da8d893750fbf882576efa2a92428a7345 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 12 Oct 2021 17:59:05 -0400 Subject: [PATCH 033/111] Add Aesone round trip test --- purescript-bridge.cabal | 3 + src/Language/PureScript/Bridge/Printer.hs | 243 ++++++++++-- test/RoundTrip/Spec.hs | 11 +- test/RoundTrip/Types.hs | 50 +++ test/RoundTrip/app/spago.dhall | 8 +- test/RoundTrip/app/src/Main.purs | 20 +- test/RoundTrip/app/src/RoundTrip/Types.purs | 408 +++++++++++++++++--- 7 files changed, 667 insertions(+), 76 deletions(-) diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index 22c169c0..f1fab3cb 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -98,6 +98,7 @@ Test-Suite tests , RoundTrip.Spec , RoundTrip.Types build-depends: aeson + , bytestring , HUnit , base , containers @@ -106,7 +107,9 @@ Test-Suite tests , hspec-expectations-pretty-diff , process , purescript-bridge + , QuickCheck , text + , utf8-string , wl-pprint-text hs-source-dirs: test diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 5a987a34..2b2729af 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -7,7 +7,7 @@ module Language.PureScript.Bridge.Printer where import Control.Lens (filtered, to, traversed, (^.), (^..), (^?), - _Right, _head) + _Right, _head, view) import Control.Monad (unless) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -30,7 +30,7 @@ import Language.PureScript.Bridge.SumType (DataConstructor (Da sumTypeInfo, _recLabel) import Language.PureScript.Bridge.TypeInfo (Language (PureScript), - PSType, TypeInfo, + PSType, TypeInfo (TypeInfo), typeParameters, _typeModule, _typeName, @@ -54,7 +54,7 @@ import Text.PrettyPrint.Leijen.Text (Doc, cat, renderPretty, rparen, space, textStrict, vsep, - (<+>)) + (<+>), hang, dquotes, braces, int, lbracket, rbracket, list) renderText :: Doc -> Text renderText = displayTStrict . renderPretty 0.4 200 @@ -109,7 +109,7 @@ moduleToText settings m = where otherImports = importsFromList - (_lensImports settings <> _genericsImports <> _argonautImports settings) + (_lensImports settings <> _genericsImports) allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) _genericsImports :: [ImportLine] @@ -129,15 +129,6 @@ _lensImports settings | otherwise = [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] ] -_argonautImports :: Switches.Settings -> [ImportLine] -_argonautImports settings - | (isJust . Switches.generateArgonaut) settings = - [ ImportLine "Data.Argonaut.Decode.Generic" $ Set.singleton "genericDecodeJsonWith" - , ImportLine "Data.Argonaut.Encode.Generic" $ Set.singleton "genericEncodeJsonWith" - , ImportLine "Data.Argonaut.Types.Generic" $ Set.singleton "defaultEncoding" - ] - | otherwise = [] - importLineToText :: ImportLine -> Text importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")" where @@ -186,29 +177,19 @@ instances st@(SumType t _ is) = go <$> is | otherwise = constraintsInner (instanceConstraints <$> sumTypeParameters) <+> "=>" name = textStrict (_typeName t) - -- isEnum = all isNoArgConstructor cs - -- isNoArgConstructor c = (c ^. sigValues) == Left [] go :: Instance -> Doc go Json = "instance encodeJson" <> name <+> "::" <+> extras encodeJsonInstance <+> "EncodeJson" <+> typeInfoToDoc False t <+> "where" <> linebreak <> - vsep - [ indent 2 "encodeJson =" - , indent 4 "genericEncodeJsonWith" - , indent 6 "defaultEncoding { valuesKey = \"contents\", unwrapSingleArguments = true }" - ] <> + indent 2 (vsep ["encodeJson =", indent 2 (sumTypeToEncode st)]) <> linebreak <> "instance decodeJson" <> name <+> "::" <+> extras decodeJsonInstance <+> "DecodeJson" <+> typeInfoToDoc False t <+> "where" <> linebreak <> - vsep - [ indent 2 "decodeJson =" - , indent 4 "genericDecodeJsonWith" - , indent 6 "defaultEncoding { valuesKey = \"contents\", unwrapSingleArguments = true }" - ] + indent 2 (vsep ["decodeJson json =", indent 2 (sumTypeToDecode st)]) go GenericShow = "instance show" <> name <+> "::" <+> extras showInstance <+> "Show" <+> typeInfoToDoc False t <+> @@ -235,6 +216,205 @@ instances st@(SumType t _ is) = go <$> is postfix Generic = " _" postfix _ = "" +sumTypeToEncode :: SumType 'PureScript -> Doc +sumTypeToEncode (SumType _ cs _) + | isEnum = "fromString <<< show" + | otherwise = + hang 2 $ vsep + [ "case _ of" + , case cs of + [dc@(DataConstructor name args)] -> + hang 2 $ vsep [textStrict name <+> bindings args <+> "->", constructorToEncode dc] + _ -> vsep $ constructorToCase <$> cs + ] + where + isEnum = all isNoArgConstructor cs + isNoArgConstructor c = (c ^. sigValues) == Left [] + bindings args = case args of + Left values -> hsep $ ("v" <>) . int <$> [0..(length values - 1)] + Right entries -> braces $ hsep $ punctuate ", " $ textStrict . view recLabel <$> entries + constructorToCase dc@(DataConstructor name args)= + hang 2 $ vsep $ + [ textStrict name <+> bindings args <+> "->" + , "\"tag\" :=" <+> dquotes (textStrict name) <+> "~>" + ] <> + ( if args == Left [] + then [] + else [ "\"contents\" :=" + , indent 2 $ lparen <+> hang 2 (constructorToEncode dc) + , indent 2 $ rparen <+> "~>" + ] + ) + <> ["jsonEmptyObject"] + constructorToEncode (DataConstructor _ args) = + either typesToEncode recordEntriesToEncode args + +typesToEncode :: [PSType] -> Doc +typesToEncode [] = "jsonEmptyArray" +typesToEncode [a] = parens ("let a = v0 in" <+> typeToEncode a) +typesToEncode ts = + encodeArray (\(i, t) -> parens ("let a = v" <> int i <+> "in" <+> typeToEncode t)) (zip [0..] ts) + + +encodeArray :: (a -> Doc) -> [a] -> Doc +encodeArray adoc as = + hang 2 $ vsep + [ "fromArray" + , lbracket <+> mconcat (punctuate (line <> ", ") $ adoc <$> as) + , rbracket + ] + +typeToEncode :: PSType -> Doc +typeToEncode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = + "jsonEmptyArray" +typeToEncode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = + vsep + [ "case a of" + , indent 2 "Nothing -> jsonNull" + , indent 2 $ "Just a ->" <+> typeToEncode t + ] +typeToEncode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = + vsep + [ "case a of" + , indent 2 $ "Left a -> \"Left\" :=" <+> parens (typeToEncode l) <+> "~> jsonEmptyObject" + , indent 2 $ "Right a -> \"Right\" :=" <+> parens (typeToEncode r) <+> "~> jsonEmptyObject" + ] +typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple.Nested" _ ts) = + vsep + [ "case a of" <+> hsep (punctuate " /\\" $ (("v" <>) . int . fst <$> zip [0..] ts) <> ["unit"]) <+> "->" + , indent 4 $ lbracket <+> mconcat (punctuate (line <> ", ") $ (tupleElementToEncode <$> zip [0..] ts)) + , indent 4 rbracket + ] + where + tupleElementToEncode (i, t) = parens $ "let a = v" <> int i <+> "in" <+> typeToEncode t +typeToEncode _ = "encodeJson a" + + +recordEntriesToEncode :: [RecordEntry 'PureScript] -> Doc +recordEntriesToEncode rs = + vsep $ punctuate " ~>" $ (recordEntryToEncode <$> rs) <> ["jsonEmptyObject"] + +recordEntryToEncode :: RecordEntry 'PureScript -> Doc +recordEntryToEncode (RecordEntry name t) = + dquotes (textStrict name) + <+> ":=" + <+> parens ("let a =" <+> textStrict name <+> "in" <+> typeToEncode t) + +sumTypeToDecode :: SumType 'PureScript -> Doc +sumTypeToDecode (SumType _ cs _) + | isEnum = + vsep + [ "decodeJson json >>= case _ of" + , indent 2 $ vsep $ constructorToCase <$> cs + , indent 2 "_ -> Left (UnexpectedValue json)" + ] + where + isEnum = all isNoArgConstructor cs + isNoArgConstructor c = (c ^. sigValues) == Left [] + constructorToCase (DataConstructor name _) = dquotes (textStrict name) <+> "->" <+> "pure" <+> textStrict name +sumTypeToDecode (SumType _ [c] _) = constructorToDecode c +sumTypeToDecode (SumType _ cs _) = + vsep + [ "do" + , indent 2 $ vsep + [ "obj <- decodeJObject json" + , "tag <- obj .: \"tag\"" + , "json <- obj .:? \"contents\" .!= jsonNull" + , "case tag of" + , indent 2 $ vsep $ + ( ( \dc@(DataConstructor name _) -> + hang 2 $ dquotes (textStrict name) <+> "->" <+> constructorToDecode dc + ) + <$> cs + ) + <> ["_ -> Left $ AtKey \"tag\" (UnexpectedValue json)"] + ] + ] + +constructorToDecode :: DataConstructor 'PureScript -> Doc +constructorToDecode (DataConstructor name (Left args)) = + case args of + [] -> "pure" <+> textStrict name + [a] -> vsep + [ "lmap (AtKey \"contents\") $" <+> textStrict name <+> "<$>" + , wrapConstructorArg $ typeToDecode a + ] + _ -> vsep + [ "do" + , "arr <- decodeJArray json" + , "lmap (AtKey \"contents\") $" <+> textStrict name <+> "<$>" + , indent 2 $ vsep . punctuate " <*>" $ wrapConstructorArg . argToDecode <$> zip [0..] args + ] + where + wrapConstructorArg doc = vsep [hang 2 $ "(" <+> doc, ")"] + argToDecode (i, arg) = + hang 2 $ vsep + [ "do" + , "json <- maybe (Left $ AtIndex" <+> int i <+> "$ MissingValue) Right $ index arr" <+> int i + , typeToDecode arg + ] +constructorToDecode (DataConstructor name (Right args)) = + case args of + [] -> "pure $" <+> textStrict name <+> "{}" + _ -> + vsep + [ "do" + , indent 2 $ vsep $ + [ "x <- decodeJson json" ] + <> fieldDecodes + <> [ "pure $" + <+> textStrict name + <+> braces (hsep (punctuate ", " $ textStrict . view recLabel <$> args)) + ] + ] + where + fieldDecodes = fieldDecode <$> args + fieldDecode (RecordEntry label value) = + textStrict label + <+> "<-" + <+> "x .:" + <+> dquotes (textStrict label) + <+> ">>= \\json ->" + <+> typeToDecode value + +typeToDecode :: PSType -> Doc +typeToDecode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = + "unit <$ decodeArray (Left <<< UnexpectedValue) json" +typeToDecode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = + vsep $ punctuate " <|>" + [ "Nothing <$ decodeNull json" + , "Just <$>" <+> typeToDecode t + ] +typeToDecode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = + hang 2 $ vsep + [ "decodeJson json >>= \\obj ->" + , "Left <$>" <+> parens ("obj .: \"Left\" >>= \\json ->" <+> typeToDecode l) <+> "<|>" + , "Right <$>" <+> parens ("obj .: \"Right\" >>= \\json ->" <+> typeToDecode r) + ] +typeToDecode (TypeInfo "purescript-tuples" "Data.Tuple.Nested" _ ts) = + hang 2 $ vsep + [ "do" + , "arr <- decodeJArray json" + , vsep $ tupleElementToDecode <$> zip [0..] ts + , "pure $" <+> hsep (punctuate " /\\" $ (("v" <>) . int . fst <$> zip [0..] ts) <> ["unit"]) + ] + where + tupleElementToDecode (i, t) = + hang 2 $ vsep + [ "v" <> int i <+> "<-" + , hang 2 $ vsep + [ "maybe" + , "(Left $ AtIndex" <+> int i <+> "$ MissingValue)" + , vsep + [ "(\\json ->" + , indent 2 $ typeToDecode t + , ")" + ] + , "$ index arr" <+> int i + ] + ] +typeToDecode _ = "decodeJson json" + constraintsInner :: [Doc] -> Doc constraintsInner = encloseSep lparen rparen ("," <> space) @@ -500,9 +680,16 @@ instanceToImportLines GenericShow = importsFromList [ ImportLine "Data.Show.Generic" $ Set.singleton "genericShow" ] instanceToImportLines Json = importsFromList - [ ImportLine "Data.Argonaut.Decode.Generic" $ Set.singleton "genericDecodeJsonWith" - , ImportLine "Data.Argonaut.Encode.Generic" $ Set.singleton "genericEncodeJsonWith" - , ImportLine "Data.Argonaut.Types.Generic" $ Set.singleton "defaultEncoding" + [ ImportLine "Control.Alt" $ Set.singleton "(<|>)" + , ImportLine "Data.Array" $ Set.singleton "index" + , ImportLine "Data.Bifunctor" $ Set.singleton "lmap" + , ImportLine "Data.Argonaut.Core" $ Set.fromList ["jsonEmptyArray", "jsonEmptyObject", "jsonNull", "fromArray", "fromString"] + , ImportLine "Data.Argonaut.Decode" $ Set.fromList ["JsonDecodeError(..)", "(.:)", "(.:?)", "(.!=)", "decodeJson"] + , ImportLine "Data.Argonaut.Decode.Decoders" $ Set.fromList ["decodeJArray", "decodeJObject", "decodeArray", "decodeNull"] + , ImportLine "Data.Argonaut.Encode" $ Set.fromList ["(:=)", "(~>)", "encodeJson"] + , ImportLine "Data.Either" $ Set.singleton "Either(..)" + , ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)", "maybe"] + , ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" ] instanceToImportLines _ = Map.empty diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index ef9349af..757faf18 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -5,7 +5,8 @@ module RoundTrip.Spec where -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON (toJSON), fromJSON, eitherDecode, encode) +import Data.ByteString.Lazy.UTF8 (fromString, toString) import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, mkSumType, writePSTypes, writePSTypesWith, equal, order, genericShow, functor) @@ -18,6 +19,7 @@ import System.Process (readProcessWithExitCode) import Test.HUnit (assertEqual) import Test.Hspec (Spec, aroundAll_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.QuickCheck (prop) myBridge :: BridgePart myBridge = defaultBridge @@ -36,10 +38,15 @@ myTypes = roundtripSpec :: Spec roundtripSpec = do aroundAll_ withProject $ - describe "writePSTypesWith" $ + describe "writePSTypesWith" do it "should be buildable" do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" assertEqual (stdout <> stderr) exitCode ExitSuccess + prop "should produce aeson-compatible argonaut instances" $ + \testData -> do + (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["run"] $ toString $ encode @TestData testData + assertEqual stdout exitCode ExitSuccess + assertEqual stdout (eitherDecode (fromString stdout)) $ Right testData where withProject runSpec = withCurrentDirectory "test/RoundTrip/app" $ generate *> runSpec diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index 43324d73..e21fcce3 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -5,6 +5,7 @@ module RoundTrip.Types where +import Control.Applicative ((<|>)) import Data.Aeson (FromJSON, ToJSON) import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) @@ -17,6 +18,7 @@ import System.Process (readProcessWithExitCode) import Test.HUnit (assertEqual) import Test.Hspec (Spec, aroundAll_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.QuickCheck (Arbitrary(..), chooseEnum, oneof) data TestData = Maybe (Maybe TestSum) @@ -27,6 +29,12 @@ instance FromJSON TestData instance ToJSON TestData +instance Arbitrary TestData where + arbitrary = oneof + [ Maybe <$> arbitrary + , Either <$> arbitrary + ] + data TestSum = Nullary | Bool Bool @@ -42,6 +50,7 @@ data TestSum | Pair (Int, String) | Triple (Int, String, Bool) | Quad (Int, String, Bool, Double) + | QuadSimple Int String Bool Double | NestedSum TestNestedSum | Enum TestEnum deriving (Show, Eq, Ord, Generic) @@ -50,6 +59,27 @@ instance FromJSON TestSum instance ToJSON TestSum +instance Arbitrary TestSum where + arbitrary = oneof + [ pure Nullary + , Bool <$> arbitrary + , Int <$> arbitrary + , Number <$> arbitrary + , String <$> arbitrary + , Array <$> arbitrary + , Record <$> arbitrary + , NestedRecord <$> arbitrary + , NT <$> arbitrary + , NTRecord <$> arbitrary + , pure $ Unit () + , Pair <$> arbitrary + , Triple <$> arbitrary + , Quad <$> arbitrary + , QuadSimple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , NestedSum <$> arbitrary + , Enum <$> arbitrary + ] + data TestRecord a = TestRecord { field1 :: String, field2 :: a @@ -60,6 +90,9 @@ instance (FromJSON a) => FromJSON (TestRecord a) instance (ToJSON a) => ToJSON (TestRecord a) +instance (Arbitrary a) => Arbitrary (TestRecord a) where + arbitrary = TestRecord <$> arbitrary <*> arbitrary + newtype TestNewtype = TestNewtype (TestRecord String) deriving (Show, Eq, Ord, Generic) @@ -67,6 +100,9 @@ instance FromJSON TestNewtype instance ToJSON TestNewtype +instance Arbitrary TestNewtype where + arbitrary = TestNewtype <$> arbitrary + newtype TestNewtypeRecord = TestNewtypeRecord {unTestNewtypeRecord :: TestNewtype} deriving (Show, Eq, Ord, Generic) @@ -74,6 +110,9 @@ instance FromJSON TestNewtypeRecord instance ToJSON TestNewtypeRecord +instance Arbitrary TestNewtypeRecord where + arbitrary = TestNewtypeRecord <$> arbitrary + data TestNestedSum = Case1 String | Case2 Int @@ -84,6 +123,13 @@ instance FromJSON TestNestedSum instance ToJSON TestNestedSum +instance Arbitrary TestNestedSum where + arbitrary = oneof + [ Case1 <$> arbitrary + , Case2 <$> arbitrary + , Case3 <$> arbitrary + ] + data TestEnum = Mon | Tue @@ -97,3 +143,7 @@ data TestEnum instance FromJSON TestEnum instance ToJSON TestEnum + +instance Arbitrary TestEnum where + arbitrary = chooseEnum (minBound, maxBound) + diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index 66603c7f..41b68bad 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -3,14 +3,20 @@ [ "argonaut-codecs" , "argonaut-core" , "argonaut-generic" - , "console" + , "arrays" + , "bifunctors" + , "control" , "effect" , "either" , "maybe" , "newtype" + , "node-buffer" + , "node-process" + , "node-streams" , "prelude" , "profunctor-lenses" , "psci-support" + , "strings" , "tuples" ] , packages = ./packages.dhall diff --git a/test/RoundTrip/app/src/Main.purs b/test/RoundTrip/app/src/Main.purs index 5c18dca5..665c6479 100644 --- a/test/RoundTrip/app/src/Main.purs +++ b/test/RoundTrip/app/src/Main.purs @@ -2,9 +2,25 @@ module Main where import Prelude +import Data.Argonaut.Core (stringify) +import Data.Argonaut.Decode (JsonDecodeError, decodeJson, parseJson, printJsonDecodeError) +import Data.Argonaut.Encode (encodeJson) +import Data.Either (Either(..)) import Effect (Effect) -import Effect.Console (log) +import Node.Encoding (Encoding(..)) +import Node.Process (exit, stdin, stdout) +import Node.Stream (cork, onDataString, writeString) +import RoundTrip.Types (TestData) main :: Effect Unit main = do - log "🍝" + onDataString stdin UTF8 \input -> + let + parsed :: Either JsonDecodeError TestData + parsed = decodeJson =<< parseJson input + in + case parsed of + Left err -> + void $ writeString stdout UTF8 (show input <> "\n" <> printJsonDecodeError err) $ cork stdout *> exit 1 + Right testData -> + void $ writeString stdout UTF8 (stringify $ encodeJson testData) $ cork stdout diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index cdfd8f46..5661a89f 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -2,23 +2,25 @@ module RoundTrip.Types where import Prelude -import Data.Argonaut.Decode (class DecodeJson) -import Data.Argonaut.Decode.Generic (genericDecodeJsonWith) -import Data.Argonaut.Encode (class EncodeJson) -import Data.Argonaut.Encode.Generic (genericEncodeJsonWith) -import Data.Argonaut.Types.Generic (defaultEncoding) -import Data.Either (Either) +import Control.Alt ((<|>)) +import Data.Argonaut.Core (fromArray, fromString, jsonEmptyArray, jsonEmptyObject, jsonNull) +import Data.Argonaut.Decode ((.!=), (.:), (.:?), JsonDecodeError(..), class DecodeJson, decodeJson) +import Data.Argonaut.Decode.Decoders (decodeArray, decodeJArray, decodeJObject, decodeNull) +import Data.Argonaut.Encode ((:=), (~>), class EncodeJson, encodeJson) +import Data.Array (index) +import Data.Bifunctor (lmap) +import Data.Either (Either, Either(..)) import Data.Functor (class Functor) import Data.Generic.Rep (class Generic) 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.Maybe (Maybe, Maybe(..), maybe) import Data.Newtype (class Newtype) import Data.Show.Generic (genericShow) import Data.Symbol (SProxy(SProxy)) import Data.Tuple (Tuple) -import Data.Tuple.Nested (Tuple3, Tuple4) +import Data.Tuple.Nested ((/\), Tuple3, Tuple4) data TestData = Maybe (Maybe TestSum) @@ -26,12 +28,40 @@ data TestData instance encodeJsonTestData :: EncodeJson TestData where encodeJson = - genericEncodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + case _ of + Maybe v0 -> + "tag" := "Maybe" ~> + "contents" := + ( (let a = v0 in case a of + Nothing -> jsonNull + Just a -> encodeJson a) + ) ~> + jsonEmptyObject + Either v0 -> + "tag" := "Either" ~> + "contents" := + ( (let a = v0 in case a of + Left a -> "Left" := (encodeJson a) ~> jsonEmptyObject + Right a -> "Right" := (encodeJson a) ~> jsonEmptyObject) + ) ~> + jsonEmptyObject instance decodeJsonTestData :: DecodeJson TestData where - decodeJson = - genericDecodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + decodeJson json = + do + obj <- decodeJObject json + tag <- obj .: "tag" + json <- obj .:? "contents" .!= jsonNull + case tag of + "Maybe" -> lmap (AtKey "contents") $ Maybe <$> + ( Nothing <$ decodeNull json <|> + Just <$> decodeJson json + ) + "Either" -> lmap (AtKey "contents") $ Either <$> + ( decodeJson json >>= \obj -> + Left <$> (obj .: "Left" >>= \json -> decodeJson json) <|> + Right <$> (obj .: "Right" >>= \json -> decodeJson json) + ) + _ -> Left $ AtKey "tag" (UnexpectedValue json) derive instance eqTestData :: Eq TestData @@ -72,17 +102,252 @@ data TestSum | Pair (Tuple Int String) | Triple (Tuple3 Int String Boolean) | Quad (Tuple4 Int String Boolean Number) + | QuadSimple Int String Boolean Number | NestedSum TestNestedSum | Enum TestEnum instance encodeJsonTestSum :: EncodeJson TestSum where encodeJson = - genericEncodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + case _ of + Nullary -> + "tag" := "Nullary" ~> + jsonEmptyObject + Bool v0 -> + "tag" := "Bool" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + Int v0 -> + "tag" := "Int" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + Number v0 -> + "tag" := "Number" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + String v0 -> + "tag" := "String" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + Array v0 -> + "tag" := "Array" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + Record v0 -> + "tag" := "Record" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + NestedRecord v0 -> + "tag" := "NestedRecord" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + NT v0 -> + "tag" := "NT" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + NTRecord v0 -> + "tag" := "NTRecord" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + Unit v0 -> + "tag" := "Unit" ~> + "contents" := + ( (let a = v0 in jsonEmptyArray) + ) ~> + jsonEmptyObject + Pair v0 -> + "tag" := "Pair" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + Triple v0 -> + "tag" := "Triple" ~> + "contents" := + ( (let a = v0 in case a of v0 /\ v1 /\ v2 /\ unit -> + [ (let a = v0 in encodeJson a) + , (let a = v1 in encodeJson a) + , (let a = v2 in encodeJson a) + ]) + ) ~> + jsonEmptyObject + Quad v0 -> + "tag" := "Quad" ~> + "contents" := + ( (let a = v0 in case a of v0 /\ v1 /\ v2 /\ v3 /\ unit -> + [ (let a = v0 in encodeJson a) + , (let a = v1 in encodeJson a) + , (let a = v2 in encodeJson a) + , (let a = v3 in encodeJson a) + ]) + ) ~> + jsonEmptyObject + QuadSimple v0 v1 v2 v3 -> + "tag" := "QuadSimple" ~> + "contents" := + ( fromArray + [ (let a = v0 in encodeJson a) + , (let a = v1 in encodeJson a) + , (let a = v2 in encodeJson a) + , (let a = v3 in encodeJson a) + ] + ) ~> + jsonEmptyObject + NestedSum v0 -> + "tag" := "NestedSum" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + Enum v0 -> + "tag" := "Enum" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject instance decodeJsonTestSum :: DecodeJson TestSum where - decodeJson = - genericDecodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + decodeJson json = + do + obj <- decodeJObject json + tag <- obj .: "tag" + json <- obj .:? "contents" .!= jsonNull + case tag of + "Nullary" -> pure Nullary + "Bool" -> lmap (AtKey "contents") $ Bool <$> + ( decodeJson json + ) + "Int" -> lmap (AtKey "contents") $ Int <$> + ( decodeJson json + ) + "Number" -> lmap (AtKey "contents") $ Number <$> + ( decodeJson json + ) + "String" -> lmap (AtKey "contents") $ String <$> + ( decodeJson json + ) + "Array" -> lmap (AtKey "contents") $ Array <$> + ( decodeJson json + ) + "Record" -> lmap (AtKey "contents") $ Record <$> + ( decodeJson json + ) + "NestedRecord" -> lmap (AtKey "contents") $ NestedRecord <$> + ( decodeJson json + ) + "NT" -> lmap (AtKey "contents") $ NT <$> + ( decodeJson json + ) + "NTRecord" -> lmap (AtKey "contents") $ NTRecord <$> + ( decodeJson json + ) + "Unit" -> lmap (AtKey "contents") $ Unit <$> + ( unit <$ decodeArray (Left <<< UnexpectedValue) json + ) + "Pair" -> lmap (AtKey "contents") $ Pair <$> + ( decodeJson json + ) + "Triple" -> lmap (AtKey "contents") $ Triple <$> + ( do + arr <- decodeJArray json + v0 <- + maybe + (Left $ AtIndex 0 $ MissingValue) + (\json -> + decodeJson json + ) + $ index arr 0 + v1 <- + maybe + (Left $ AtIndex 1 $ MissingValue) + (\json -> + decodeJson json + ) + $ index arr 1 + v2 <- + maybe + (Left $ AtIndex 2 $ MissingValue) + (\json -> + decodeJson json + ) + $ index arr 2 + pure $ v0 /\ v1 /\ v2 /\ unit + ) + "Quad" -> lmap (AtKey "contents") $ Quad <$> + ( do + arr <- decodeJArray json + v0 <- + maybe + (Left $ AtIndex 0 $ MissingValue) + (\json -> + decodeJson json + ) + $ index arr 0 + v1 <- + maybe + (Left $ AtIndex 1 $ MissingValue) + (\json -> + decodeJson json + ) + $ index arr 1 + v2 <- + maybe + (Left $ AtIndex 2 $ MissingValue) + (\json -> + decodeJson json + ) + $ index arr 2 + v3 <- + maybe + (Left $ AtIndex 3 $ MissingValue) + (\json -> + decodeJson json + ) + $ index arr 3 + pure $ v0 /\ v1 /\ v2 /\ v3 /\ unit + ) + "QuadSimple" -> do + arr <- decodeJArray json + lmap (AtKey "contents") $ QuadSimple <$> + ( do + json <- maybe (Left $ AtIndex 0 $ MissingValue) Right $ index arr 0 + decodeJson json + ) <*> + ( do + json <- maybe (Left $ AtIndex 1 $ MissingValue) Right $ index arr 1 + decodeJson json + ) <*> + ( do + json <- maybe (Left $ AtIndex 2 $ MissingValue) Right $ index arr 2 + decodeJson json + ) <*> + ( do + json <- maybe (Left $ AtIndex 3 $ MissingValue) Right $ index arr 3 + decodeJson json + ) + "NestedSum" -> lmap (AtKey "contents") $ NestedSum <$> + ( decodeJson json + ) + "Enum" -> lmap (AtKey "contents") $ Enum <$> + ( decodeJson json + ) + _ -> Left $ AtKey "tag" (UnexpectedValue json) derive instance eqTestSum :: Eq TestSum @@ -179,6 +444,15 @@ _Quad = prism' Quad f f (Quad a) = Just $ a f _ = Nothing +_QuadSimple :: Prism' TestSum { a :: Int + , b :: String + , c :: Boolean + , d :: Number } +_QuadSimple = prism' (\{ a, b, c, d } -> QuadSimple a b c d) f + where + f (QuadSimple a b c d) = Just $ { a: a, b: b, c: c, d: d } + f _ = Nothing + _NestedSum :: Prism' TestSum TestNestedSum _NestedSum = prism' NestedSum f where @@ -200,12 +474,18 @@ newtype TestRecord a instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where encodeJson = - genericEncodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + case _ of + TestRecord {field1, field2} -> + "field1" := (let a = field1 in encodeJson a) ~> + "field2" := (let a = field2 in encodeJson a) ~> + jsonEmptyObject instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) where - decodeJson = - genericDecodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + decodeJson json = + do + x <- decodeJson json + field1 <- x .: "field1" >>= \json -> decodeJson json + field2 <- x .: "field2" >>= \json -> decodeJson json + pure $ TestRecord {field1, field2} derive instance functorTestRecord :: Functor TestRecord @@ -231,12 +511,14 @@ newtype TestNewtype instance encodeJsonTestNewtype :: EncodeJson TestNewtype where encodeJson = - genericEncodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + case _ of + TestNewtype v0 -> + (let a = v0 in encodeJson a) instance decodeJsonTestNewtype :: DecodeJson TestNewtype where - decodeJson = - genericDecodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + decodeJson json = + lmap (AtKey "contents") $ TestNewtype <$> + ( decodeJson json + ) derive instance eqTestNewtype :: Eq TestNewtype @@ -262,12 +544,16 @@ newtype TestNewtypeRecord instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where encodeJson = - genericEncodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + case _ of + TestNewtypeRecord {unTestNewtypeRecord} -> + "unTestNewtypeRecord" := (let a = unTestNewtypeRecord in encodeJson a) ~> + jsonEmptyObject instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where - decodeJson = - genericDecodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + decodeJson json = + do + x <- decodeJson json + unTestNewtypeRecord <- x .: "unTestNewtypeRecord" >>= \json -> decodeJson json + pure $ TestNewtypeRecord {unTestNewtypeRecord} derive instance eqTestNewtypeRecord :: Eq TestNewtypeRecord @@ -293,12 +579,42 @@ data TestNestedSum instance encodeJsonTestNestedSum :: EncodeJson TestNestedSum where encodeJson = - genericEncodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + case _ of + Case1 v0 -> + "tag" := "Case1" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + Case2 v0 -> + "tag" := "Case2" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject + Case3 v0 -> + "tag" := "Case3" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject instance decodeJsonTestNestedSum :: DecodeJson TestNestedSum where - decodeJson = - genericDecodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + decodeJson json = + do + obj <- decodeJObject json + tag <- obj .: "tag" + json <- obj .:? "contents" .!= jsonNull + case tag of + "Case1" -> lmap (AtKey "contents") $ Case1 <$> + ( decodeJson json + ) + "Case2" -> lmap (AtKey "contents") $ Case2 <$> + ( decodeJson json + ) + "Case3" -> lmap (AtKey "contents") $ Case3 <$> + ( decodeJson json + ) + _ -> Left $ AtKey "tag" (UnexpectedValue json) derive instance eqTestNestedSum :: Eq TestNestedSum @@ -341,12 +657,18 @@ data TestEnum instance encodeJsonTestEnum :: EncodeJson TestEnum where encodeJson = - genericEncodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + fromString <<< show instance decodeJsonTestEnum :: DecodeJson TestEnum where - decodeJson = - genericDecodeJsonWith - defaultEncoding { valuesKey = "contents", unwrapSingleArguments = true } + decodeJson json = + decodeJson json >>= case _ of + "Mon" -> pure Mon + "Tue" -> pure Tue + "Wed" -> pure Wed + "Thu" -> pure Thu + "Fri" -> pure Fri + "Sat" -> pure Sat + "Sun" -> pure Sun + _ -> Left (UnexpectedValue json) derive instance eqTestEnum :: Eq TestEnum From 44fe87f5f21266d26722d688e8d78ea03c71ee1a Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 13 Oct 2021 15:06:14 -0400 Subject: [PATCH 034/111] Spawn only one process and check warnings --- test/RoundTrip/Spec.hs | 48 +++++++++++++++------ test/RoundTrip/Types.hs | 10 +++++ test/RoundTrip/app/spago.dhall | 2 - test/RoundTrip/app/src/Main.purs | 16 ++++--- test/RoundTrip/app/src/RoundTrip/Types.purs | 45 +++++++++++++++++++ 5 files changed, 102 insertions(+), 19 deletions(-) diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 757faf18..5bb80fb0 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -5,21 +5,25 @@ module RoundTrip.Spec where -import Data.Aeson (FromJSON, ToJSON (toJSON), fromJSON, eitherDecode, encode) +import Control.Exception (bracket) +import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, encode, fromJSON) import Data.ByteString.Lazy.UTF8 (fromString, toString) +import Data.List (isInfixOf) import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) -import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, mkSumType, writePSTypes, writePSTypesWith, equal, order, genericShow, functor) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, equal, functor, genericShow, mkSumType, order, writePSTypes, writePSTypesWith) import Language.PureScript.Bridge.CodeGenSwitches (ArgonautOptions (ArgonautOptions), genArgonaut) import Language.PureScript.Bridge.TypeParameters (A) import RoundTrip.Types import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) -import System.Process (readProcessWithExitCode) -import Test.HUnit (assertEqual) -import Test.Hspec (Spec, aroundAll_, describe, it) +import System.IO (BufferMode (LineBuffering), hGetLine, hPutStrLn, hSetBuffering) +import System.Process (CreateProcess (std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess) +import Test.HUnit (assertBool, assertEqual) +import Test.Hspec (Spec, around, aroundAll_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck.Property (Testable (property)) myBridge :: BridgePart myBridge = defaultBridge @@ -32,7 +36,8 @@ myTypes = equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestNewtype, equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestNewtypeRecord, equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestNestedSum, - equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestEnum + equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestEnum, + equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @MyUnit ] roundtripSpec :: Spec @@ -41,13 +46,32 @@ roundtripSpec = do describe "writePSTypesWith" do it "should be buildable" do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" - assertEqual (stdout <> stderr) exitCode ExitSuccess - prop "should produce aeson-compatible argonaut instances" $ - \testData -> do - (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["run"] $ toString $ encode @TestData testData - assertEqual stdout exitCode ExitSuccess - assertEqual stdout (eitherDecode (fromString stdout)) $ Right testData + assertEqual (stdout <> stderr) ExitSuccess exitCode + it "should not warn of unused packages buildable" do + (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" + assertBool stderr $ not $ "[warn]" `isInfixOf` stderr + around withTestApp $ + it "should produce aeson-compatible argonaut instances" $ \(hin, hout, hproc) -> + property $ + \testData -> + do + hPutStrLn hin $ toString $ encode @TestData testData + output <- hGetLine hout + assertEqual output Nothing =<< getProcessExitCode hproc + assertEqual output (eitherDecode (fromString output)) $ Right testData where + withTestApp runSpec = + bracket runApp killApp runSpec + + runApp = do + (Just hin, Just hout, _, hproc) <- + createProcess (proc "spago" ["run"]) {std_in = CreatePipe, std_out = CreatePipe} + hSetBuffering hin LineBuffering + hSetBuffering hout LineBuffering + pure (hin, hout, hproc) + + killApp (_, _, hproc) = terminateProcess hproc + withProject runSpec = withCurrentDirectory "test/RoundTrip/app" $ generate *> runSpec diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index e21fcce3..37e1cf59 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -47,6 +47,7 @@ data TestSum | NT TestNewtype | NTRecord TestNewtypeRecord | Unit () + | MyUnit MyUnit | Pair (Int, String) | Triple (Int, String, Bool) | Quad (Int, String, Bool, Double) @@ -147,3 +148,12 @@ instance ToJSON TestEnum instance Arbitrary TestEnum where arbitrary = chooseEnum (minBound, maxBound) +data MyUnit = U deriving (Show, Eq, Ord, Bounded, Enum, Generic) + +instance FromJSON MyUnit + +instance ToJSON MyUnit + +instance Arbitrary MyUnit where + arbitrary = pure U + diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index 41b68bad..3e0b2fca 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -2,7 +2,6 @@ , dependencies = [ "argonaut-codecs" , "argonaut-core" - , "argonaut-generic" , "arrays" , "bifunctors" , "control" @@ -16,7 +15,6 @@ , "prelude" , "profunctor-lenses" , "psci-support" - , "strings" , "tuples" ] , packages = ./packages.dhall diff --git a/test/RoundTrip/app/src/Main.purs b/test/RoundTrip/app/src/Main.purs index 665c6479..614de168 100644 --- a/test/RoundTrip/app/src/Main.purs +++ b/test/RoundTrip/app/src/Main.purs @@ -9,7 +9,7 @@ import Data.Either (Either(..)) import Effect (Effect) import Node.Encoding (Encoding(..)) import Node.Process (exit, stdin, stdout) -import Node.Stream (cork, onDataString, writeString) +import Node.Stream (onDataString, onEnd, uncork, writeString) import RoundTrip.Types (TestData) main :: Effect Unit @@ -20,7 +20,13 @@ main = do parsed = decodeJson =<< parseJson input in case parsed of - Left err -> - void $ writeString stdout UTF8 (show input <> "\n" <> printJsonDecodeError err) $ cork stdout *> exit 1 - Right testData -> - void $ writeString stdout UTF8 (stringify $ encodeJson testData) $ cork stdout + Left err -> do + void + $ writeString stdout UTF8 (show input <> "\n" <> printJsonDecodeError err <> "\n") + $ uncork stdout + exit 1 + Right testData -> do + void + $ writeString stdout UTF8 (stringify (encodeJson testData) <> "\n") + $ uncork stdout + onEnd stdin $ exit 0 diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 5661a89f..a58c8983 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -99,6 +99,7 @@ data TestSum | NT TestNewtype | NTRecord TestNewtypeRecord | Unit Unit + | MyUnit MyUnit | Pair (Tuple Int String) | Triple (Tuple3 Int String Boolean) | Quad (Tuple4 Int String Boolean Number) @@ -172,6 +173,12 @@ instance encodeJsonTestSum :: EncodeJson TestSum where ( (let a = v0 in jsonEmptyArray) ) ~> jsonEmptyObject + MyUnit v0 -> + "tag" := "MyUnit" ~> + "contents" := + ( (let a = v0 in encodeJson a) + ) ~> + jsonEmptyObject Pair v0 -> "tag" := "Pair" ~> "contents" := @@ -260,6 +267,9 @@ instance decodeJsonTestSum :: DecodeJson TestSum where "Unit" -> lmap (AtKey "contents") $ Unit <$> ( unit <$ decodeArray (Left <<< UnexpectedValue) json ) + "MyUnit" -> lmap (AtKey "contents") $ MyUnit <$> + ( decodeJson json + ) "Pair" -> lmap (AtKey "contents") $ Pair <$> ( decodeJson json ) @@ -426,6 +436,12 @@ _Unit = prism' Unit f f (Unit a) = Just $ a f _ = Nothing +_MyUnit :: Prism' TestSum MyUnit +_MyUnit = prism' MyUnit f + where + f (MyUnit a) = Just $ a + f _ = Nothing + _Pair :: Prism' TestSum (Tuple Int String) _Pair = prism' Pair f where @@ -724,3 +740,32 @@ _Sun = prism' (\_ -> Sun) f f _ = Nothing -------------------------------------------------------------------------------- +data MyUnit + = U + +instance encodeJsonMyUnit :: EncodeJson MyUnit where + encodeJson = + fromString <<< show +instance decodeJsonMyUnit :: DecodeJson MyUnit where + decodeJson json = + decodeJson json >>= case _ of + "U" -> pure U + _ -> Left (UnexpectedValue json) + +derive instance eqMyUnit :: Eq MyUnit + +instance showMyUnit :: Show MyUnit where + show x = genericShow x + +derive instance ordMyUnit :: Ord MyUnit + +derive instance genericMyUnit :: Generic MyUnit _ + +-------------------------------------------------------------------------------- + +_U :: Prism' MyUnit Unit +_U = prism' (\_ -> U) f + where + f U = Just unit + +-------------------------------------------------------------------------------- From 1e0cebf22c65c9284e08df89f1c8b4dd16bdb492 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 13 Oct 2021 15:44:16 -0400 Subject: [PATCH 035/111] Remove Proxy from API --- src/Language/PureScript/Bridge.hs | 24 ++-- src/Language/PureScript/Bridge/Builder.hs | 2 +- .../PureScript/Bridge/CodeGenSwitches.hs | 22 +-- src/Language/PureScript/Bridge/Primitives.hs | 4 +- src/Language/PureScript/Bridge/Printer.hs | 36 ++--- src/Language/PureScript/Bridge/SumType.hs | 39 ++--- src/Language/PureScript/Bridge/TypeInfo.hs | 7 +- .../PureScript/Bridge/TypeParameters.hs | 2 +- test/RoundTrip/Spec.hs | 21 ++- test/RoundTrip/Types.hs | 65 ++++----- test/RoundTrip/app/src/RoundTrip/Types.purs | 134 ++++++++++-------- test/Spec.hs | 35 ++--- test/TestData.hs | 9 +- 13 files changed, 190 insertions(+), 210 deletions(-) diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index f7bd7d95..b1c721cb 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -14,7 +14,6 @@ module Language.PureScript.Bridge import Control.Applicative import qualified Data.Map as M -import Data.Maybe (isJust) import qualified Data.Set as Set import qualified Data.Text.IO as T @@ -39,9 +38,9 @@ import Language.PureScript.Bridge.TypeInfo as Bridge -- > -- | All types will have a `Generic` instance produced in Purescript. -- > myTypes :: [SumType 'Haskell] -- > myTypes = --- > [ let p = (Proxy :: Proxy Foo) in equal p (mkSumType p) -- Also produce a `Eq` instance. --- > , let p = (Proxy :: Proxy Bar) in order p (mkSumType p) -- Produce both `Eq` and `Ord`. --- > , mkSumType (Proxy :: Proxy Baz) -- Just produce a `Generic` instance. +-- > [ equal (mkSumType @Foo) -- Also produce a `Eq` instance. +-- > , order (mkSumType @Bar) -- Produce both `Eq` and `Ord`. +-- > , mkSumType @Baz -- Just produce a `Generic` instance. -- > ] -- > -- > writePSTypes "path/to/your/purescript/project" (buildBridge defaultBridge) myTypes @@ -99,16 +98,13 @@ writePSTypesWith switch root bridge sts = do T.putStrLn "\nSuccessfully created your PureScript modules!" where settings = Switches.getSettings switch - bridged = map (bridgeSumType bridge settings) sts + bridged = map (bridgeSumType bridge) sts modules = M.elems $ sumTypesToModules bridged packages = sumTypesToNeededPackages bridged <> Set.filter (const $ Switches.generateLenses settings) (Set.singleton "purescript-profunctor-lenses") - <> Set.filter - (const $ isJust $ Switches.generateArgonaut settings) - (Set.fromList ["purescript-argonaut-codecs", "purescript-argonaut-core", "purescript-argonaut-generic"]) -- | Translate all 'TypeInfo' values in a 'SumType' to PureScript types. -- @@ -116,14 +112,10 @@ writePSTypesWith switch root bridge sts = do -- -- > data Foo = Foo | Bar Int | FooBar Int Text deriving (Generic, Typeable, Show) -- --- > bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo)) -bridgeSumType :: FullBridge -> Settings -> SumType 'Haskell -> SumType 'PureScript -bridgeSumType br settings (SumType t cs is) = - SumType - (br t) - (map (bridgeConstructor br) cs) - $ maybe is (const $ Json : is) - $ Switches.generateArgonaut settings +-- > bridgeSumType (buildBridge defaultBridge) (mkSumType @Foo) +bridgeSumType :: FullBridge -> SumType 'Haskell -> SumType 'PureScript +bridgeSumType br (SumType t cs is) = + SumType (br t) (map (bridgeConstructor br) cs) is -- | Default bridge for mapping primitive/common types: -- You can append your own bridges like this: diff --git a/src/Language/PureScript/Bridge/Builder.hs b/src/Language/PureScript/Bridge/Builder.hs index 58568b13..aba8706b 100644 --- a/src/Language/PureScript/Bridge/Builder.hs +++ b/src/Language/PureScript/Bridge/Builder.hs @@ -100,7 +100,7 @@ data BridgeData = -- > stringBridge :: BridgePart -- > stringBridge = do -- > -- Note: we are using the HaskellType instance here: --- > haskType ^== mkTypeInfo (Proxy :: Proxy String) +-- > haskType ^== mkTypeInfo @String -- > return psString instance HasHaskType BridgeData where haskType inj (BridgeData iT fB) = flip BridgeData fB <$> inj iT diff --git a/src/Language/PureScript/Bridge/CodeGenSwitches.hs b/src/Language/PureScript/Bridge/CodeGenSwitches.hs index 4179b224..ee9130e3 100644 --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ b/src/Language/PureScript/Bridge/CodeGenSwitches.hs @@ -1,36 +1,26 @@ -- | General switches for the code generation, such as generating profunctor-lenses or not module Language.PureScript.Bridge.CodeGenSwitches ( Settings(..) - , ArgonautOptions(..) , defaultSettings , Switch , getSettings , defaultSwitch , noLenses , genLenses - , genArgonaut - , noArgonaut ) where import Data.Monoid (Endo(..)) -- | General settings for code generation -data Settings = +newtype Settings = Settings { generateLenses :: Bool -- ^use purescript-profunctor-lens for generated PS-types? - , generateArgonaut :: Maybe ArgonautOptions -- ^generate Argonaut EncodeJson and DecodeJson instances } deriving (Eq, Show) -data ArgonautOptions = - ArgonautOptions - -- { unwrapSingleConstructors :: Bool - -- } - deriving (Eq, Show) - -- | Settings to generate Lenses defaultSettings :: Settings -defaultSettings = Settings True Nothing +defaultSettings = Settings True -- | you can `mappend` switches to control the code generation type Switch = Endo Settings @@ -50,11 +40,3 @@ noLenses = Endo $ \settings -> settings {generateLenses = False} -- | Switch on the generatation of profunctor-lenses genLenses :: Switch genLenses = Endo $ \settings -> settings {generateLenses = True} - --- | Switch on the generatation of argonaut decode and encode instances -genArgonaut :: ArgonautOptions -> Switch -genArgonaut opts = Endo $ \settings -> settings {generateArgonaut = Just opts} - --- | Switch off the generatation of argonaut decode and encode instances -noArgonaut :: Switch -noArgonaut = Endo $ \settings -> settings {generateArgonaut = Nothing} diff --git a/src/Language/PureScript/Bridge/Primitives.hs b/src/Language/PureScript/Bridge/Primitives.hs index e9bdcfe9..a671d2af 100644 --- a/src/Language/PureScript/Bridge/Primitives.hs +++ b/src/Language/PureScript/Bridge/Primitives.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} module Language.PureScript.Bridge.Primitives where import Control.Monad.Reader.Class -import Data.Proxy import Language.PureScript.Bridge.Builder import Language.PureScript.Bridge.PSTypes import Language.PureScript.Bridge.TypeInfo @@ -34,7 +34,7 @@ maybeBridge = typeName ^== "Maybe" >> psMaybe stringBridge :: BridgePart stringBridge = - haskType ^== mkTypeInfo (Proxy :: Proxy String) >> return psString + haskType ^== mkTypeInfo @String >> return psString textBridge :: BridgePart textBridge = do diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 2b2729af..4e3de428 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -54,7 +54,7 @@ import Text.PrettyPrint.Leijen.Text (Doc, cat, renderPretty, rparen, space, textStrict, vsep, - (<+>), hang, dquotes, braces, int, lbracket, rbracket, list) + (<+>), hang, dquotes, braces, int, lbracket, rbracket) renderText :: Doc -> Text renderText = displayTStrict . renderPretty 0.4 200 @@ -124,7 +124,7 @@ _lensImports settings 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 "Type.Proxy" $ Set.fromList ["Proxy(Proxy)"] ] | otherwise = [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] ] @@ -135,7 +135,7 @@ importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")" typeList = T.intercalate ", " (Set.toList (importTypes l)) sumTypeToDoc :: Switches.Settings -> SumType 'PureScript -> Doc -sumTypeToDoc settings st = vsep $ punctuate line [sumTypeToTypeDecls settings st, additionalCode] +sumTypeToDoc settings st = vsep $ punctuate line [sumTypeToTypeDecls st, additionalCode] where additionalCode = if Switches.generateLenses settings @@ -144,8 +144,8 @@ sumTypeToDoc settings st = vsep $ punctuate line [sumTypeToTypeDecls settings st lenses = vsep $ punctuate line [dashes, sumTypeToOptics st, dashes] dashes = textStrict (T.replicate 80 "-") -sumTypeToTypeDecls :: Switches.Settings -> SumType 'PureScript -> Doc -sumTypeToTypeDecls settings (SumType t cs is) = +sumTypeToTypeDecls :: SumType 'PureScript -> Doc +sumTypeToTypeDecls (SumType t cs is) = vsep $ punctuate line $ (dataOrNewtype <+> typeInfoToDoc True t <> line @@ -156,14 +156,12 @@ sumTypeToTypeDecls settings (SumType t cs is) = mempty ("|" <> space) (constructorToDoc <$> cs)) - ) : instances (SumType t cs (filter genArgonaut is)) + ) : instances (SumType t cs is) where dataOrNewtype = if isJust (nootype cs) then "newtype" else "data" - genArgonaut Json = (isJust . Switches.generateArgonaut) settings - genArgonaut _ = True -- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. @@ -179,17 +177,13 @@ instances st@(SumType t _ is) = go <$> is name = textStrict (_typeName t) go :: Instance -> Doc go Json = - "instance encodeJson" <> name <+> "::" <+> extras encodeJsonInstance <+> "EncodeJson" <+> - typeInfoToDoc False t <+> - "where" <> - linebreak <> - indent 2 (vsep ["encodeJson =", indent 2 (sumTypeToEncode st)]) <> - linebreak <> - "instance decodeJson" <> name <+> "::" <+> extras decodeJsonInstance <+> "DecodeJson" <+> - typeInfoToDoc False t <+> - "where" <> - linebreak <> - indent 2 (vsep ["decodeJson json =", indent 2 (sumTypeToDecode st)]) + vsep + [ "instance encodeJson" <> name <+> "::" <+> extras encodeJsonInstance <+> "EncodeJson" <+> typeInfoToDoc False t <+> "where" + , indent 2 (vsep ["encodeJson =", indent 2 (sumTypeToEncode st)]) + , linebreak + , "instance decodeJson" <> name <+> "::" <+> extras decodeJsonInstance <+> "DecodeJson" <+> typeInfoToDoc False t <+> "where" + , indent 2 (vsep ["decodeJson json =", indent 2 (sumTypeToDecode st)]) + ] go GenericShow = "instance show" <> name <+> "::" <+> extras showInstance <+> "Show" <+> typeInfoToDoc False t <+> @@ -282,7 +276,7 @@ typeToEncode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple.Nested" _ ts) = vsep [ "case a of" <+> hsep (punctuate " /\\" $ (("v" <>) . int . fst <$> zip [0..] ts) <> ["unit"]) <+> "->" - , indent 4 $ lbracket <+> mconcat (punctuate (line <> ", ") $ (tupleElementToEncode <$> zip [0..] ts)) + , indent 4 $ lbracket <+> mconcat (punctuate (line <> ", ") $ tupleElementToEncode <$> zip [0..] ts) , indent 4 rbracket ] where @@ -585,7 +579,7 @@ recordEntryToLens st e = then vsep [ textStrict lensName <> forAll <> "Lens'" <+> typName <+> recType , textStrict lensName <+> "= _Newtype <<< prop" <+> - parens ("SProxy :: SProxy \"" <> textStrict recName <> "\"") + parens ("Proxy :: _ \"" <> textStrict recName <> "\"") ] else mempty where diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 29e56a92..27ceaca1 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,9 +9,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeApplications #-} module Language.PureScript.Bridge.SumType ( SumType(..) + , argonaut , mkSumType , genericShow , functor @@ -32,10 +35,8 @@ module Language.PureScript.Bridge.SumType ) where import Control.Lens hiding (from, to) -import Data.Functor.Classes (Eq1) import Data.List (nub) import Data.Maybe (maybeToList) -import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -70,14 +71,12 @@ sumTypeConstructors inj (SumType info constrs is) = -- | Create a representation of your sum (and product) types, -- for doing type translations and writing it out to your PureScript modules. --- 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 'Haskell +mkSumType = SumType - (mkTypeInfo p) + (mkTypeInfo @t) constructors (Generic : maybeToList (nootype constructors)) where @@ -108,26 +107,30 @@ nootype cs = isSingletonList [_] = True isSingletonList _ = False +-- | Ensure that aeson-compatible `EncodeJson` and `DecodeJson` instances are generated for your type. +argonaut :: SumType t -> SumType t +argonaut (SumType ti dc is) = SumType ti dc . nub $ Json : is + -- | Ensure that a generic `Show` instance is generated for your type. -genericShow :: Proxy a -> SumType t -> SumType t -genericShow _ (SumType ti dc is) = SumType ti dc . nub $ GenericShow : is +genericShow :: SumType t -> SumType t +genericShow (SumType ti dc is) = SumType ti dc . nub $ GenericShow : is -- | Ensure that a functor instance is generated for your type. It it -- your responsibility to ensure your type is a functor. -functor :: Proxy a -> SumType t -> SumType t -functor _ (SumType ti dc is) = SumType ti dc . nub $ Functor : is +functor :: SumType t -> SumType t +functor (SumType ti dc is) = SumType ti dc . nub $ Functor : is -- | Ensure that an `Eq` instance is generated for your type. -equal :: Eq a => Proxy a -> SumType t -> SumType t -equal _ (SumType ti dc is) = SumType ti dc . nub $ Eq : is +equal :: SumType t -> SumType t +equal (SumType ti dc is) = SumType ti dc . nub $ Eq : is -- | Ensure that an `Eq1` instance is generated for your type. -equal1 :: Eq1 f => Proxy (f a) -> SumType t -> SumType t -equal1 _ (SumType ti dc is) = SumType ti dc . nub $ Eq1 : is +equal1 :: SumType t -> SumType t +equal1 (SumType ti dc is) = SumType ti dc . nub $ Eq1 : is -- | Ensure that both `Eq` and `Ord` instances are generated for your type. -order :: Ord a => Proxy a -> SumType t -> SumType t -order _ (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is +order :: SumType t -> SumType t +order (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is data DataConstructor (lang :: Language) = DataConstructor @@ -178,7 +181,7 @@ instance (Selector a, Typeable t) => GRecordEntry (S1 a (K1 R t)) where gToRecordEntries e = [ RecordEntry { _recLabel = T.pack (selName e) - , _recValue = mkTypeInfo (Proxy :: Proxy t) + , _recValue = mkTypeInfo @t } ] diff --git a/src/Language/PureScript/Bridge/TypeInfo.hs b/src/Language/PureScript/Bridge/TypeInfo.hs index 4c132be7..d568df98 100644 --- a/src/Language/PureScript/Bridge/TypeInfo.hs +++ b/src/Language/PureScript/Bridge/TypeInfo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -5,6 +6,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Language.PureScript.Bridge.TypeInfo ( TypeInfo(..) @@ -58,8 +61,8 @@ class HasHaskType t where instance HasHaskType HaskellType where haskType inj = inj -mkTypeInfo :: Typeable t => Proxy t -> HaskellType -mkTypeInfo = mkTypeInfo' . typeRep +mkTypeInfo :: forall t. Typeable t => HaskellType +mkTypeInfo = mkTypeInfo' . typeRep $ Proxy @t mkTypeInfo' :: TypeRep -> HaskellType mkTypeInfo' rep = diff --git a/src/Language/PureScript/Bridge/TypeParameters.hs b/src/Language/PureScript/Bridge/TypeParameters.hs index a931578e..129dc358 100644 --- a/src/Language/PureScript/Bridge/TypeParameters.hs +++ b/src/Language/PureScript/Bridge/TypeParameters.hs @@ -75,7 +75,7 @@ data Z deriving (Eq, Ord) -- | You can use those if your type parameters are actually type constructors as well: -- @ --- st = mkSumType (Proxy :: Proxy ('ReaderT' R M1 A)) +-- st = mkSumType @('ReaderT' R M1 A) -- @ data A1 a diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 5bb80fb0..6a3be83a 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -11,8 +11,7 @@ import Data.ByteString.Lazy.UTF8 (fromString, toString) import Data.List (isInfixOf) import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) -import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, equal, functor, genericShow, mkSumType, order, writePSTypes, writePSTypesWith) -import Language.PureScript.Bridge.CodeGenSwitches (ArgonautOptions (ArgonautOptions), genArgonaut) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, equal, functor, genericShow, mkSumType, order, writePSTypes, writePSTypesWith, argonaut) import Language.PureScript.Bridge.TypeParameters (A) import RoundTrip.Types import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) @@ -30,14 +29,14 @@ myBridge = defaultBridge myTypes :: [SumType 'Haskell] myTypes = - [ equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestData, - equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestSum, - functor <*> (equal <*> (genericShow <*> (order <*> mkSumType))) $ Proxy @(TestRecord A), - equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestNewtype, - equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestNewtypeRecord, - equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestNestedSum, - equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @TestEnum, - equal <*> (genericShow <*> (order <*> mkSumType)) $ Proxy @MyUnit + [ equal . genericShow . order . argonaut $ mkSumType @TestData, + equal . genericShow . order . argonaut $ mkSumType @TestSum, + functor . equal . genericShow . order . argonaut $ mkSumType @(TestRecord A), + equal . genericShow . order . argonaut $ mkSumType @TestNewtype, + equal . genericShow . order . argonaut $ mkSumType @TestNewtypeRecord, + equal . genericShow . order . argonaut $ mkSumType @TestNestedSum, + equal . genericShow . order . argonaut $ mkSumType @TestEnum, + equal . genericShow . order . argonaut $ mkSumType @MyUnit ] roundtripSpec :: Spec @@ -77,7 +76,7 @@ roundtripSpec = do generate = do writePSTypesWith - (defaultSwitch <> genArgonaut ArgonautOptions) + defaultSwitch "src" (buildBridge myBridge) myTypes diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index 37e1cf59..668de085 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -9,8 +9,7 @@ import Control.Applicative ((<|>)) import Data.Aeson (FromJSON, ToJSON) import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) -import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, mkSumType, writePSTypes, writePSTypesWith, defaultSwitch) -import Language.PureScript.Bridge.CodeGenSwitches (genArgonaut, ArgonautOptions (ArgonautOptions)) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, mkSumType, writePSTypes, writePSTypesWith) import Language.PureScript.Bridge.TypeParameters (A) import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) @@ -18,7 +17,7 @@ import System.Process (readProcessWithExitCode) import Test.HUnit (assertEqual) import Test.Hspec (Spec, aroundAll_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) -import Test.QuickCheck (Arbitrary(..), chooseEnum, oneof) +import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof) data TestData = Maybe (Maybe TestSum) @@ -30,10 +29,11 @@ instance FromJSON TestData instance ToJSON TestData instance Arbitrary TestData where - arbitrary = oneof - [ Maybe <$> arbitrary - , Either <$> arbitrary - ] + arbitrary = + oneof + [ Maybe <$> arbitrary, + Either <$> arbitrary + ] data TestSum = Nullary @@ -61,25 +61,26 @@ instance FromJSON TestSum instance ToJSON TestSum instance Arbitrary TestSum where - arbitrary = oneof - [ pure Nullary - , Bool <$> arbitrary - , Int <$> arbitrary - , Number <$> arbitrary - , String <$> arbitrary - , Array <$> arbitrary - , Record <$> arbitrary - , NestedRecord <$> arbitrary - , NT <$> arbitrary - , NTRecord <$> arbitrary - , pure $ Unit () - , Pair <$> arbitrary - , Triple <$> arbitrary - , Quad <$> arbitrary - , QuadSimple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - , NestedSum <$> arbitrary - , Enum <$> arbitrary - ] + arbitrary = + oneof + [ pure Nullary, + Bool <$> arbitrary, + Int <$> arbitrary, + Number <$> arbitrary, + String <$> arbitrary, + Array <$> arbitrary, + Record <$> arbitrary, + NestedRecord <$> arbitrary, + NT <$> arbitrary, + NTRecord <$> arbitrary, + pure $ Unit (), + Pair <$> arbitrary, + Triple <$> arbitrary, + Quad <$> arbitrary, + QuadSimple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary, + NestedSum <$> arbitrary, + Enum <$> arbitrary + ] data TestRecord a = TestRecord { field1 :: String, @@ -125,11 +126,12 @@ instance FromJSON TestNestedSum instance ToJSON TestNestedSum instance Arbitrary TestNestedSum where - arbitrary = oneof - [ Case1 <$> arbitrary - , Case2 <$> arbitrary - , Case3 <$> arbitrary - ] + arbitrary = + oneof + [ Case1 <$> arbitrary, + Case2 <$> arbitrary, + Case3 <$> arbitrary + ] data TestEnum = Mon @@ -156,4 +158,3 @@ instance ToJSON MyUnit instance Arbitrary MyUnit where arbitrary = pure U - diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index a58c8983..553988b2 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -18,14 +18,21 @@ import Data.Lens.Record (prop) import Data.Maybe (Maybe, Maybe(..), maybe) import Data.Newtype (class Newtype) import Data.Show.Generic (genericShow) -import Data.Symbol (SProxy(SProxy)) import Data.Tuple (Tuple) import Data.Tuple.Nested ((/\), Tuple3, Tuple4) +import Type.Proxy (Proxy(Proxy)) data TestData = Maybe (Maybe TestSum) | Either (Either String TestSum) +derive instance eqTestData :: Eq TestData + +instance showTestData :: Show TestData where + show x = genericShow x + +derive instance ordTestData :: Ord TestData + instance encodeJsonTestData :: EncodeJson TestData where encodeJson = case _ of @@ -45,6 +52,8 @@ instance encodeJsonTestData :: EncodeJson TestData where Right a -> "Right" := (encodeJson a) ~> jsonEmptyObject) ) ~> jsonEmptyObject + + instance decodeJsonTestData :: DecodeJson TestData where decodeJson json = do @@ -63,13 +72,6 @@ instance decodeJsonTestData :: DecodeJson TestData where ) _ -> Left $ AtKey "tag" (UnexpectedValue json) -derive instance eqTestData :: Eq TestData - -instance showTestData :: Show TestData where - show x = genericShow x - -derive instance ordTestData :: Ord TestData - derive instance genericTestData :: Generic TestData _ -------------------------------------------------------------------------------- @@ -107,6 +109,13 @@ data TestSum | NestedSum TestNestedSum | Enum TestEnum +derive instance eqTestSum :: Eq TestSum + +instance showTestSum :: Show TestSum where + show x = genericShow x + +derive instance ordTestSum :: Ord TestSum + instance encodeJsonTestSum :: EncodeJson TestSum where encodeJson = case _ of @@ -229,6 +238,8 @@ instance encodeJsonTestSum :: EncodeJson TestSum where ( (let a = v0 in encodeJson a) ) ~> jsonEmptyObject + + instance decodeJsonTestSum :: DecodeJson TestSum where decodeJson json = do @@ -359,13 +370,6 @@ instance decodeJsonTestSum :: DecodeJson TestSum where ) _ -> Left $ AtKey "tag" (UnexpectedValue json) -derive instance eqTestSum :: Eq TestSum - -instance showTestSum :: Show TestSum where - show x = genericShow x - -derive instance ordTestSum :: Ord TestSum - derive instance genericTestSum :: Generic TestSum _ -------------------------------------------------------------------------------- @@ -488,6 +492,15 @@ newtype TestRecord a , field2 :: a } +derive instance functorTestRecord :: Functor TestRecord + +derive instance eqTestRecord :: (Eq a) => Eq (TestRecord a) + +instance showTestRecord :: (Show a) => Show (TestRecord a) where + show x = genericShow x + +derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) + instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where encodeJson = case _ of @@ -495,6 +508,8 @@ instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) whe "field1" := (let a = field1 in encodeJson a) ~> "field2" := (let a = field2 in encodeJson a) ~> jsonEmptyObject + + instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) where decodeJson json = do @@ -503,15 +518,6 @@ instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) whe field2 <- x .: "field2" >>= \json -> decodeJson json pure $ TestRecord {field1, field2} -derive instance functorTestRecord :: Functor TestRecord - -derive instance eqTestRecord :: (Eq a) => Eq (TestRecord a) - -instance showTestRecord :: (Show a) => Show (TestRecord a) where - show x = genericShow x - -derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) - derive instance genericTestRecord :: Generic (TestRecord a) _ derive instance newtypeTestRecord :: Newtype (TestRecord a) _ @@ -525,24 +531,26 @@ _TestRecord = _Newtype newtype TestNewtype = TestNewtype (TestRecord String) +derive instance eqTestNewtype :: Eq TestNewtype + +instance showTestNewtype :: Show TestNewtype where + show x = genericShow x + +derive instance ordTestNewtype :: Ord TestNewtype + instance encodeJsonTestNewtype :: EncodeJson TestNewtype where encodeJson = case _ of TestNewtype v0 -> (let a = v0 in encodeJson a) + + instance decodeJsonTestNewtype :: DecodeJson TestNewtype where decodeJson json = lmap (AtKey "contents") $ TestNewtype <$> ( decodeJson json ) -derive instance eqTestNewtype :: Eq TestNewtype - -instance showTestNewtype :: Show TestNewtype where - show x = genericShow x - -derive instance ordTestNewtype :: Ord TestNewtype - derive instance genericTestNewtype :: Generic TestNewtype _ derive instance newtypeTestNewtype :: Newtype TestNewtype _ @@ -558,12 +566,21 @@ newtype TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } +derive instance eqTestNewtypeRecord :: Eq TestNewtypeRecord + +instance showTestNewtypeRecord :: Show TestNewtypeRecord where + show x = genericShow x + +derive instance ordTestNewtypeRecord :: Ord TestNewtypeRecord + instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where encodeJson = case _ of TestNewtypeRecord {unTestNewtypeRecord} -> "unTestNewtypeRecord" := (let a = unTestNewtypeRecord in encodeJson a) ~> jsonEmptyObject + + instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where decodeJson json = do @@ -571,13 +588,6 @@ instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where unTestNewtypeRecord <- x .: "unTestNewtypeRecord" >>= \json -> decodeJson json pure $ TestNewtypeRecord {unTestNewtypeRecord} -derive instance eqTestNewtypeRecord :: Eq TestNewtypeRecord - -instance showTestNewtypeRecord :: Show TestNewtypeRecord where - show x = genericShow x - -derive instance ordTestNewtypeRecord :: Ord TestNewtypeRecord - derive instance genericTestNewtypeRecord :: Generic TestNewtypeRecord _ derive instance newtypeTestNewtypeRecord :: Newtype TestNewtypeRecord _ @@ -593,6 +603,13 @@ data TestNestedSum | Case2 Int | Case3 (TestRecord Int) +derive instance eqTestNestedSum :: Eq TestNestedSum + +instance showTestNestedSum :: Show TestNestedSum where + show x = genericShow x + +derive instance ordTestNestedSum :: Ord TestNestedSum + instance encodeJsonTestNestedSum :: EncodeJson TestNestedSum where encodeJson = case _ of @@ -614,6 +631,8 @@ instance encodeJsonTestNestedSum :: EncodeJson TestNestedSum where ( (let a = v0 in encodeJson a) ) ~> jsonEmptyObject + + instance decodeJsonTestNestedSum :: DecodeJson TestNestedSum where decodeJson json = do @@ -632,13 +651,6 @@ instance decodeJsonTestNestedSum :: DecodeJson TestNestedSum where ) _ -> Left $ AtKey "tag" (UnexpectedValue json) -derive instance eqTestNestedSum :: Eq TestNestedSum - -instance showTestNestedSum :: Show TestNestedSum where - show x = genericShow x - -derive instance ordTestNestedSum :: Ord TestNestedSum - derive instance genericTestNestedSum :: Generic TestNestedSum _ -------------------------------------------------------------------------------- @@ -671,9 +683,18 @@ data TestEnum | Sat | Sun +derive instance eqTestEnum :: Eq TestEnum + +instance showTestEnum :: Show TestEnum where + show x = genericShow x + +derive instance ordTestEnum :: Ord TestEnum + instance encodeJsonTestEnum :: EncodeJson TestEnum where encodeJson = fromString <<< show + + instance decodeJsonTestEnum :: DecodeJson TestEnum where decodeJson json = decodeJson json >>= case _ of @@ -686,13 +707,6 @@ instance decodeJsonTestEnum :: DecodeJson TestEnum where "Sun" -> pure Sun _ -> Left (UnexpectedValue json) -derive instance eqTestEnum :: Eq TestEnum - -instance showTestEnum :: Show TestEnum where - show x = genericShow x - -derive instance ordTestEnum :: Ord TestEnum - derive instance genericTestEnum :: Generic TestEnum _ -------------------------------------------------------------------------------- @@ -743,22 +757,24 @@ _Sun = prism' (\_ -> Sun) f data MyUnit = U +derive instance eqMyUnit :: Eq MyUnit + +instance showMyUnit :: Show MyUnit where + show x = genericShow x + +derive instance ordMyUnit :: Ord MyUnit + instance encodeJsonMyUnit :: EncodeJson MyUnit where encodeJson = fromString <<< show + + instance decodeJsonMyUnit :: DecodeJson MyUnit where decodeJson json = decodeJson json >>= case _ of "U" -> pure U _ -> Left (UnexpectedValue json) -derive instance eqMyUnit :: Eq MyUnit - -instance showMyUnit :: Show MyUnit where - show x = genericShow x - -derive instance ordMyUnit :: Ord MyUnit - derive instance genericMyUnit :: Generic MyUnit _ -------------------------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs index 36c40faf..9200ccd1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,12 +4,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Main where import qualified Data.Map as Map import Data.Monoid ((<>)) -import Data.Proxy import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Bridge @@ -32,12 +32,10 @@ allTests = do describe "buildBridge without lens-code-gen" $ do let settings = getSettings noLenses it "tests generation of typeclasses for custom type Foo" $ - let proxy = Proxy :: Proxy Foo - recType = + let recType = bridgeSumType (buildBridge defaultBridge) - settings - (genericShow proxy $ order proxy $ mkSumType proxy) + (genericShow . order $ mkSumType @Foo) recTypeText = sumTypeToDoc settings recType txt = T.unlines @@ -59,12 +57,10 @@ allTests = do ] in recTypeText `shouldRender` txt it "tests generation of typeclasses for custom type Func" $ - let proxy = Proxy :: Proxy (Func A) - recType = + let recType = bridgeSumType (buildBridge defaultBridge) - settings - (equal1 proxy $ functor proxy $ genericShow proxy $ mkSumType proxy) + (equal1 . functor . genericShow $ mkSumType @(Func A)) recTypeText = sumTypeToDoc settings recType txt = T.unlines @@ -87,8 +83,7 @@ allTests = do let advanced' = bridgeSumType (buildBridge defaultBridge) - settings - (mkSumType (Proxy :: Proxy (Bar A B M1 C))) + (mkSumType @(Bar A B M1 C)) modules = sumTypeToModule advanced' m = head . map (moduleToText settings) . Map.elems $ modules txt = @@ -118,8 +113,7 @@ allTests = do let recType' = bridgeSumType (buildBridge defaultBridge) - settings - (mkSumType (Proxy :: Proxy (SingleRecord A B))) + (mkSumType @(SingleRecord A B)) recTypeText = sumTypeToDoc settings recType' txt = T.unlines @@ -141,8 +135,7 @@ allTests = do let recType' = bridgeSumType (buildBridge defaultBridge) - settings - (mkSumType (Proxy :: Proxy SomeNewtype)) + (mkSumType @SomeNewtype) recTypeText = sumTypeToDoc settings recType' txt = T.unlines @@ -160,8 +153,7 @@ allTests = do let recType' = bridgeSumType (buildBridge defaultBridge) - settings - (mkSumType (Proxy :: Proxy SingleValueConstr)) + (mkSumType @SingleValueConstr) recTypeText = sumTypeToDoc settings recType' txt = T.unlines @@ -180,8 +172,7 @@ allTests = do let recType' = bridgeSumType (buildBridge defaultBridge) - settings - (mkSumType (Proxy :: Proxy SingleProduct)) + (mkSumType @SingleProduct) recTypeText = sumTypeToDoc settings recType' txt = T.unlines @@ -197,8 +188,7 @@ allTests = do let recType' = bridgeSumType (buildBridge defaultBridge) - settings - ((equal <*> mkSumType) (Proxy :: Proxy (SingleRecord A B))) + (equal $ mkSumType @(SingleRecord A B)) recTypeText = sumTypeToDoc settings recType' txt = T.unlines @@ -222,8 +212,7 @@ allTests = do let recType' = bridgeSumType (buildBridge defaultBridge) - settings - ((order <*> mkSumType) (Proxy :: Proxy (SingleRecord A B))) + (order $ mkSumType @(SingleRecord A B)) recTypeText = sumTypeToDoc settings recType' txt = T.unlines diff --git a/test/TestData.hs b/test/TestData.hs index b1dfcf06..c18966f2 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module TestData where @@ -29,7 +30,7 @@ textBridge = do stringBridge :: BridgePart stringBridge = do - haskType ^== mkTypeInfo (Proxy :: Proxy String) + haskType ^== mkTypeInfo @String return psString data Foo = Foo @@ -78,7 +79,7 @@ data SingleProduct = SingleProduct Text Int deriving (Generic, Typeable, Show) a :: HaskellType -a = mkTypeInfo (Proxy :: Proxy (Either String Int)) +a = mkTypeInfo @(Either String Int) applyBridge :: FullBridge applyBridge = buildBridge defaultBridge @@ -87,9 +88,9 @@ psA :: PSType psA = applyBridge a b :: SumType 'Haskell -b = mkSumType (Proxy :: Proxy (Either String Int)) +b = mkSumType @(Either String Int) t :: TypeInfo 'PureScript cs :: [DataConstructor 'PureScript] psB :: SumType 'PureScript -psB@(SumType t cs _) = bridgeSumType (buildBridge defaultBridge) defaultSettings b +psB@(SumType t cs _) = bridgeSumType (buildBridge defaultBridge) b From 1d311a8227b3bd88070ec3ad9a6f83f3d550e4ba Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 13 Oct 2021 16:14:08 -0400 Subject: [PATCH 036/111] Add lenses to test --- src/Language/PureScript/Bridge/Printer.hs | 24 ++++++--------------- test/RoundTrip/Types.hs | 4 ++-- test/RoundTrip/app/src/RoundTrip/Types.purs | 24 +++++++++++++-------- 3 files changed, 24 insertions(+), 28 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 4e3de428..181006bc 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -4,10 +4,7 @@ module Language.PureScript.Bridge.Printer where -import Control.Lens (filtered, to, - traversed, (^.), - (^..), (^?), - _Right, _head, view) +import Control.Lens (to, traversed,(^.), (^..), view) import Control.Monad (unless) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -448,19 +445,13 @@ constructorOptics st = typeInfo = st ^. sumTypeInfo recordOptics :: SumType 'PureScript -> [Doc] --- Match on SumTypes with a single DataConstructor (that's a list of a single element) -recordOptics st@(SumType _ [_] _) = recordEntryToLens st <$> dcRecords - where - cs = st ^. sumTypeConstructors - 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 st@(SumType _ [DataConstructor _ (Right fields)] _) = + recordEntryToLens st <$> filter hasUnderscore fields recordOptics _ = mempty +hasUnderscore :: RecordEntry lang -> Bool +hasUnderscore (RecordEntry name _) = "_" `T.isPrefixOf` name + constructorToDoc :: DataConstructor 'PureScript -> Doc constructorToDoc (DataConstructor n (Left [])) = textStrict n constructorToDoc (DataConstructor n (Left ts)) = @@ -575,7 +566,7 @@ constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Doc recordEntryToLens st e = - if hasUnderscore + if hasUnderscore e then vsep [ textStrict lensName <> forAll <> "Lens'" <+> typName <+> recType , textStrict lensName <+> "= _Newtype <<< prop" <+> @@ -587,7 +578,6 @@ recordEntryToLens st e = recName = e ^. recLabel lensName = T.drop 1 recName recType = typeInfoToDoc False (e ^. recValue) - hasUnderscore = e ^. recLabel . to (T.isPrefixOf "_") recordEntryToDoc :: RecordEntry 'PureScript -> Doc recordEntryToDoc e = diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index 668de085..786a06f1 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -83,8 +83,8 @@ instance Arbitrary TestSum where ] data TestRecord a = TestRecord - { field1 :: String, - field2 :: a + { _field1 :: String, + _field2 :: a } deriving (Show, Eq, Ord, Generic) diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 553988b2..3a33ff15 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -488,8 +488,8 @@ _Enum = prism' Enum f -------------------------------------------------------------------------------- newtype TestRecord a = TestRecord - { field1 :: String - , field2 :: a + { _field1 :: String + , _field2 :: a } derive instance functorTestRecord :: Functor TestRecord @@ -504,9 +504,9 @@ derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where encodeJson = case _ of - TestRecord {field1, field2} -> - "field1" := (let a = field1 in encodeJson a) ~> - "field2" := (let a = field2 in encodeJson a) ~> + TestRecord {_field1, _field2} -> + "_field1" := (let a = _field1 in encodeJson a) ~> + "_field2" := (let a = _field2 in encodeJson a) ~> jsonEmptyObject @@ -514,9 +514,9 @@ instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) whe decodeJson json = do x <- decodeJson json - field1 <- x .: "field1" >>= \json -> decodeJson json - field2 <- x .: "field2" >>= \json -> decodeJson json - pure $ TestRecord {field1, field2} + _field1 <- x .: "_field1" >>= \json -> decodeJson json + _field2 <- x .: "_field2" >>= \json -> decodeJson json + pure $ TestRecord {_field1, _field2} derive instance genericTestRecord :: Generic (TestRecord a) _ @@ -524,9 +524,15 @@ derive instance newtypeTestRecord :: Newtype (TestRecord a) _ -------------------------------------------------------------------------------- -_TestRecord :: forall a. Iso' (TestRecord a) { field1 :: String, field2 :: a } +_TestRecord :: forall a. Iso' (TestRecord a) { _field1 :: String, _field2 :: a } _TestRecord = _Newtype +field1 :: forall a. Lens' (TestRecord a) String +field1 = _Newtype <<< prop (Proxy :: _ "_field1") + +field2 :: forall a. Lens' (TestRecord a) a +field2 = _Newtype <<< prop (Proxy :: _ "_field2") + -------------------------------------------------------------------------------- newtype TestNewtype = TestNewtype (TestRecord String) From f9c9fe98fc8935ba4b40ef4a547c744b8b8065fb Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 13 Oct 2021 17:16:28 -0400 Subject: [PATCH 037/111] Fix bugs with nested decoders --- src/Language/PureScript/Bridge/Printer.hs | 5 +++-- test/RoundTrip/Spec.hs | 19 ++++++++++++------- test/RoundTrip/app/src/RoundTrip/Types.purs | 14 +++++++++----- 3 files changed, 24 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 181006bc..96e04914 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -342,7 +342,8 @@ constructorToDecode (DataConstructor name (Left args)) = hang 2 $ vsep [ "do" , "json <- maybe (Left $ AtIndex" <+> int i <+> "$ MissingValue) Right $ index arr" <+> int i - , typeToDecode arg + , hang 2 $ lparen <+> typeToDecode arg + , rparen ] constructorToDecode (DataConstructor name (Right args)) = case args of @@ -374,7 +375,7 @@ typeToDecode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = typeToDecode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = vsep $ punctuate " <|>" [ "Nothing <$ decodeNull json" - , "Just <$>" <+> typeToDecode t + , "Just <$>" <+> parens (typeToDecode t) ] typeToDecode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = hang 2 $ vsep diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 6a3be83a..ba6f9012 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -1,28 +1,32 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module RoundTrip.Spec where import Control.Exception (bracket) import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, encode, fromJSON) -import Data.ByteString.Lazy.UTF8 (fromString, toString) +import Data.ByteString.Lazy (stripSuffix) +import Data.ByteString.Lazy.UTF8 (toString, fromString) import Data.List (isInfixOf) import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) -import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, equal, functor, genericShow, mkSumType, order, writePSTypes, writePSTypesWith, argonaut) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, argonaut, buildBridge, defaultBridge, defaultSwitch, equal, functor, genericShow, mkSumType, order, writePSTypes, writePSTypesWith) import Language.PureScript.Bridge.TypeParameters (A) import RoundTrip.Types import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) -import System.IO (BufferMode (LineBuffering), hGetLine, hPutStrLn, hSetBuffering) +import System.IO (BufferMode (..), hSetBuffering, hGetLine, hPutStrLn) import System.Process (CreateProcess (std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess) import Test.HUnit (assertBool, assertEqual) import Test.Hspec (Spec, around, aroundAll_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck.Property (Testable (property)) +import Data.Maybe (fromMaybe) +import Test.QuickCheck (verbose, once) myBridge :: BridgePart myBridge = defaultBridge @@ -45,7 +49,7 @@ roundtripSpec = do describe "writePSTypesWith" do it "should be buildable" do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" - assertEqual (stdout <> stderr) ExitSuccess exitCode + assertEqual (stdout <> stderr) exitCode ExitSuccess it "should not warn of unused packages buildable" do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" assertBool stderr $ not $ "[warn]" `isInfixOf` stderr @@ -55,9 +59,10 @@ roundtripSpec = do \testData -> do hPutStrLn hin $ toString $ encode @TestData testData - output <- hGetLine hout - assertEqual output Nothing =<< getProcessExitCode hproc - assertEqual output (eitherDecode (fromString output)) $ Right testData + output <- fromString <$> hGetLine hout + let output = fromMaybe output $ stripSuffix "\n" output + flip (assertEqual (toString output)) Nothing =<< getProcessExitCode hproc + assertEqual (toString output) (Right testData) $ eitherDecode output where withTestApp runSpec = bracket runApp killApp runSpec diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 3a33ff15..1229685c 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -63,7 +63,7 @@ instance decodeJsonTestData :: DecodeJson TestData where case tag of "Maybe" -> lmap (AtKey "contents") $ Maybe <$> ( Nothing <$ decodeNull json <|> - Just <$> decodeJson json + Just <$> (decodeJson json) ) "Either" -> lmap (AtKey "contents") $ Either <$> ( decodeJson json >>= \obj -> @@ -348,19 +348,23 @@ instance decodeJsonTestSum :: DecodeJson TestSum where lmap (AtKey "contents") $ QuadSimple <$> ( do json <- maybe (Left $ AtIndex 0 $ MissingValue) Right $ index arr 0 - decodeJson json + ( decodeJson json + ) ) <*> ( do json <- maybe (Left $ AtIndex 1 $ MissingValue) Right $ index arr 1 - decodeJson json + ( decodeJson json + ) ) <*> ( do json <- maybe (Left $ AtIndex 2 $ MissingValue) Right $ index arr 2 - decodeJson json + ( decodeJson json + ) ) <*> ( do json <- maybe (Left $ AtIndex 3 $ MissingValue) Right $ index arr 3 - decodeJson json + ( decodeJson json + ) ) "NestedSum" -> lmap (AtKey "contents") $ NestedSum <$> ( decodeJson json From 69f69a5fd8ca39562724103241a65b0d0636d937 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 13 Oct 2021 17:25:50 -0400 Subject: [PATCH 038/111] Simplify test type --- .../PureScript/Bridge/TypeParameters.hs | 2 +- test/RoundTrip/Spec.hs | 1 - test/RoundTrip/Types.hs | 36 +---- test/RoundTrip/app/src/RoundTrip/Types.purs | 144 ++++-------------- 4 files changed, 38 insertions(+), 145 deletions(-) diff --git a/src/Language/PureScript/Bridge/TypeParameters.hs b/src/Language/PureScript/Bridge/TypeParameters.hs index 129dc358..6b59fea3 100644 --- a/src/Language/PureScript/Bridge/TypeParameters.hs +++ b/src/Language/PureScript/Bridge/TypeParameters.hs @@ -17,7 +17,7 @@ -- import "Language.PureScript.Bridge" -- import "Language.PureScript.Bridge.TypeParameters" -- --- st = mkSumType ('Proxy' :: 'Proxy' (Maybe' A)) -- Note that we use "Maybe' A" instead of just Maybe - which would not work. +-- st = mkSumType @(Maybe' A) -- Note that we use "Maybe' A" instead of just Maybe - which would not work. -- @ module Language.PureScript.Bridge.TypeParameters where diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index ba6f9012..30bb2800 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -38,7 +38,6 @@ myTypes = functor . equal . genericShow . order . argonaut $ mkSumType @(TestRecord A), equal . genericShow . order . argonaut $ mkSumType @TestNewtype, equal . genericShow . order . argonaut $ mkSumType @TestNewtypeRecord, - equal . genericShow . order . argonaut $ mkSumType @TestNestedSum, equal . genericShow . order . argonaut $ mkSumType @TestEnum, equal . genericShow . order . argonaut $ mkSumType @MyUnit ] diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index 786a06f1..de94cfb3 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -21,7 +21,7 @@ import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof) data TestData = Maybe (Maybe TestSum) - | Either (Either String TestSum) + | Either (Either (Maybe Int) (Maybe Bool)) deriving (Show, Eq, Ord, Generic) instance FromJSON TestData @@ -41,18 +41,17 @@ data TestSum | Int Int | Number Double | String String - | Array [String] + | Array [Int] | Record (TestRecord Int) | NestedRecord (TestRecord (TestRecord Int)) | NT TestNewtype | NTRecord TestNewtypeRecord | Unit () | MyUnit MyUnit - | Pair (Int, String) - | Triple (Int, String, Bool) - | Quad (Int, String, Bool, Double) - | QuadSimple Int String Bool Double - | NestedSum TestNestedSum + | Pair (Int, Double) + | Triple (Int, (), Bool) + | Quad (Int, Double, Bool, Double) + | QuadSimple Int Double Bool Double | Enum TestEnum deriving (Show, Eq, Ord, Generic) @@ -78,12 +77,11 @@ instance Arbitrary TestSum where Triple <$> arbitrary, Quad <$> arbitrary, QuadSimple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary, - NestedSum <$> arbitrary, Enum <$> arbitrary ] data TestRecord a = TestRecord - { _field1 :: String, + { _field1 :: Int, _field2 :: a } deriving (Show, Eq, Ord, Generic) @@ -95,7 +93,7 @@ instance (ToJSON a) => ToJSON (TestRecord a) instance (Arbitrary a) => Arbitrary (TestRecord a) where arbitrary = TestRecord <$> arbitrary <*> arbitrary -newtype TestNewtype = TestNewtype (TestRecord String) +newtype TestNewtype = TestNewtype (TestRecord Bool) deriving (Show, Eq, Ord, Generic) instance FromJSON TestNewtype @@ -115,24 +113,6 @@ instance ToJSON TestNewtypeRecord instance Arbitrary TestNewtypeRecord where arbitrary = TestNewtypeRecord <$> arbitrary -data TestNestedSum - = Case1 String - | Case2 Int - | Case3 (TestRecord Int) - deriving (Show, Eq, Ord, Generic) - -instance FromJSON TestNestedSum - -instance ToJSON TestNestedSum - -instance Arbitrary TestNestedSum where - arbitrary = - oneof - [ Case1 <$> arbitrary, - Case2 <$> arbitrary, - Case3 <$> arbitrary - ] - data TestEnum = Mon | Tue diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 1229685c..8076bf59 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -24,7 +24,7 @@ import Type.Proxy (Proxy(Proxy)) data TestData = Maybe (Maybe TestSum) - | Either (Either String TestSum) + | Either (Either (Maybe Int) (Maybe Boolean)) derive instance eqTestData :: Eq TestData @@ -48,8 +48,12 @@ instance encodeJsonTestData :: EncodeJson TestData where "tag" := "Either" ~> "contents" := ( (let a = v0 in case a of - Left a -> "Left" := (encodeJson a) ~> jsonEmptyObject - Right a -> "Right" := (encodeJson a) ~> jsonEmptyObject) + Left a -> "Left" := (case a of + Nothing -> jsonNull + Just a -> encodeJson a) ~> jsonEmptyObject + Right a -> "Right" := (case a of + Nothing -> jsonNull + Just a -> encodeJson a) ~> jsonEmptyObject) ) ~> jsonEmptyObject @@ -67,8 +71,10 @@ instance decodeJsonTestData :: DecodeJson TestData where ) "Either" -> lmap (AtKey "contents") $ Either <$> ( decodeJson json >>= \obj -> - Left <$> (obj .: "Left" >>= \json -> decodeJson json) <|> - Right <$> (obj .: "Right" >>= \json -> decodeJson json) + Left <$> (obj .: "Left" >>= \json -> Nothing <$ decodeNull json <|> + Just <$> (decodeJson json)) <|> + Right <$> (obj .: "Right" >>= \json -> Nothing <$ decodeNull json <|> + Just <$> (decodeJson json)) ) _ -> Left $ AtKey "tag" (UnexpectedValue json) @@ -82,7 +88,7 @@ _Maybe = prism' Maybe f f (Maybe a) = Just $ a f _ = Nothing -_Either :: Prism' TestData (Either String TestSum) +_Either :: Prism' TestData (Either (Maybe Int) (Maybe Boolean)) _Either = prism' Either f where f (Either a) = Just $ a @@ -95,18 +101,17 @@ data TestSum | Int Int | Number Number | String String - | Array (Array String) + | Array (Array Int) | Record (TestRecord Int) | NestedRecord (TestRecord (TestRecord Int)) | NT TestNewtype | NTRecord TestNewtypeRecord | Unit Unit | MyUnit MyUnit - | Pair (Tuple Int String) - | Triple (Tuple3 Int String Boolean) - | Quad (Tuple4 Int String Boolean Number) - | QuadSimple Int String Boolean Number - | NestedSum TestNestedSum + | Pair (Tuple Int Number) + | Triple (Tuple3 Int Unit Boolean) + | Quad (Tuple4 Int Number Boolean Number) + | QuadSimple Int Number Boolean Number | Enum TestEnum derive instance eqTestSum :: Eq TestSum @@ -199,7 +204,7 @@ instance encodeJsonTestSum :: EncodeJson TestSum where "contents" := ( (let a = v0 in case a of v0 /\ v1 /\ v2 /\ unit -> [ (let a = v0 in encodeJson a) - , (let a = v1 in encodeJson a) + , (let a = v1 in jsonEmptyArray) , (let a = v2 in encodeJson a) ]) ) ~> @@ -226,12 +231,6 @@ instance encodeJsonTestSum :: EncodeJson TestSum where ] ) ~> jsonEmptyObject - NestedSum v0 -> - "tag" := "NestedSum" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject Enum v0 -> "tag" := "Enum" ~> "contents" := @@ -298,7 +297,7 @@ instance decodeJsonTestSum :: DecodeJson TestSum where maybe (Left $ AtIndex 1 $ MissingValue) (\json -> - decodeJson json + unit <$ decodeArray (Left <<< UnexpectedValue) json ) $ index arr 1 v2 <- @@ -366,9 +365,6 @@ instance decodeJsonTestSum :: DecodeJson TestSum where ( decodeJson json ) ) - "NestedSum" -> lmap (AtKey "contents") $ NestedSum <$> - ( decodeJson json - ) "Enum" -> lmap (AtKey "contents") $ Enum <$> ( decodeJson json ) @@ -408,7 +404,7 @@ _String = prism' String f f (String a) = Just $ a f _ = Nothing -_Array :: Prism' TestSum (Array String) +_Array :: Prism' TestSum (Array Int) _Array = prism' Array f where f (Array a) = Just $ a @@ -450,26 +446,26 @@ _MyUnit = prism' MyUnit f f (MyUnit a) = Just $ a f _ = Nothing -_Pair :: Prism' TestSum (Tuple Int String) +_Pair :: Prism' TestSum (Tuple Int Number) _Pair = prism' Pair f where f (Pair a) = Just $ a f _ = Nothing -_Triple :: Prism' TestSum (Tuple3 Int String Boolean) +_Triple :: Prism' TestSum (Tuple3 Int Unit Boolean) _Triple = prism' Triple f where f (Triple a) = Just $ a f _ = Nothing -_Quad :: Prism' TestSum (Tuple4 Int String Boolean Number) +_Quad :: Prism' TestSum (Tuple4 Int Number Boolean Number) _Quad = prism' Quad f where f (Quad a) = Just $ a f _ = Nothing _QuadSimple :: Prism' TestSum { a :: Int - , b :: String + , b :: Number , c :: Boolean , d :: Number } _QuadSimple = prism' (\{ a, b, c, d } -> QuadSimple a b c d) f @@ -477,12 +473,6 @@ _QuadSimple = prism' (\{ a, b, c, d } -> QuadSimple a b c d) f f (QuadSimple a b c d) = Just $ { a: a, b: b, c: c, d: d } f _ = Nothing -_NestedSum :: Prism' TestSum TestNestedSum -_NestedSum = prism' NestedSum f - where - f (NestedSum a) = Just $ a - f _ = Nothing - _Enum :: Prism' TestSum TestEnum _Enum = prism' Enum f where @@ -492,7 +482,7 @@ _Enum = prism' Enum f -------------------------------------------------------------------------------- newtype TestRecord a = TestRecord - { _field1 :: String + { _field1 :: Int , _field2 :: a } @@ -528,10 +518,10 @@ derive instance newtypeTestRecord :: Newtype (TestRecord a) _ -------------------------------------------------------------------------------- -_TestRecord :: forall a. Iso' (TestRecord a) { _field1 :: String, _field2 :: a } +_TestRecord :: forall a. Iso' (TestRecord a) { _field1 :: Int, _field2 :: a } _TestRecord = _Newtype -field1 :: forall a. Lens' (TestRecord a) String +field1 :: forall a. Lens' (TestRecord a) Int field1 = _Newtype <<< prop (Proxy :: _ "_field1") field2 :: forall a. Lens' (TestRecord a) a @@ -539,7 +529,7 @@ field2 = _Newtype <<< prop (Proxy :: _ "_field2") -------------------------------------------------------------------------------- newtype TestNewtype - = TestNewtype (TestRecord String) + = TestNewtype (TestRecord Boolean) derive instance eqTestNewtype :: Eq TestNewtype @@ -567,7 +557,7 @@ derive instance newtypeTestNewtype :: Newtype TestNewtype _ -------------------------------------------------------------------------------- -_TestNewtype :: Iso' TestNewtype (TestRecord String) +_TestNewtype :: Iso' TestNewtype (TestRecord Boolean) _TestNewtype = _Newtype -------------------------------------------------------------------------------- @@ -607,82 +597,6 @@ derive instance newtypeTestNewtypeRecord :: Newtype TestNewtypeRecord _ _TestNewtypeRecord :: Iso' TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } _TestNewtypeRecord = _Newtype --------------------------------------------------------------------------------- -data TestNestedSum - = Case1 String - | Case2 Int - | Case3 (TestRecord Int) - -derive instance eqTestNestedSum :: Eq TestNestedSum - -instance showTestNestedSum :: Show TestNestedSum where - show x = genericShow x - -derive instance ordTestNestedSum :: Ord TestNestedSum - -instance encodeJsonTestNestedSum :: EncodeJson TestNestedSum where - encodeJson = - case _ of - Case1 v0 -> - "tag" := "Case1" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - Case2 v0 -> - "tag" := "Case2" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - Case3 v0 -> - "tag" := "Case3" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - - -instance decodeJsonTestNestedSum :: DecodeJson TestNestedSum where - decodeJson json = - do - obj <- decodeJObject json - tag <- obj .: "tag" - json <- obj .:? "contents" .!= jsonNull - case tag of - "Case1" -> lmap (AtKey "contents") $ Case1 <$> - ( decodeJson json - ) - "Case2" -> lmap (AtKey "contents") $ Case2 <$> - ( decodeJson json - ) - "Case3" -> lmap (AtKey "contents") $ Case3 <$> - ( decodeJson json - ) - _ -> Left $ AtKey "tag" (UnexpectedValue json) - -derive instance genericTestNestedSum :: Generic TestNestedSum _ - --------------------------------------------------------------------------------- - -_Case1 :: Prism' TestNestedSum String -_Case1 = prism' Case1 f - where - f (Case1 a) = Just $ a - f _ = Nothing - -_Case2 :: Prism' TestNestedSum Int -_Case2 = prism' Case2 f - where - f (Case2 a) = Just $ a - f _ = Nothing - -_Case3 :: Prism' TestNestedSum (TestRecord Int) -_Case3 = prism' Case3 f - where - f (Case3 a) = Just $ a - f _ = Nothing - -------------------------------------------------------------------------------- data TestEnum = Mon From 12aa42cd2ce0427fb4209225f23b6c928dec32cf Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 19 Oct 2021 20:20:10 -0400 Subject: [PATCH 039/111] Integrate json helpers --- src/Language/PureScript/Bridge.hs | 19 +- src/Language/PureScript/Bridge/PSTypes.hs | 22 +- src/Language/PureScript/Bridge/Printer.hs | 644 +++++++++-------- src/Language/PureScript/Bridge/SumType.hs | 99 ++- test/RoundTrip/Spec.hs | 29 +- test/RoundTrip/Types.hs | 2 +- test/RoundTrip/app/packages.dhall | 28 +- test/RoundTrip/app/spago.dhall | 6 +- test/RoundTrip/app/src/Main.purs | 20 +- test/RoundTrip/app/src/RoundTrip/Types.purs | 755 +++++++------------- test/Spec.hs | 2 +- 11 files changed, 727 insertions(+), 899 deletions(-) diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index b1c721cb..6c7af282 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -115,7 +115,14 @@ writePSTypesWith switch root bridge sts = do -- > bridgeSumType (buildBridge defaultBridge) (mkSumType @Foo) bridgeSumType :: FullBridge -> SumType 'Haskell -> SumType 'PureScript bridgeSumType br (SumType t cs is) = - SumType (br t) (map (bridgeConstructor br) cs) is + SumType (br t) (map (bridgeConstructor br) cs) $ is <> extraInstances + where + extraInstances + | not (null cs) && all isNullary cs = [Enum, Bounded] + | otherwise = [] + isNullary (DataConstructor _ args) = args == Nullary + + -- | Default bridge for mapping primitive/common types: -- You can append your own bridges like this: @@ -137,10 +144,12 @@ defaultBridge = -- | Translate types in a constructor. bridgeConstructor :: FullBridge -> DataConstructor 'Haskell -> DataConstructor 'PureScript -bridgeConstructor br (DataConstructor name (Left infos)) = - DataConstructor name . Left $ map br infos -bridgeConstructor br (DataConstructor name (Right record)) = - DataConstructor name . Right $ map (bridgeRecordEntry br) record +bridgeConstructor _ (DataConstructor name Nullary) = + DataConstructor name Nullary +bridgeConstructor br (DataConstructor name (Normal infos)) = + DataConstructor name . Normal $ fmap br infos +bridgeConstructor br (DataConstructor name (Record record)) = + DataConstructor name . Record $ fmap (bridgeRecordEntry br) record -- | Translate types in a record entry. bridgeRecordEntry :: diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs index f85d8870..5d03156e 100644 --- a/src/Language/PureScript/Bridge/PSTypes.hs +++ b/src/Language/PureScript/Bridge/PSTypes.hs @@ -7,7 +7,7 @@ -- | PureScript types to be used for bridges, e.g. in "Language.PureScript.Bridge.Primitives". module Language.PureScript.Bridge.PSTypes where -import Control.Lens (views) +import Control.Lens (views, view) import Control.Monad.Reader.Class import qualified Data.Text as T @@ -66,17 +66,15 @@ psString = -- | Uses type parameters from 'haskType' (bridged). psTuple :: MonadReader BridgeData m => m PSType psTuple = do - size <- views (haskType . typeParameters) length - let tupleModule = - if size == 2 - then "Data.Tuple" - else "Data.Tuple.Nested" - tupleName = - "Tuple" <> - if size == 2 - then "" - else T.pack (show size) - TypeInfo "purescript-tuples" tupleModule tupleName <$> psTypeParameters + params <- view (haskType . typeParameters) + bridge <- view fullBridge + let + computeTuple [] = psUnit + computeTuple [a] = bridge a + computeTuple [a, b] = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge a, bridge b] + computeTuple (h : t) = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge h, computeTuple t] + pure $ computeTuple params + psUnit :: PSType psUnit = diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 96e04914..87377305 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -1,45 +1,46 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} module Language.PureScript.Bridge.Printer where -import Control.Lens (to, traversed,(^.), (^..), view) +import Control.Lens (to, traversed,(^.), (^..)) import Control.Monad (unless) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) +import Data.Maybe (isJust, catMaybes) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches -import Language.PureScript.Bridge.SumType (DataConstructor (DataConstructor), - Instance (Eq, Eq1, Functor, Generic, GenericShow, Newtype, Ord, Json), +import Language.PureScript.Bridge.SumType (DataConstructor (..), + Instance (..), RecordEntry (RecordEntry), + DataConstructorArgs (..), SumType (SumType), getUsedTypes, nootype, recLabel, recValue, - sigValues, sumTypeConstructors, sumTypeInfo, - _recLabel) + _recLabel, sigConstructor) import Language.PureScript.Bridge.TypeInfo (Language (PureScript), PSType, TypeInfo (TypeInfo), typeParameters, _typeModule, _typeName, _typePackage, - _typeParameters) + _typeParameters, typeName, flattenTypeInfo) import System.Directory (createDirectoryIfMissing, doesDirectoryExist) import System.FilePath (joinPath, takeDirectory, ()) -import Text.PrettyPrint.Leijen.Text (Doc, cat, +import Text.PrettyPrint.Leijen.Text (Doc, comma, displayTStrict, encloseSep, hcat, @@ -51,7 +52,12 @@ import Text.PrettyPrint.Leijen.Text (Doc, cat, renderPretty, rparen, space, textStrict, vsep, - (<+>), hang, dquotes, braces, int, lbracket, rbracket) + (<+>), hang, dquotes, braces, char, backslash) +import Data.List (unfoldr) +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Char (isLower) +import Language.PureScript.Bridge.PSTypes (psUnit) renderText :: Doc -> Text renderText = displayTStrict . renderPretty 0.4 200 @@ -60,6 +66,7 @@ data Module (lang :: Language) = PSModule { psModuleName :: !Text , psImportLines :: !ImportLines + , psQualifiedImports :: !(Map Text Text) , psTypes :: ![SumType lang] } deriving (Show) @@ -101,6 +108,7 @@ moduleToText settings m = " where\n" : "import Prelude" : (importLineToText <$> allImports) <> + (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) <> [""] <> (renderText . sumTypeToDoc settings <$> psTypes m) where @@ -118,7 +126,7 @@ _lensImports settings | Switches.generateLenses settings = [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] , ImportLine "Data.Lens" $ - Set.fromList ["Iso'", "Prism'", "Lens'", "prism'", "lens"] + Set.fromList ["Iso'", "Prism'", "Lens'", "prism'", "lens", "iso"] , ImportLine "Data.Lens.Record" $ Set.fromList ["prop"] , ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"] , ImportLine "Type.Proxy" $ Set.fromList ["Proxy(Proxy)"] @@ -126,6 +134,9 @@ _lensImports settings | otherwise = [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] ] +qualifiedImportToText :: Text -> Text -> Text +qualifiedImportToText m q = "import " <> m <> " as " <> q + importLineToText :: ImportLine -> Text importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")" where @@ -144,7 +155,7 @@ sumTypeToDoc settings st = vsep $ punctuate line [sumTypeToTypeDecls st, additio sumTypeToTypeDecls :: SumType 'PureScript -> Doc sumTypeToTypeDecls (SumType t cs is) = vsep $ punctuate line $ - (dataOrNewtype <+> typeInfoToDoc True t + (dataOrNewtype <+> typeInfoToDecl t <> line <> indent 2 @@ -173,17 +184,33 @@ instances st@(SumType t _ is) = go <$> is constraintsInner (instanceConstraints <$> sumTypeParameters) <+> "=>" name = textStrict (_typeName t) go :: Instance -> Doc + go Bounded = + hang 2 $ vsep + [ "instance bounded" <> name <+> "::" <+> "Bounded" <+> typeInfoToDoc t <+> "where" + , "bottom = genericBottom" + , "top = genericTop" + ] + go Enum = + hang 2 $ vsep + [ "instance enum" <> name <+> "::" <+> "Enum" <+> typeInfoToDoc t <+> "where" + , "succ = genericSucc" + , "pred = genericPred" + ] go Json = vsep - [ "instance encodeJson" <> name <+> "::" <+> extras encodeJsonInstance <+> "EncodeJson" <+> typeInfoToDoc False t <+> "where" - , indent 2 (vsep ["encodeJson =", indent 2 (sumTypeToEncode st)]) + [ hang 2 $ vsep + [ "instance encodeJson" <> name <+> "::" <+> extras encodeJsonInstance <+> "EncodeJson" <+> typeInfoToDoc t <+> "where" + , hang 2 ("encodeJson = E.encode" <+> sumTypeToEncode st) + ] , linebreak - , "instance decodeJson" <> name <+> "::" <+> extras decodeJsonInstance <+> "DecodeJson" <+> typeInfoToDoc False t <+> "where" - , indent 2 (vsep ["decodeJson json =", indent 2 (sumTypeToDecode st)]) + , hang 2 $ vsep + [ "instance decodeJson" <> name <+> "::" <+> extras decodeJsonInstance <+> "DecodeJson" <+> typeInfoToDoc t <+> "where" + , hang 2 ("decodeJson = D.decode" <+> sumTypeToDecode st) + ] ] go GenericShow = "instance show" <> name <+> "::" <+> extras showInstance <+> "Show" <+> - typeInfoToDoc False t <+> + typeInfoToDoc t <+> "where" <> linebreak <> indent 2 "show x = genericShow x" @@ -191,15 +218,15 @@ instances st@(SumType t _ is) = go <$> is "derive instance functor" <> name <+> "::" <+> "Functor" <+> name go Eq = "derive instance eq" <> name <+> "::" <+> extras eqInstance <+> "Eq" <+> - typeInfoToDoc False t + typeInfoToDoc t go Eq1 = "derive instance eq1" <> name <+> "::" <+> "Eq1" <+> name go Ord = "derive instance ord" <> name <+> "::" <+> extras ordInstance <+> "Ord" <+> - typeInfoToDoc False t + typeInfoToDoc t go i = "derive instance " <> textStrict (T.toLower c) <> name <+> "::" <+> textStrict c <+> - typeInfoToDoc False t <> + typeInfoToDoc t <> postfix i where c = T.pack $ show i @@ -207,205 +234,122 @@ instances st@(SumType t _ is) = go <$> is postfix Generic = " _" postfix _ = "" +isEnum :: [DataConstructor lang] -> Bool +isEnum = all $ (== Nullary) . _sigValues + sumTypeToEncode :: SumType 'PureScript -> Doc sumTypeToEncode (SumType _ cs _) - | isEnum = "fromString <<< show" + | isEnum cs = "E.enum" | otherwise = - hang 2 $ vsep - [ "case _ of" - , case cs of - [dc@(DataConstructor name args)] -> - hang 2 $ vsep [textStrict name <+> bindings args <+> "->", constructorToEncode dc] - _ -> vsep $ constructorToCase <$> cs - ] + line <> "$" <+> case cs of + [dc@(DataConstructor _ args)] -> + vsep + [ if isJust (nootype [dc]) + then "unwrap" + else parens $ "case _ of" <+> branch (constructorPattern dc) (constructorExpr args) + , ">$<" <+> hang 2 (argsToEncode args) + ] + _ -> + vsep + [ "E.sumType" + , "$ toEither" + , indent 4 $ ">$<" <+> hsep (punctuate (line <> ">|<") (constructorToTagged <$> cs)) + , "where" + , "toEither =" <+> case_of (unfoldr toEither ("", cs)) + ] where - isEnum = all isNoArgConstructor cs - isNoArgConstructor c = (c ^. sigValues) == Left [] - bindings args = case args of - Left values -> hsep $ ("v" <>) . int <$> [0..(length values - 1)] - Right entries -> braces $ hsep $ punctuate ", " $ textStrict . view recLabel <$> entries - constructorToCase dc@(DataConstructor name args)= - hang 2 $ vsep $ - [ textStrict name <+> bindings args <+> "->" - , "\"tag\" :=" <+> dquotes (textStrict name) <+> "~>" - ] <> - ( if args == Left [] - then [] - else [ "\"contents\" :=" - , indent 2 $ lparen <+> hang 2 (constructorToEncode dc) - , indent 2 $ rparen <+> "~>" - ] + toEither (_, []) = Nothing + toEither (prefix, dc@(DataConstructor _ args) : rest) = + Just + ( ( constructorPattern dc + , prefix <+> eitherCase rest <+> "$" <+> constructorExpr args ) - <> ["jsonEmptyObject"] - constructorToEncode (DataConstructor _ args) = - either typesToEncode recordEntriesToEncode args - -typesToEncode :: [PSType] -> Doc -typesToEncode [] = "jsonEmptyArray" -typesToEncode [a] = parens ("let a = v0 in" <+> typeToEncode a) -typesToEncode ts = - encodeArray (\(i, t) -> parens ("let a = v" <> int i <+> "in" <+> typeToEncode t)) (zip [0..] ts) - - -encodeArray :: (a -> Doc) -> [a] -> Doc -encodeArray adoc as = - hang 2 $ vsep - [ "fromArray" - , lbracket <+> mconcat (punctuate (line <> ", ") $ adoc <$> as) - , rbracket - ] + , (nextPrefix rest, rest) + ) + where + eitherCase [] = "Right" + eitherCase _ = "Left" + nextPrefix [_] = prefix + nextPrefix _ = prefix <+> "Right $" + constructorToTagged (DataConstructor name args) = + "E.tagged" <+> dquotes (textStrict name) <+> argsToEncode args + argsToEncode Nullary = "E.null" + argsToEncode (Normal (t :| [])) = typeToEncode t + argsToEncode (Normal ts) = + parens $ "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> NE.toList ts) + argsToEncode (Record fields) = parens $ vsep + [ "E.record" + , braces $ vsep $ punctuate comma $ fieldToEncode <$> NE.toList fields + ] + fieldToEncode (RecordEntry name t) = + textStrict name <> ":" <+> typeToEncode t <+> ":: Encoder" <+> typeInfoToDoc t typeToEncode :: PSType -> Doc -typeToEncode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = - "jsonEmptyArray" -typeToEncode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = - vsep - [ "case a of" - , indent 2 "Nothing -> jsonNull" - , indent 2 $ "Just a ->" <+> typeToEncode t - ] -typeToEncode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = - vsep - [ "case a of" - , indent 2 $ "Left a -> \"Left\" :=" <+> parens (typeToEncode l) <+> "~> jsonEmptyObject" - , indent 2 $ "Right a -> \"Right\" :=" <+> parens (typeToEncode r) <+> "~> jsonEmptyObject" - ] -typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple.Nested" _ ts) = - vsep - [ "case a of" <+> hsep (punctuate " /\\" $ (("v" <>) . int . fst <$> zip [0..] ts) <> ["unit"]) <+> "->" - , indent 4 $ lbracket <+> mconcat (punctuate (line <> ", ") $ tupleElementToEncode <$> zip [0..] ts) - , indent 4 rbracket - ] - where - tupleElementToEncode (i, t) = parens $ "let a = v" <> int i <+> "in" <+> typeToEncode t -typeToEncode _ = "encodeJson a" - - -recordEntriesToEncode :: [RecordEntry 'PureScript] -> Doc -recordEntriesToEncode rs = - vsep $ punctuate " ~>" $ (recordEntryToEncode <$> rs) <> ["jsonEmptyObject"] +typeToEncode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = "E.unit" +typeToEncode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = parens $ + "E.maybe" <+> typeToEncode t +typeToEncode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = parens $ + "E.either" <+> typeToEncode l <+> typeToEncode r +typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ + "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) + where + flattenTuple [] = [] + flattenTuple [a] = [a] + flattenTuple [a, TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts'] = a : flattenTuple ts' + flattenTuple (h : t) = h : flattenTuple t +typeToEncode _ = "E.value" -recordEntryToEncode :: RecordEntry 'PureScript -> Doc -recordEntryToEncode (RecordEntry name t) = - dquotes (textStrict name) - <+> ":=" - <+> parens ("let a =" <+> textStrict name <+> "in" <+> typeToEncode t) sumTypeToDecode :: SumType 'PureScript -> Doc sumTypeToDecode (SumType _ cs _) - | isEnum = - vsep - [ "decodeJson json >>= case _ of" - , indent 2 $ vsep $ constructorToCase <$> cs - , indent 2 "_ -> Left (UnexpectedValue json)" - ] - where - isEnum = all isNoArgConstructor cs - isNoArgConstructor c = (c ^. sigValues) == Left [] - constructorToCase (DataConstructor name _) = dquotes (textStrict name) <+> "->" <+> "pure" <+> textStrict name -sumTypeToDecode (SumType _ [c] _) = constructorToDecode c -sumTypeToDecode (SumType _ cs _) = + | isEnum cs = "D.enum" +sumTypeToDecode (SumType _ [c] _) = "$" <+> constructorToDecode c +sumTypeToDecode (SumType t cs _) = line <> vsep - [ "do" - , indent 2 $ vsep - [ "obj <- decodeJObject json" - , "tag <- obj .: \"tag\"" - , "json <- obj .:? \"contents\" .!= jsonNull" - , "case tag of" - , indent 2 $ vsep $ - ( ( \dc@(DataConstructor name _) -> - hang 2 $ dquotes (textStrict name) <+> "->" <+> constructorToDecode dc - ) - <$> cs - ) - <> ["_ -> Left $ AtKey \"tag\" (UnexpectedValue json)"] - ] + [ "$ D.sumType" <+> dquotes (t ^. typeName . to textStrict) + , "$" <+> hang 2 (hsep $ punctuate (line <> "<|>") $ constructorToTagged <$> cs) ] + where + constructorToTagged dc = + "D.tagged" + <+> dc ^. sigConstructor . to textStrict . to dquotes + <+> dc ^. to constructorToDecode . to parens + constructorToDecode :: DataConstructor 'PureScript -> Doc -constructorToDecode (DataConstructor name (Left args)) = - case args of - [] -> "pure" <+> textStrict name - [a] -> vsep - [ "lmap (AtKey \"contents\") $" <+> textStrict name <+> "<$>" - , wrapConstructorArg $ typeToDecode a - ] - _ -> vsep - [ "do" - , "arr <- decodeJArray json" - , "lmap (AtKey \"contents\") $" <+> textStrict name <+> "<$>" - , indent 2 $ vsep . punctuate " <*>" $ wrapConstructorArg . argToDecode <$> zip [0..] args - ] - where - wrapConstructorArg doc = vsep [hang 2 $ "(" <+> doc, ")"] - argToDecode (i, arg) = - hang 2 $ vsep - [ "do" - , "json <- maybe (Left $ AtIndex" <+> int i <+> "$ MissingValue) Right $ index arr" <+> int i - , hang 2 $ lparen <+> typeToDecode arg - , rparen - ] -constructorToDecode (DataConstructor name (Right args)) = - case args of - [] -> "pure $" <+> textStrict name <+> "{}" - _ -> - vsep - [ "do" - , indent 2 $ vsep $ - [ "x <- decodeJson json" ] - <> fieldDecodes - <> [ "pure $" - <+> textStrict name - <+> braces (hsep (punctuate ", " $ textStrict . view recLabel <$> args)) - ] - ] +constructorToDecode (DataConstructor name Nullary) = + textStrict name <+> "<$" <+> "D.null" +constructorToDecode (DataConstructor name (Normal (a :| []))) = + textStrict name <+> "<$>" <+> typeToDecode a +constructorToDecode (DataConstructor name (Normal as)) = + "D.tuple" + <+> "$" + <+> textStrict name + <+> "" + <+> hsep (punctuate " " $ typeToDecode <$> NE.toList as) +constructorToDecode (DataConstructor name (Record fields)) = + vsep + [ textStrict name <+> "<$> D.record" <+> dquotes (textStrict name) + , braces $ vsep $ punctuate comma $ fieldToDecode <$> NE.toList fields + ] where - fieldDecodes = fieldDecode <$> args - fieldDecode (RecordEntry label value) = - textStrict label - <+> "<-" - <+> "x .:" - <+> dquotes (textStrict label) - <+> ">>= \\json ->" - <+> typeToDecode value + fieldToDecode (RecordEntry n t) = + textStrict n <> ":" <+> typeToDecode t <+> ":: Decoder" <+> typeInfoToDoc t typeToDecode :: PSType -> Doc -typeToDecode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = - "unit <$ decodeArray (Left <<< UnexpectedValue) json" -typeToDecode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = - vsep $ punctuate " <|>" - [ "Nothing <$ decodeNull json" - , "Just <$>" <+> parens (typeToDecode t) - ] -typeToDecode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = - hang 2 $ vsep - [ "decodeJson json >>= \\obj ->" - , "Left <$>" <+> parens ("obj .: \"Left\" >>= \\json ->" <+> typeToDecode l) <+> "<|>" - , "Right <$>" <+> parens ("obj .: \"Right\" >>= \\json ->" <+> typeToDecode r) - ] -typeToDecode (TypeInfo "purescript-tuples" "Data.Tuple.Nested" _ ts) = - hang 2 $ vsep - [ "do" - , "arr <- decodeJArray json" - , vsep $ tupleElementToDecode <$> zip [0..] ts - , "pure $" <+> hsep (punctuate " /\\" $ (("v" <>) . int . fst <$> zip [0..] ts) <> ["unit"]) - ] - where - tupleElementToDecode (i, t) = - hang 2 $ vsep - [ "v" <> int i <+> "<-" - , hang 2 $ vsep - [ "maybe" - , "(Left $ AtIndex" <+> int i <+> "$ MissingValue)" - , vsep - [ "(\\json ->" - , indent 2 $ typeToDecode t - , ")" - ] - , "$ index arr" <+> int i - ] - ] -typeToDecode _ = "decodeJson json" +typeToDecode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = "D.unit" +typeToDecode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = parens $ + "D.maybe" <+> typeToDecode t +typeToDecode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = parens $ + "D.either" <+> typeToDecode l <+> typeToDecode r +typeToDecode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ + "D.tuple" <+> parens (hsep $ punctuate " " $ typeToDecode <$> flattenTuple ts) + where + flattenTuple [] = [] + flattenTuple [a] = [a] + flattenTuple [a, TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts'] = a : flattenTuple ts' + flattenTuple (h : t) = h : flattenTuple t +typeToDecode _ = "D.value" constraintsInner :: [Doc] -> Doc constraintsInner = encloseSep lparen rparen ("," <> space) @@ -414,23 +358,23 @@ isTypeParam :: PSType -> PSType -> Bool isTypeParam t typ = _typeName typ `elem` map _typeName (_typeParameters t) eqInstance :: PSType -> Doc -eqInstance params = "Eq" <+> typeInfoToDoc False params +eqInstance params = "Eq" <+> typeInfoToDoc params ordInstance :: PSType -> Doc -ordInstance params = "Ord" <+> typeInfoToDoc False params +ordInstance params = "Ord" <+> typeInfoToDoc params showInstance :: PSType -> Doc -showInstance params = "Show" <+> typeInfoToDoc False params +showInstance params = "Show" <+> typeInfoToDoc params decodeJsonInstance :: PSType -> Doc -decodeJsonInstance params = "DecodeJson" <+> typeInfoToDoc False params +decodeJsonInstance params = "DecodeJson" <+> typeInfoToDoc params encodeJsonInstance :: PSType -> Doc -encodeJsonInstance params = "EncodeJson" <+> typeInfoToDoc False params +encodeJsonInstance params = "EncodeJson" <+> typeInfoToDoc params genericInstance :: PSType -> Doc genericInstance params = - "Generic" <+> typeInfoToDoc False params <+> "r" <> mergedTypeInfoToDoc params + "Generic" <+> typeInfoToDoc params <+> "r" <> mergedTypeInfoToDoc params sumTypeToOptics :: SumType 'PureScript -> Doc sumTypeToOptics st = @@ -446,19 +390,19 @@ constructorOptics st = typeInfo = st ^. sumTypeInfo recordOptics :: SumType 'PureScript -> [Doc] -recordOptics st@(SumType _ [DataConstructor _ (Right fields)] _) = - recordEntryToLens st <$> filter hasUnderscore fields +recordOptics st@(SumType _ [DataConstructor _ (Record fields)] _) = + recordEntryToLens st <$> filter hasUnderscore (NE.toList fields) recordOptics _ = mempty hasUnderscore :: RecordEntry lang -> Bool hasUnderscore (RecordEntry name _) = "_" `T.isPrefixOf` name constructorToDoc :: DataConstructor 'PureScript -> Doc -constructorToDoc (DataConstructor n (Left [])) = textStrict n -constructorToDoc (DataConstructor n (Left ts)) = - textStrict n <+> hsep (typeInfoToDoc False <$> ts) -constructorToDoc (DataConstructor n (Right rs)) = - textStrict n <> line <> indent 4 (recordFields (recordEntryToDoc <$> rs)) +constructorToDoc (DataConstructor n Nullary) = textStrict n +constructorToDoc (DataConstructor n (Normal ts)) = + textStrict n <+> hsep (typeInfoToDoc <$> NE.toList ts) +constructorToDoc (DataConstructor n (Record rs)) = + textStrict n <> line <> indent 4 (recordFields (recordEntryToDoc <$> NE.toList rs)) recordFields :: [Doc] -> Doc recordFields = encloseVsep (lbrace <> space) (line <> rbrace) (comma <> space) @@ -473,97 +417,83 @@ encloseVsep left right sp ds = typeNameAndForall :: TypeInfo 'PureScript -> (Doc, Doc) typeNameAndForall typeInfo = (typName, forAll) where - typName = typeInfoToDoc False typeInfo + typName = typeInfoToDoc typeInfo forAllParams = - typeInfo ^.. typeParameters . traversed . to (typeInfoToDoc False) + typeInfo ^.. typeParameters . traversed . to typeInfoToDoc forAll = " :: " <> case forAllParams of [] -> mempty cs -> "forall" <+> hsep cs <> ". " -fromEntries :: (RecordEntry a -> Doc) -> [RecordEntry a] -> Doc -fromEntries mkElem rs = - encloseSep (lbrace <> space) (space <> rbrace) ("," <> space) (mkElem <$> rs) - -mkFnArgs :: [RecordEntry 'PureScript] -> Doc -mkFnArgs [r] = textStrict $ r ^. recLabel -mkFnArgs rs = - fromEntries - (\recE -> - textStrict (recE ^. recLabel) <> ":" <+> textStrict (recE ^. recLabel)) - rs - -mkTypeSig :: [RecordEntry 'PureScript] -> Doc -mkTypeSig [] = "Unit" -mkTypeSig [r] = typeInfoToDoc False $ r ^. recValue -mkTypeSig rs = fromEntries recordEntryToDoc rs - constructorToOptic :: Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Doc constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = case (args, hasOtherConstructors) of - (Left [c], False) -> - vsep - [ pName <> forAll <> "Iso'" <+> typName <+> - mkTypeSig (constructorTypes [c]) - , pName <+> "= _Newtype" - ] - (Left cs, _) -> - vsep - [ pName <> forAll <> "Prism'" <+> typName <+> mkTypeSig types - , pName <+> "= prism'" <+> getter <+> "f" <> line <> - indent - 2 - ("where" <> linebreak <> - indent 2 (vsep ["f" <+> mkF cs, otherConstructorFallThrough])) - ] - where mkF [] = textStrict n <+> "= Just unit" - mkF _ = - parens - (textStrict n <> space <> - textStrict (T.unwords (_recLabel <$> types))) <+> - "= Just $" <+> - mkFnArgs types - getter :: Doc - getter - | null cs = parens ("\\_ ->" <+> textStrict n) - | length cs == 1 = textStrict n - | otherwise = - parens - ("\\{" <+> cat (punctuate ", " cArgs) <+> "} ->" <+> - textStrict n <+> - cat (punctuate space cArgs)) - where - cArgs = textStrict . T.singleton . fst <$> zip ['a' ..] cs - types = constructorTypes cs - (Right rs, False) -> - vsep - [ pName <> forAll <> "Iso'" <+> typName <+> - fromEntries recordEntryToDoc rs - , pName <+> "= _Newtype" - ] - (Right rs, True) -> - vsep - [ pName <> forAll <> "Prism'" <+> typName <+> - fromEntries recordEntryToDoc rs - , pName <+> "= prism'" <+> textStrict n <+> "f" <> line <> - indent - 2 - ("where" <> linebreak <> - indent - 2 - ("f (" <> textStrict n <+> "r) = Just r" <> line <> - otherConstructorFallThrough)) - ] + (Nullary, False) -> iso pName typeInfo psUnit "(const unit)" $ parens ("const" <+> cName) + (Nullary, True) -> prism pName typeInfo psUnit cName "unit" $ parens ("const" <+> cName) + (Normal (t :| []), False) -> newtypeIso pName typeInfo t + (Normal (t :| []), True) -> prism pName typeInfo t (normalPattern n [t]) "a" cName + (Normal ts, False) -> + iso + pName + typeInfo + (mkType (renderText $ recordType rec) []) + (parens (lambda (normalPattern n ts) (recordExpr rec))) + (parens (lambda (recordExpr rec) (normalPattern n ts))) + where + rec = argsToRecord ts + (Normal ts, True) -> + prism + pName + typeInfo + (mkType (renderText $ recordType rec) []) + (normalPattern n ts) + (recordExpr rec) + (parens (lambda (recordExpr rec) (normalPattern n ts))) + where + rec = argsToRecord ts + (Record rs, False) -> newtypeIso pName typeInfo (mkType (renderText $ recordType rs) []) + (Record rs, True) -> newtypeIso pName typeInfo (mkType (renderText $ recordType rs) []) where - constructorTypes cs = - [RecordEntry (T.singleton label) t | (label, t) <- zip ['a' ..] cs] - (typName, forAll) = typeNameAndForall typeInfo + cName = textStrict n pName = "_" <> textStrict n - otherConstructorFallThrough - | hasOtherConstructors = "f _ = Nothing" - | otherwise = mempty + recordType = braces . hsep . punctuate ", " . map recordFieldSig . NE.toList + recordFieldSig (RecordEntry name t) = signature False (textStrict name) [] [] t + +argsToRecord :: NonEmpty PSType -> NonEmpty (RecordEntry 'PureScript) +argsToRecord = fmap (uncurry RecordEntry) . NE.zip (T.singleton <$> ['a'..]) + +iso :: Doc -> PSType -> PSType -> Doc -> Doc -> Doc +iso name fromType toType fromMorph toMorph = + def + name + [] + [] + (mkType "Iso'" [fromType, toType]) + ("iso" <+> fromMorph <+> toMorph) + +prism :: Doc -> PSType -> PSType -> Doc -> Doc -> Doc -> Doc +prism name fromType toType previewPattern previewExpr inject = + def + name + [] + [] + (mkType "Prism'" [fromType, toType]) + ( "prism'" <+> inject <+> case_of + [ (previewPattern, "Just" <+> previewExpr) + , ("_", "Nothing") + ] + ) + +newtypeIso :: Doc -> PSType -> PSType -> Doc +newtypeIso name fromType toType = + def + name + [] + [] + (mkType "Iso'" [fromType, toType]) + "_Newtype" recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Doc recordEntryToLens st e = @@ -578,29 +508,22 @@ recordEntryToLens st e = (typName, forAll) = typeNameAndForall (st ^. sumTypeInfo) recName = e ^. recLabel lensName = T.drop 1 recName - recType = typeInfoToDoc False (e ^. recValue) + recType = typeInfoToDoc (e ^. recValue) recordEntryToDoc :: RecordEntry 'PureScript -> Doc recordEntryToDoc e = - textStrict (_recLabel e) <+> "::" <+> typeInfoToDoc True (e ^. recValue) + textStrict (_recLabel e) <+> "::" <+> typeInfoToDoc (e ^. recValue) -typeInfoToText :: Bool -> PSType -> Text -typeInfoToText topLevel = renderText . typeInfoToDoc topLevel +typeInfoToText :: PSType -> Text +typeInfoToText = renderText . typeInfoToDoc -typeInfoToDoc :: Bool -> PSType -> Doc -typeInfoToDoc topLevel t = - if needParens - then parens inner - else inner - where - inner = - if pLength > 0 - then textStrict (_typeName t) <+> hsep textParameters - else textStrict (_typeName t) - params = _typeParameters t - pLength = length params - needParens = not topLevel && pLength > 0 - textParameters = typeInfoToDoc False <$> params +typeInfoToDecl :: PSType -> Doc +typeInfoToDecl (TypeInfo _ _ name params) = + hsep $ textStrict name : (typeInfoToDoc <$> params) + +typeInfoToDoc :: PSType -> Doc +typeInfoToDoc t@(TypeInfo _ _ _ params) = + (if null params then id else parens) $ typeInfoToDecl t mergedTypeInfoToDoc :: PSType -> Doc mergedTypeInfoToDoc t = textStrict (_typeName t) <> hcat textParameters @@ -632,6 +555,7 @@ sumTypeToModule st@(SumType t _ is) = unionImportLines (typesToImportLines (getUsedTypes st)) (instancesToImportLines is) + , psQualifiedImports = instancesToQualifiedImports is , psTypes = [st] } where @@ -640,6 +564,9 @@ sumTypeToModule st@(SumType t _ is) = dropPrim = Map.delete "Prim" dropSelf = Map.delete (_typeModule t) +unionQualifiedImports :: Map Text Text -> Map Text Text -> Map Text Text +unionQualifiedImports = Map.unionWith const + unionImportLines :: ImportLines -> ImportLines -> ImportLines unionImportLines = Map.unionWith unionImportLine @@ -656,6 +583,10 @@ typeToImportLines t = unionImportLines (typesToImportLines $ Set.fromList (_typeParameters t)) $ importsFromList [ImportLine (_typeModule t) (Set.singleton (_typeName t))] +instancesToQualifiedImports :: [Instance] -> Map Text Text +instancesToQualifiedImports = + foldr unionQualifiedImports Map.empty . fmap instanceToQualifiedImports + instancesToImportLines :: [Instance] -> ImportLines instancesToImportLines = foldr unionImportLines Map.empty . fmap instanceToImportLines @@ -670,14 +601,33 @@ instanceToImportLines Json = , ImportLine "Data.Bifunctor" $ Set.singleton "lmap" , ImportLine "Data.Argonaut.Core" $ Set.fromList ["jsonEmptyArray", "jsonEmptyObject", "jsonNull", "fromArray", "fromString"] , ImportLine "Data.Argonaut.Decode" $ Set.fromList ["JsonDecodeError(..)", "(.:)", "(.:?)", "(.!=)", "decodeJson"] + , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["Decoder", "()", "()", "()"] , ImportLine "Data.Argonaut.Decode.Decoders" $ Set.fromList ["decodeJArray", "decodeJObject", "decodeArray", "decodeNull"] , ImportLine "Data.Argonaut.Encode" $ Set.fromList ["(:=)", "(~>)", "encodeJson"] + , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["Encoder", "(>$<)", "(>*<)", "(>/\\<)", "(>|<)"] , ImportLine "Data.Either" $ Set.singleton "Either(..)" , ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)", "maybe"] + , ImportLine "Data.Newtype" $ Set.singleton "unwrap" , ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" ] +instanceToImportLines Enum = + importsFromList + [ ImportLine "Data.Enum.Generic" $ Set.fromList ["genericPred", "genericSucc"] + ] +instanceToImportLines Bounded = + importsFromList + [ ImportLine "Data.Bounded.Generic" $ Set.fromList ["genericBottom", "genericTop"] + ] instanceToImportLines _ = Map.empty +instanceToQualifiedImports :: Instance -> Map Text Text +instanceToQualifiedImports Json = + Map.fromList + [ ("Data.Argonaut.Decode.Aeson", "D") + , ("Data.Argonaut.Encode.Aeson", "E") + ] +instanceToQualifiedImports _ = Map.empty + importsFromList :: [ImportLine] -> Map Text ImportLine importsFromList ls = let pairs = zip (importModule <$> ls) ls @@ -693,3 +643,79 @@ mergeImportLines = Map.unionWith mergeLines unlessM :: Monad m => m Bool -> m () -> m () unlessM mbool action = mbool >>= flip unless action + +constructorPattern :: DataConstructor 'PureScript -> Doc +constructorPattern (DataConstructor name Nullary) = nullaryPattern name +constructorPattern (DataConstructor name (Normal ts)) = normalPattern name ts +constructorPattern (DataConstructor name (Record rs)) = recordPattern name rs + +constructorExpr :: DataConstructorArgs 'PureScript -> Doc +constructorExpr Nullary = nullaryExpr +constructorExpr (Normal ts) = normalExpr ts +constructorExpr (Record rs) = recordExpr rs + +nullaryPattern :: Text -> Doc +nullaryPattern = textStrict + +nullaryExpr :: Doc +nullaryExpr = "unit" + +normalPattern :: Text -> NonEmpty PSType -> Doc +normalPattern name = parens . (textStrict name <+>) . hsep . normalLabels + +normalExpr :: NonEmpty PSType -> Doc +normalExpr = parens . hsep . punctuate " /\\" . normalLabels + +normalLabels :: NonEmpty PSType -> [Doc] +normalLabels = fmap char . zipWith const ['a'..] . NE.toList + +recordPattern :: Text -> NonEmpty (RecordEntry 'PureScript) -> Doc +recordPattern name = parens . (textStrict name <+>) . recordExpr + +recordExpr :: NonEmpty (RecordEntry 'PureScript) -> Doc +recordExpr = braces . hsep . punctuate ", " . recordLabels + +recordLabels :: NonEmpty (RecordEntry 'PureScript) -> [Doc] +recordLabels = fmap recordLabel . NE.toList + +recordLabel :: RecordEntry 'PureScript -> Doc +recordLabel = textStrict . _recLabel + +case_of :: [(Doc, Doc)] -> Doc +case_of = caseOf "_" + +caseOf :: Doc -> [(Doc, Doc)] -> Doc +caseOf scrutinee branches = + vsep $ hsep ["case", scrutinee, "of"] : (indent 2 . uncurry branch <$> branches) + +branch :: Doc -> Doc -> Doc +branch pattern body = hsep [pattern, "->", body] + +lambda :: Doc -> Doc -> Doc +lambda variables body = backslash <> branch variables body + +signature :: Bool -> Doc -> [PSType] -> [PSType] -> PSType-> Doc +signature topLevel name constraints params ret = + hsep $ catMaybes [Just name, Just "::", forAll, constraintsDoc, paramsDoc, Just $ typeInfoToDoc ret] + where + forAll = case (topLevel, typeParams) of + (False, _) -> Nothing + (_, []) -> Nothing + (_, ps) -> Just $ "forall" <+> hsep (textStrict <$> ps) <> "." + typeParams = filter (isLower . T.head) $ _typeName <$> allTypes + allTypes = concatMap flattenTypeInfo $ constraints <> params <> [ret] + constraintsDoc = case constraints of + [] -> Nothing + cs -> Just $ hsep ((<+> "=>") . typeInfoToDecl <$> cs) + paramsDoc = case params of + [] -> Nothing + ps -> Just $ hsep ((<+> "->") . typeInfoToDecl <$> ps) + +def :: Doc -> [PSType] -> [(Doc, PSType)] -> PSType -> Doc -> Doc +def name constraints params ret body = vsep + [ signature True name constraints (snd <$> params) ret + , hsep $ name : (fst <$> params) <> ["=", body] + ] + +mkType :: Text -> [PSType] -> PSType +mkType = TypeInfo "" "" diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 27ceaca1..4f9a3dbc 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -5,11 +5,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} module Language.PureScript.Bridge.SumType ( SumType(..) @@ -21,6 +24,7 @@ module Language.PureScript.Bridge.SumType , equal1 , order , DataConstructor(..) + , DataConstructorArgs(..) , RecordEntry(..) , Instance(..) , nootype @@ -45,6 +49,8 @@ import Data.Typeable import Generics.Deriving import Language.PureScript.Bridge.TypeInfo +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE -- | Generic representation of your Haskell types. data SumType (lang :: Language) = @@ -92,20 +98,16 @@ data Instance | Eq | Eq1 | Ord + | Enum + | Bounded deriving (Eq, Show) -- | The Purescript typeclass `Newtype` might be derivable if the original -- Haskell type was a simple type wrapper. nootype :: [DataConstructor lang] -> Maybe Instance -nootype cs = - case cs of - [constr] - | either isSingletonList (const True) (_sigValues constr) -> Just Newtype - | otherwise -> Nothing - _ -> Nothing - where - isSingletonList [_] = True - isSingletonList _ = False +nootype [DataConstructor _ (Record _)] = Just Newtype +nootype [DataConstructor _ (Normal [_])] = Just Newtype +nootype _ = Nothing -- | Ensure that aeson-compatible `EncodeJson` and `DecodeJson` instances are generated for your type. argonaut :: SumType t -> SumType t @@ -135,10 +137,27 @@ order (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is data DataConstructor (lang :: Language) = DataConstructor { _sigConstructor :: !Text -- ^ e.g. `Left`/`Right` for `Either` - , _sigValues :: !(Either [TypeInfo lang] [RecordEntry lang]) + , _sigValues :: !(DataConstructorArgs lang) } deriving (Show, Eq) +data DataConstructorArgs (lang :: Language) + = Nullary + | Normal (NonEmpty (TypeInfo lang)) + | Record (NonEmpty (RecordEntry lang)) + deriving (Show, Eq) + +instance Semigroup (DataConstructorArgs lang) where + Nullary <> b = b + a <> Nullary = a + Normal as <> Normal bs = Normal $ as <> bs + Record as <> Record bs = Record $ as <> bs + Normal as <> Record bs = Normal as <> Normal (_recValue <$> bs) + Record as <> Normal bs = Normal (_recValue <$> as) <> Normal bs + +instance Monoid (DataConstructorArgs lang) where + mempty = Nullary + data RecordEntry (lang :: Language) = RecordEntry { _recLabel :: !Text -- ^ e.g. `runState` for `State` @@ -149,41 +168,34 @@ data RecordEntry (lang :: Language) = class GDataConstructor f where gToConstructors :: f a -> [DataConstructor 'Haskell] -class GRecordEntry f where - gToRecordEntries :: f a -> [RecordEntry 'Haskell] +class GDataConstructorArgs f where + gToDataConstructorArgs :: f a -> DataConstructorArgs 'Haskell instance (Datatype a, GDataConstructor c) => GDataConstructor (D1 a c) where gToConstructors (M1 c) = gToConstructors c -instance (GDataConstructor a, GDataConstructor b) => - GDataConstructor (a :+: b) where - gToConstructors (_ :: (a :+: b) f) = +instance (GDataConstructor a, GDataConstructor b) => GDataConstructor (a :+: b) where + gToConstructors _ = gToConstructors (undefined :: a f) ++ gToConstructors (undefined :: b f) -instance (Constructor a, GRecordEntry b) => GDataConstructor (C1 a b) where +instance (Constructor a, GDataConstructorArgs b) => GDataConstructor (C1 a b) where gToConstructors c@(M1 r) = [DataConstructor {_sigConstructor = constructor, _sigValues = values}] where constructor = T.pack $ conName c - values = - if conIsRecord c - then Right $ gToRecordEntries r - else Left $ map _recValue $ gToRecordEntries r - -instance (GRecordEntry a, GRecordEntry b) => GRecordEntry (a :*: b) where - gToRecordEntries (_ :: (a :*: b) f) = - gToRecordEntries (undefined :: a f) ++ gToRecordEntries (undefined :: b f) - -instance GRecordEntry U1 where - gToRecordEntries _ = [] - -instance (Selector a, Typeable t) => GRecordEntry (S1 a (K1 R t)) where - gToRecordEntries e = - [ RecordEntry - { _recLabel = T.pack (selName e) - , _recValue = mkTypeInfo @t - } - ] + values = gToDataConstructorArgs r + +instance (GDataConstructorArgs a, GDataConstructorArgs b) => GDataConstructorArgs (a :*: b) where + gToDataConstructorArgs _ = + gToDataConstructorArgs (undefined :: a f) <> gToDataConstructorArgs (undefined :: b f) + +instance GDataConstructorArgs U1 where + gToDataConstructorArgs _ = mempty + +instance (Selector a, Typeable t) => GDataConstructorArgs (S1 a (K1 R t)) where + gToDataConstructorArgs e = case selName e of + "" -> Normal [mkTypeInfo @t] + name -> Record [RecordEntry (T.pack name) (mkTypeInfo @t)] -- | Get all used types in a sum type. -- @@ -194,10 +206,15 @@ getUsedTypes (SumType _ cs is) = foldMap constructorToTypes cs <> foldMap instan constructorToTypes :: DataConstructor lang -> Set (TypeInfo lang) -constructorToTypes (DataConstructor _ (Left myTs)) = - Set.fromList (concatMap flattenTypeInfo myTs) -constructorToTypes (DataConstructor _ (Right rs)) = - Set.fromList (concatMap (flattenTypeInfo . _recValue) rs) +constructorToTypes (DataConstructor _ Nullary) = Set.empty +constructorToTypes (DataConstructor _ (Normal [ts])) = + Set.fromList $ flattenTypeInfo ts +constructorToTypes (DataConstructor _ (Record [rs])) = + Set.fromList . flattenTypeInfo $ _recValue rs +constructorToTypes (DataConstructor _ (Normal ts)) = + Set.fromList . concatMap flattenTypeInfo $ NE.toList ts +constructorToTypes (DataConstructor _ (Record rs)) = + Set.fromList . concatMap (flattenTypeInfo . _recValue) $ NE.toList rs instanceToTypes :: Instance -> Set (TypeInfo lang) instanceToTypes Generic = @@ -219,6 +236,10 @@ instanceToTypes Eq1 = Set.singleton $ TypeInfo "purescript-prelude" "Data.Eq" "class Eq1" [] instanceToTypes Ord = Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Ord" [] +instanceToTypes Enum = + Set.singleton $ TypeInfo "purescript-enums" "Data.Enum" "class Enum" [] +instanceToTypes Bounded = + Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Bounded" [] -- Lenses: makeLenses ''DataConstructor diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 30bb2800..3a632210 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -8,7 +8,7 @@ module RoundTrip.Spec where import Control.Exception (bracket) import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, encode, fromJSON) -import Data.ByteString.Lazy (stripSuffix) +import Data.ByteString.Lazy (stripSuffix, hGetContents) import Data.ByteString.Lazy.UTF8 (toString, fromString) import Data.List (isInfixOf) import Data.Proxy (Proxy (..)) @@ -18,15 +18,15 @@ import Language.PureScript.Bridge.TypeParameters (A) import RoundTrip.Types import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) -import System.IO (BufferMode (..), hSetBuffering, hGetLine, hPutStrLn) -import System.Process (CreateProcess (std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess) +import System.IO (BufferMode (..), hSetBuffering, hPutStrLn, stdout, stderr, hFlush) +import System.Process (CreateProcess (std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess, waitForProcess) import Test.HUnit (assertBool, assertEqual) import Test.Hspec (Spec, around, aroundAll_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck.Property (Testable (property)) import Data.Maybe (fromMaybe) -import Test.QuickCheck (verbose, once) +import Test.QuickCheck (verbose, once, noShrinking, withMaxSuccess) myBridge :: BridgePart myBridge = defaultBridge @@ -52,20 +52,15 @@ roundtripSpec = do it "should not warn of unused packages buildable" do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" assertBool stderr $ not $ "[warn]" `isInfixOf` stderr - around withTestApp $ - it "should produce aeson-compatible argonaut instances" $ \(hin, hout, hproc) -> - property $ - \testData -> - do - hPutStrLn hin $ toString $ encode @TestData testData - output <- fromString <$> hGetLine hout - let output = fromMaybe output $ stripSuffix "\n" output - flip (assertEqual (toString output)) Nothing =<< getProcessExitCode hproc - assertEqual (toString output) (Right testData) $ eitherDecode output + it "should produce aeson-compatible argonaut instances" $ + property $ + \testData -> bracket runApp killApp $ + \(hin, hout, hproc) -> do + hPutStrLn hin $ toString $ encode @TestData testData + output <- hGetContents hout + assertEqual (toString output) ExitSuccess =<< waitForProcess hproc + assertEqual (toString output) (Right testData) $ eitherDecode @TestData output where - withTestApp runSpec = - bracket runApp killApp runSpec - runApp = do (Just hin, Just hout, _, hproc) <- createProcess (proc "spago" ["run"]) {std_in = CreatePipe, std_out = CreatePipe} diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index de94cfb3..b6ca6ea0 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -81,7 +81,7 @@ instance Arbitrary TestSum where ] data TestRecord a = TestRecord - { _field1 :: Int, + { _field1 :: Maybe Int, _field2 :: a } deriving (Show, Eq, Ord, Generic) diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall index da4058d0..1d31d537 100644 --- a/test/RoundTrip/app/packages.dhall +++ b/test/RoundTrip/app/packages.dhall @@ -1,4 +1,30 @@ let upstream = https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20211005/packages.dhall sha256:2ec351f17be14b3f6421fbba36f4f01d1681e5c7f46e0c981465c4cf222de5be -in upstream +in upstream // { + json-helpers = + { dependencies = + [ "argonaut-codecs" + , "argonaut-core" + , "arrays" + , "bifunctors" + , "contravariant" + , "control" + , "either" + , "enums" + , "foreign-object" + , "maybe" + , "newtype" + , "ordered-collections" + , "prelude" + , "profunctor" + , "psci-support" + , "record" + , "transformers" + , "tuples" + , "typelevel-prelude" + ] + , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" + , version = "68265aaacc1a56c00a7625d424ff13d619681e5e" + } +} diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index 3e0b2fca..2f5e5091 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -4,14 +4,16 @@ , "argonaut-core" , "arrays" , "bifunctors" + , "console" , "control" , "effect" , "either" + , "enums" + , "json-helpers" , "maybe" , "newtype" - , "node-buffer" , "node-process" - , "node-streams" + , "node-readline" , "prelude" , "profunctor-lenses" , "psci-support" diff --git a/test/RoundTrip/app/src/Main.purs b/test/RoundTrip/app/src/Main.purs index 614de168..47e1ffb1 100644 --- a/test/RoundTrip/app/src/Main.purs +++ b/test/RoundTrip/app/src/Main.purs @@ -7,26 +7,24 @@ import Data.Argonaut.Decode (JsonDecodeError, decodeJson, parseJson, printJsonDe import Data.Argonaut.Encode (encodeJson) import Data.Either (Either(..)) import Effect (Effect) -import Node.Encoding (Encoding(..)) -import Node.Process (exit, stdin, stdout) -import Node.Stream (onDataString, onEnd, uncork, writeString) +import Effect.Class.Console (log) +import Node.Process (exit) +import Node.ReadLine (createConsoleInterface, noCompletion, question) import RoundTrip.Types (TestData) main :: Effect Unit main = do - onDataString stdin UTF8 \input -> + interface <- createConsoleInterface noCompletion + interface # question "" \input -> let parsed :: Either JsonDecodeError TestData parsed = decodeJson =<< parseJson input in case parsed of Left err -> do - void - $ writeString stdout UTF8 (show input <> "\n" <> printJsonDecodeError err <> "\n") - $ uncork stdout + log $ "got" <> input + log $ printJsonDecodeError err exit 1 Right testData -> do - void - $ writeString stdout UTF8 (stringify (encodeJson testData) <> "\n") - $ uncork stdout - onEnd stdin $ exit 0 + log $ stringify $ encodeJson testData + exit 0 diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 8076bf59..c40da35b 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -5,22 +5,29 @@ import Prelude import Control.Alt ((<|>)) import Data.Argonaut.Core (fromArray, fromString, jsonEmptyArray, jsonEmptyObject, jsonNull) import Data.Argonaut.Decode ((.!=), (.:), (.:?), JsonDecodeError(..), class DecodeJson, decodeJson) +import Data.Argonaut.Decode.Aeson ((), (), (), Decoder) import Data.Argonaut.Decode.Decoders (decodeArray, decodeJArray, decodeJObject, decodeNull) import Data.Argonaut.Encode ((:=), (~>), class EncodeJson, encodeJson) +import Data.Argonaut.Encode.Aeson ((>$<), (>*<), (>/\<), (>|<), Encoder) import Data.Array (index) import Data.Bifunctor (lmap) +import Data.Bounded.Generic (genericBottom, genericTop) import Data.Either (Either, Either(..)) +import Data.Enum (class Enum) +import Data.Enum.Generic (genericPred, genericSucc) import Data.Functor (class Functor) import Data.Generic.Rep (class Generic) -import Data.Lens (Iso', Lens', Prism', lens, prism') +import Data.Lens (Iso', Lens', Prism', iso, lens, prism') import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) import Data.Maybe (Maybe, Maybe(..), maybe) -import Data.Newtype (class Newtype) +import Data.Newtype (class Newtype, unwrap) import Data.Show.Generic (genericShow) import Data.Tuple (Tuple) -import Data.Tuple.Nested ((/\), Tuple3, Tuple4) +import Data.Tuple.Nested ((/\)) import Type.Proxy (Proxy(Proxy)) +import Data.Argonaut.Decode.Aeson as D +import Data.Argonaut.Encode.Aeson as E data TestData = Maybe (Maybe TestSum) @@ -34,65 +41,36 @@ instance showTestData :: Show TestData where derive instance ordTestData :: Ord TestData instance encodeJsonTestData :: EncodeJson TestData where - encodeJson = - case _ of - Maybe v0 -> - "tag" := "Maybe" ~> - "contents" := - ( (let a = v0 in case a of - Nothing -> jsonNull - Just a -> encodeJson a) - ) ~> - jsonEmptyObject - Either v0 -> - "tag" := "Either" ~> - "contents" := - ( (let a = v0 in case a of - Left a -> "Left" := (case a of - Nothing -> jsonNull - Just a -> encodeJson a) ~> jsonEmptyObject - Right a -> "Right" := (case a of - Nothing -> jsonNull - Just a -> encodeJson a) ~> jsonEmptyObject) - ) ~> - jsonEmptyObject + encodeJson = E.encode + $ E.sumType + $ toEither + >$< E.tagged "Maybe" (E.maybe E.value) + >|< E.tagged "Either" (E.either (E.maybe E.value) (E.maybe E.value)) + where + toEither = case _ of + (Maybe a) -> Left $ (a) + (Either a) -> Right $ (a) instance decodeJsonTestData :: DecodeJson TestData where - decodeJson json = - do - obj <- decodeJObject json - tag <- obj .: "tag" - json <- obj .:? "contents" .!= jsonNull - case tag of - "Maybe" -> lmap (AtKey "contents") $ Maybe <$> - ( Nothing <$ decodeNull json <|> - Just <$> (decodeJson json) - ) - "Either" -> lmap (AtKey "contents") $ Either <$> - ( decodeJson json >>= \obj -> - Left <$> (obj .: "Left" >>= \json -> Nothing <$ decodeNull json <|> - Just <$> (decodeJson json)) <|> - Right <$> (obj .: "Right" >>= \json -> Nothing <$ decodeNull json <|> - Just <$> (decodeJson json)) - ) - _ -> Left $ AtKey "tag" (UnexpectedValue json) + decodeJson = D.decode + $ D.sumType "TestData" + $ D.tagged "Maybe" (Maybe <$> (D.maybe D.value)) + <|> D.tagged "Either" (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) derive instance genericTestData :: Generic TestData _ -------------------------------------------------------------------------------- -_Maybe :: Prism' TestData (Maybe TestSum) -_Maybe = prism' Maybe f - where - f (Maybe a) = Just $ a - f _ = Nothing +_Maybe :: (Prism' TestData (Maybe TestSum)) +_Maybe = prism' Maybe case _ of + (Maybe a) -> Just a + _ -> Nothing -_Either :: Prism' TestData (Either (Maybe Int) (Maybe Boolean)) -_Either = prism' Either f - where - f (Either a) = Just $ a - f _ = Nothing +_Either :: (Prism' TestData (Either (Maybe Int) (Maybe Boolean))) +_Either = prism' Either case _ of + (Either a) -> Just a + _ -> Nothing -------------------------------------------------------------------------------- data TestSum @@ -109,8 +87,8 @@ data TestSum | Unit Unit | MyUnit MyUnit | Pair (Tuple Int Number) - | Triple (Tuple3 Int Unit Boolean) - | Quad (Tuple4 Int Number Boolean Number) + | Triple (Tuple Int (Tuple Unit Boolean)) + | Quad (Tuple Int (Tuple Number (Tuple Boolean Number))) | QuadSimple Int Number Boolean Number | Enum TestEnum @@ -122,367 +100,161 @@ instance showTestSum :: Show TestSum where derive instance ordTestSum :: Ord TestSum instance encodeJsonTestSum :: EncodeJson TestSum where - encodeJson = - case _ of - Nullary -> - "tag" := "Nullary" ~> - jsonEmptyObject - Bool v0 -> - "tag" := "Bool" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - Int v0 -> - "tag" := "Int" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - Number v0 -> - "tag" := "Number" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - String v0 -> - "tag" := "String" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - Array v0 -> - "tag" := "Array" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - Record v0 -> - "tag" := "Record" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - NestedRecord v0 -> - "tag" := "NestedRecord" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - NT v0 -> - "tag" := "NT" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - NTRecord v0 -> - "tag" := "NTRecord" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - Unit v0 -> - "tag" := "Unit" ~> - "contents" := - ( (let a = v0 in jsonEmptyArray) - ) ~> - jsonEmptyObject - MyUnit v0 -> - "tag" := "MyUnit" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - Pair v0 -> - "tag" := "Pair" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject - Triple v0 -> - "tag" := "Triple" ~> - "contents" := - ( (let a = v0 in case a of v0 /\ v1 /\ v2 /\ unit -> - [ (let a = v0 in encodeJson a) - , (let a = v1 in jsonEmptyArray) - , (let a = v2 in encodeJson a) - ]) - ) ~> - jsonEmptyObject - Quad v0 -> - "tag" := "Quad" ~> - "contents" := - ( (let a = v0 in case a of v0 /\ v1 /\ v2 /\ v3 /\ unit -> - [ (let a = v0 in encodeJson a) - , (let a = v1 in encodeJson a) - , (let a = v2 in encodeJson a) - , (let a = v3 in encodeJson a) - ]) - ) ~> - jsonEmptyObject - QuadSimple v0 v1 v2 v3 -> - "tag" := "QuadSimple" ~> - "contents" := - ( fromArray - [ (let a = v0 in encodeJson a) - , (let a = v1 in encodeJson a) - , (let a = v2 in encodeJson a) - , (let a = v3 in encodeJson a) - ] - ) ~> - jsonEmptyObject - Enum v0 -> - "tag" := "Enum" ~> - "contents" := - ( (let a = v0 in encodeJson a) - ) ~> - jsonEmptyObject + encodeJson = E.encode + $ E.sumType + $ toEither + >$< E.tagged "Nullary" E.null + >|< E.tagged "Bool" E.value + >|< E.tagged "Int" E.value + >|< E.tagged "Number" E.value + >|< E.tagged "String" E.value + >|< E.tagged "Array" E.value + >|< E.tagged "Record" E.value + >|< E.tagged "NestedRecord" E.value + >|< E.tagged "NT" E.value + >|< E.tagged "NTRecord" E.value + >|< E.tagged "Unit" E.unit + >|< E.tagged "MyUnit" E.value + >|< E.tagged "Pair" (E.tuple (E.value >/\< E.value)) + >|< E.tagged "Triple" (E.tuple (E.value >/\< E.unit >/\< E.value)) + >|< E.tagged "Quad" (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + >|< E.tagged "QuadSimple" (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + >|< E.tagged "Enum" E.value + where + toEither = case _ of + Nullary -> Left $ unit + (Bool a) -> Right $ Left $ (a) + (Int a) -> Right $ Right $ Left $ (a) + (Number a) -> Right $ Right $ Right $ Left $ (a) + (String a) -> Right $ Right $ Right $ Right $ Left $ (a) + (Array a) -> Right $ Right $ Right $ Right $ Right $ Left $ (a) + (Record a) -> Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (NestedRecord a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (NT a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (NTRecord a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (Unit a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (MyUnit a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (Pair a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (Triple a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (Quad a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (QuadSimple a b c d) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a /\ b /\ c /\ d) + (Enum a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ (a) instance decodeJsonTestSum :: DecodeJson TestSum where - decodeJson json = - do - obj <- decodeJObject json - tag <- obj .: "tag" - json <- obj .:? "contents" .!= jsonNull - case tag of - "Nullary" -> pure Nullary - "Bool" -> lmap (AtKey "contents") $ Bool <$> - ( decodeJson json - ) - "Int" -> lmap (AtKey "contents") $ Int <$> - ( decodeJson json - ) - "Number" -> lmap (AtKey "contents") $ Number <$> - ( decodeJson json - ) - "String" -> lmap (AtKey "contents") $ String <$> - ( decodeJson json - ) - "Array" -> lmap (AtKey "contents") $ Array <$> - ( decodeJson json - ) - "Record" -> lmap (AtKey "contents") $ Record <$> - ( decodeJson json - ) - "NestedRecord" -> lmap (AtKey "contents") $ NestedRecord <$> - ( decodeJson json - ) - "NT" -> lmap (AtKey "contents") $ NT <$> - ( decodeJson json - ) - "NTRecord" -> lmap (AtKey "contents") $ NTRecord <$> - ( decodeJson json - ) - "Unit" -> lmap (AtKey "contents") $ Unit <$> - ( unit <$ decodeArray (Left <<< UnexpectedValue) json - ) - "MyUnit" -> lmap (AtKey "contents") $ MyUnit <$> - ( decodeJson json - ) - "Pair" -> lmap (AtKey "contents") $ Pair <$> - ( decodeJson json - ) - "Triple" -> lmap (AtKey "contents") $ Triple <$> - ( do - arr <- decodeJArray json - v0 <- - maybe - (Left $ AtIndex 0 $ MissingValue) - (\json -> - decodeJson json - ) - $ index arr 0 - v1 <- - maybe - (Left $ AtIndex 1 $ MissingValue) - (\json -> - unit <$ decodeArray (Left <<< UnexpectedValue) json - ) - $ index arr 1 - v2 <- - maybe - (Left $ AtIndex 2 $ MissingValue) - (\json -> - decodeJson json - ) - $ index arr 2 - pure $ v0 /\ v1 /\ v2 /\ unit - ) - "Quad" -> lmap (AtKey "contents") $ Quad <$> - ( do - arr <- decodeJArray json - v0 <- - maybe - (Left $ AtIndex 0 $ MissingValue) - (\json -> - decodeJson json - ) - $ index arr 0 - v1 <- - maybe - (Left $ AtIndex 1 $ MissingValue) - (\json -> - decodeJson json - ) - $ index arr 1 - v2 <- - maybe - (Left $ AtIndex 2 $ MissingValue) - (\json -> - decodeJson json - ) - $ index arr 2 - v3 <- - maybe - (Left $ AtIndex 3 $ MissingValue) - (\json -> - decodeJson json - ) - $ index arr 3 - pure $ v0 /\ v1 /\ v2 /\ v3 /\ unit - ) - "QuadSimple" -> do - arr <- decodeJArray json - lmap (AtKey "contents") $ QuadSimple <$> - ( do - json <- maybe (Left $ AtIndex 0 $ MissingValue) Right $ index arr 0 - ( decodeJson json - ) - ) <*> - ( do - json <- maybe (Left $ AtIndex 1 $ MissingValue) Right $ index arr 1 - ( decodeJson json - ) - ) <*> - ( do - json <- maybe (Left $ AtIndex 2 $ MissingValue) Right $ index arr 2 - ( decodeJson json - ) - ) <*> - ( do - json <- maybe (Left $ AtIndex 3 $ MissingValue) Right $ index arr 3 - ( decodeJson json - ) - ) - "Enum" -> lmap (AtKey "contents") $ Enum <$> - ( decodeJson json - ) - _ -> Left $ AtKey "tag" (UnexpectedValue json) + decodeJson = D.decode + $ D.sumType "TestSum" + $ D.tagged "Nullary" (Nullary <$ D.null) + <|> D.tagged "Bool" (Bool <$> D.value) + <|> D.tagged "Int" (Int <$> D.value) + <|> D.tagged "Number" (Number <$> D.value) + <|> D.tagged "String" (String <$> D.value) + <|> D.tagged "Array" (Array <$> D.value) + <|> D.tagged "Record" (Record <$> D.value) + <|> D.tagged "NestedRecord" (NestedRecord <$> D.value) + <|> D.tagged "NT" (NT <$> D.value) + <|> D.tagged "NTRecord" (NTRecord <$> D.value) + <|> D.tagged "Unit" (Unit <$> D.unit) + <|> D.tagged "MyUnit" (MyUnit <$> D.value) + <|> D.tagged "Pair" (Pair <$> (D.tuple (D.value D.value))) + <|> D.tagged "Triple" (Triple <$> (D.tuple (D.value D.unit D.value))) + <|> D.tagged "Quad" (Quad <$> (D.tuple (D.value D.value D.value D.value))) + <|> D.tagged "QuadSimple" (D.tuple $ QuadSimple D.value D.value D.value D.value) + <|> D.tagged "Enum" (Enum <$> D.value) derive instance genericTestSum :: Generic TestSum _ -------------------------------------------------------------------------------- -_Nullary :: Prism' TestSum Unit -_Nullary = prism' (\_ -> Nullary) f - where - f Nullary = Just unit - f _ = Nothing - -_Bool :: Prism' TestSum Boolean -_Bool = prism' Bool f - where - f (Bool a) = Just $ a - f _ = Nothing - -_Int :: Prism' TestSum Int -_Int = prism' Int f - where - f (Int a) = Just $ a - f _ = Nothing - -_Number :: Prism' TestSum Number -_Number = prism' Number f - where - f (Number a) = Just $ a - f _ = Nothing - -_String :: Prism' TestSum String -_String = prism' String f - where - f (String a) = Just $ a - f _ = Nothing - -_Array :: Prism' TestSum (Array Int) -_Array = prism' Array f - where - f (Array a) = Just $ a - f _ = Nothing - -_Record :: Prism' TestSum (TestRecord Int) -_Record = prism' Record f - where - f (Record a) = Just $ a - f _ = Nothing - -_NestedRecord :: Prism' TestSum (TestRecord (TestRecord Int)) -_NestedRecord = prism' NestedRecord f - where - f (NestedRecord a) = Just $ a - f _ = Nothing - -_NT :: Prism' TestSum TestNewtype -_NT = prism' NT f - where - f (NT a) = Just $ a - f _ = Nothing - -_NTRecord :: Prism' TestSum TestNewtypeRecord -_NTRecord = prism' NTRecord f - where - f (NTRecord a) = Just $ a - f _ = Nothing - -_Unit :: Prism' TestSum Unit -_Unit = prism' Unit f - where - f (Unit a) = Just $ a - f _ = Nothing - -_MyUnit :: Prism' TestSum MyUnit -_MyUnit = prism' MyUnit f - where - f (MyUnit a) = Just $ a - f _ = Nothing - -_Pair :: Prism' TestSum (Tuple Int Number) -_Pair = prism' Pair f - where - f (Pair a) = Just $ a - f _ = Nothing - -_Triple :: Prism' TestSum (Tuple3 Int Unit Boolean) -_Triple = prism' Triple f - where - f (Triple a) = Just $ a - f _ = Nothing - -_Quad :: Prism' TestSum (Tuple4 Int Number Boolean Number) -_Quad = prism' Quad f - where - f (Quad a) = Just $ a - f _ = Nothing - -_QuadSimple :: Prism' TestSum { a :: Int - , b :: Number - , c :: Boolean - , d :: Number } -_QuadSimple = prism' (\{ a, b, c, d } -> QuadSimple a b c d) f - where - f (QuadSimple a b c d) = Just $ { a: a, b: b, c: c, d: d } - f _ = Nothing - -_Enum :: Prism' TestSum TestEnum -_Enum = prism' Enum f - where - f (Enum a) = Just $ a - f _ = Nothing +_Nullary :: (Prism' TestSum Unit) +_Nullary = prism' (const Nullary) case _ of + Nullary -> Just unit + _ -> Nothing + +_Bool :: (Prism' TestSum Boolean) +_Bool = prism' Bool case _ of + (Bool a) -> Just a + _ -> Nothing + +_Int :: (Prism' TestSum Int) +_Int = prism' Int case _ of + (Int a) -> Just a + _ -> Nothing + +_Number :: (Prism' TestSum Number) +_Number = prism' Number case _ of + (Number a) -> Just a + _ -> Nothing + +_String :: (Prism' TestSum String) +_String = prism' String case _ of + (String a) -> Just a + _ -> Nothing + +_Array :: (Prism' TestSum (Array Int)) +_Array = prism' Array case _ of + (Array a) -> Just a + _ -> Nothing + +_Record :: (Prism' TestSum (TestRecord Int)) +_Record = prism' Record case _ of + (Record a) -> Just a + _ -> Nothing + +_NestedRecord :: (Prism' TestSum (TestRecord (TestRecord Int))) +_NestedRecord = prism' NestedRecord case _ of + (NestedRecord a) -> Just a + _ -> Nothing + +_NT :: (Prism' TestSum TestNewtype) +_NT = prism' NT case _ of + (NT a) -> Just a + _ -> Nothing + +_NTRecord :: (Prism' TestSum TestNewtypeRecord) +_NTRecord = prism' NTRecord case _ of + (NTRecord a) -> Just a + _ -> Nothing + +_Unit :: (Prism' TestSum Unit) +_Unit = prism' Unit case _ of + (Unit a) -> Just a + _ -> Nothing + +_MyUnit :: (Prism' TestSum MyUnit) +_MyUnit = prism' MyUnit case _ of + (MyUnit a) -> Just a + _ -> Nothing + +_Pair :: (Prism' TestSum (Tuple Int Number)) +_Pair = prism' Pair case _ of + (Pair a) -> Just a + _ -> Nothing + +_Triple :: (Prism' TestSum (Tuple Int (Tuple Unit Boolean))) +_Triple = prism' Triple case _ of + (Triple a) -> Just a + _ -> Nothing + +_Quad :: (Prism' TestSum (Tuple Int (Tuple Number (Tuple Boolean Number)))) +_Quad = prism' Quad case _ of + (Quad a) -> Just a + _ -> Nothing + +_QuadSimple :: (Prism' TestSum {a :: Int, b :: Number, c :: Boolean, d :: Number}) +_QuadSimple = prism' (\{a, b, c, d} -> (QuadSimple a b c d)) case _ of + (QuadSimple a b c d) -> Just {a, b, c, d} + _ -> Nothing + +_Enum :: (Prism' TestSum TestEnum) +_Enum = prism' Enum case _ of + (Enum a) -> Just a + _ -> Nothing -------------------------------------------------------------------------------- newtype TestRecord a = TestRecord - { _field1 :: Int + { _field1 :: (Maybe Int) , _field2 :: a } @@ -496,21 +268,17 @@ instance showTestRecord :: (Show a) => Show (TestRecord a) where derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where - encodeJson = - case _ of - TestRecord {_field1, _field2} -> - "_field1" := (let a = _field1 in encodeJson a) ~> - "_field2" := (let a = _field2 in encodeJson a) ~> - jsonEmptyObject + encodeJson = E.encode + $ unwrap + >$< (E.record + {_field1: (E.maybe E.value) :: Encoder (Maybe Int), + _field2: E.value :: Encoder a}) instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) where - decodeJson json = - do - x <- decodeJson json - _field1 <- x .: "_field1" >>= \json -> decodeJson json - _field2 <- x .: "_field2" >>= \json -> decodeJson json - pure $ TestRecord {_field1, _field2} + decodeJson = D.decode $ TestRecord <$> D.record "TestRecord" + {_field1: (D.maybe D.value) :: Decoder (Maybe Int), + _field2: D.value :: Decoder a} derive instance genericTestRecord :: Generic (TestRecord a) _ @@ -518,10 +286,10 @@ derive instance newtypeTestRecord :: Newtype (TestRecord a) _ -------------------------------------------------------------------------------- -_TestRecord :: forall a. Iso' (TestRecord a) { _field1 :: Int, _field2 :: a } +_TestRecord :: forall a. (Iso' (TestRecord a) {_field1 :: (Maybe Int), _field2 :: a}) _TestRecord = _Newtype -field1 :: forall a. Lens' (TestRecord a) Int +field1 :: forall a. Lens' (TestRecord a) (Maybe Int) field1 = _Newtype <<< prop (Proxy :: _ "_field1") field2 :: forall a. Lens' (TestRecord a) a @@ -539,17 +307,13 @@ instance showTestNewtype :: Show TestNewtype where derive instance ordTestNewtype :: Ord TestNewtype instance encodeJsonTestNewtype :: EncodeJson TestNewtype where - encodeJson = - case _ of - TestNewtype v0 -> - (let a = v0 in encodeJson a) + encodeJson = E.encode + $ unwrap + >$< E.value instance decodeJsonTestNewtype :: DecodeJson TestNewtype where - decodeJson json = - lmap (AtKey "contents") $ TestNewtype <$> - ( decodeJson json - ) + decodeJson = D.decode $ TestNewtype <$> D.value derive instance genericTestNewtype :: Generic TestNewtype _ @@ -557,7 +321,7 @@ derive instance newtypeTestNewtype :: Newtype TestNewtype _ -------------------------------------------------------------------------------- -_TestNewtype :: Iso' TestNewtype (TestRecord Boolean) +_TestNewtype :: (Iso' TestNewtype (TestRecord Boolean)) _TestNewtype = _Newtype -------------------------------------------------------------------------------- @@ -574,19 +338,15 @@ instance showTestNewtypeRecord :: Show TestNewtypeRecord where derive instance ordTestNewtypeRecord :: Ord TestNewtypeRecord instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where - encodeJson = - case _ of - TestNewtypeRecord {unTestNewtypeRecord} -> - "unTestNewtypeRecord" := (let a = unTestNewtypeRecord in encodeJson a) ~> - jsonEmptyObject + encodeJson = E.encode + $ unwrap + >$< (E.record + {unTestNewtypeRecord: E.value :: Encoder TestNewtype}) instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where - decodeJson json = - do - x <- decodeJson json - unTestNewtypeRecord <- x .: "unTestNewtypeRecord" >>= \json -> decodeJson json - pure $ TestNewtypeRecord {unTestNewtypeRecord} + decodeJson = D.decode $ TestNewtypeRecord <$> D.record "TestNewtypeRecord" + {unTestNewtypeRecord: D.value :: Decoder TestNewtype} derive instance genericTestNewtypeRecord :: Generic TestNewtypeRecord _ @@ -594,7 +354,7 @@ derive instance newtypeTestNewtypeRecord :: Newtype TestNewtypeRecord _ -------------------------------------------------------------------------------- -_TestNewtypeRecord :: Iso' TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } +_TestNewtypeRecord :: (Iso' TestNewtypeRecord {unTestNewtypeRecord :: TestNewtype}) _TestNewtypeRecord = _Newtype -------------------------------------------------------------------------------- @@ -615,67 +375,58 @@ instance showTestEnum :: Show TestEnum where derive instance ordTestEnum :: Ord TestEnum instance encodeJsonTestEnum :: EncodeJson TestEnum where - encodeJson = - fromString <<< show + encodeJson = E.encode E.enum instance decodeJsonTestEnum :: DecodeJson TestEnum where - decodeJson json = - decodeJson json >>= case _ of - "Mon" -> pure Mon - "Tue" -> pure Tue - "Wed" -> pure Wed - "Thu" -> pure Thu - "Fri" -> pure Fri - "Sat" -> pure Sat - "Sun" -> pure Sun - _ -> Left (UnexpectedValue json) + decodeJson = D.decode D.enum derive instance genericTestEnum :: Generic TestEnum _ +instance enumTestEnum :: Enum TestEnum where + succ = genericSucc + pred = genericPred + +instance boundedTestEnum :: Bounded TestEnum where + bottom = genericBottom + top = genericTop + -------------------------------------------------------------------------------- -_Mon :: Prism' TestEnum Unit -_Mon = prism' (\_ -> Mon) f - where - f Mon = Just unit - f _ = Nothing - -_Tue :: Prism' TestEnum Unit -_Tue = prism' (\_ -> Tue) f - where - f Tue = Just unit - f _ = Nothing - -_Wed :: Prism' TestEnum Unit -_Wed = prism' (\_ -> Wed) f - where - f Wed = Just unit - f _ = Nothing - -_Thu :: Prism' TestEnum Unit -_Thu = prism' (\_ -> Thu) f - where - f Thu = Just unit - f _ = Nothing - -_Fri :: Prism' TestEnum Unit -_Fri = prism' (\_ -> Fri) f - where - f Fri = Just unit - f _ = Nothing - -_Sat :: Prism' TestEnum Unit -_Sat = prism' (\_ -> Sat) f - where - f Sat = Just unit - f _ = Nothing - -_Sun :: Prism' TestEnum Unit -_Sun = prism' (\_ -> Sun) f - where - f Sun = Just unit - f _ = Nothing +_Mon :: (Prism' TestEnum Unit) +_Mon = prism' (const Mon) case _ of + Mon -> Just unit + _ -> Nothing + +_Tue :: (Prism' TestEnum Unit) +_Tue = prism' (const Tue) case _ of + Tue -> Just unit + _ -> Nothing + +_Wed :: (Prism' TestEnum Unit) +_Wed = prism' (const Wed) case _ of + Wed -> Just unit + _ -> Nothing + +_Thu :: (Prism' TestEnum Unit) +_Thu = prism' (const Thu) case _ of + Thu -> Just unit + _ -> Nothing + +_Fri :: (Prism' TestEnum Unit) +_Fri = prism' (const Fri) case _ of + Fri -> Just unit + _ -> Nothing + +_Sat :: (Prism' TestEnum Unit) +_Sat = prism' (const Sat) case _ of + Sat -> Just unit + _ -> Nothing + +_Sun :: (Prism' TestEnum Unit) +_Sun = prism' (const Sun) case _ of + Sun -> Just unit + _ -> Nothing -------------------------------------------------------------------------------- data MyUnit @@ -689,23 +440,25 @@ instance showMyUnit :: Show MyUnit where derive instance ordMyUnit :: Ord MyUnit instance encodeJsonMyUnit :: EncodeJson MyUnit where - encodeJson = - fromString <<< show + encodeJson = E.encode E.enum instance decodeJsonMyUnit :: DecodeJson MyUnit where - decodeJson json = - decodeJson json >>= case _ of - "U" -> pure U - _ -> Left (UnexpectedValue json) + decodeJson = D.decode D.enum derive instance genericMyUnit :: Generic MyUnit _ +instance enumMyUnit :: Enum MyUnit where + succ = genericSucc + pred = genericPred + +instance boundedMyUnit :: Bounded MyUnit where + bottom = genericBottom + top = genericTop + -------------------------------------------------------------------------------- -_U :: Prism' MyUnit Unit -_U = prism' (\_ -> U) f - where - f U = Just unit +_U :: (Iso' MyUnit Unit) +_U = iso (const unit) (const U) -------------------------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs index 9200ccd1..8c92eafd 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -101,7 +101,7 @@ allTests = do , " | Bar2 (Either a b)" , " | Bar3 a" , " | Bar4" - , " { myMonadicResult :: m b" + , " { myMonadicResult :: (m b)" , " }" , "" , "derive instance genericBar :: Generic (Bar a b m c) _" From 223129254499fcc1ab027966d5f5e0081a4b0bd8 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 20 Oct 2021 14:15:21 -0400 Subject: [PATCH 040/111] Refactor printing --- src/Language/PureScript/Bridge/PSTypes.hs | 3 +- src/Language/PureScript/Bridge/Printer.hs | 776 ++++++++++---------- test/RoundTrip/Spec.hs | 2 +- test/RoundTrip/app/src/RoundTrip/Types.purs | 232 +++--- test/Spec.hs | 141 ++-- 5 files changed, 541 insertions(+), 613 deletions(-) diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs index 5d03156e..2162cf77 100644 --- a/src/Language/PureScript/Bridge/PSTypes.hs +++ b/src/Language/PureScript/Bridge/PSTypes.hs @@ -7,9 +7,8 @@ -- | PureScript types to be used for bridges, e.g. in "Language.PureScript.Bridge.Primitives". module Language.PureScript.Bridge.PSTypes where -import Control.Lens (views, view) +import Control.Lens (view) import Control.Monad.Reader.Class -import qualified Data.Text as T import Language.PureScript.Bridge.Builder import Language.PureScript.Bridge.TypeInfo diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 87377305..a76eac2e 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -2,10 +2,19 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} - -module Language.PureScript.Bridge.Printer where - -import Control.Lens (to, traversed,(^.), (^..)) +{-# LANGUAGE BlockArguments #-} + +module Language.PureScript.Bridge.Printer + ( printModule + , sumTypesToNeededPackages + , sumTypesToModules + , sumTypeToModule + , sumTypeToDocs + , renderText + , moduleToText + ) where + +import Control.Lens (to,(^.), (%~), (<>~)) import Control.Monad (unless) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -18,18 +27,15 @@ import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.SumType (DataConstructor (..), Instance (..), - RecordEntry (RecordEntry), + RecordEntry (..), DataConstructorArgs (..), SumType (SumType), getUsedTypes, nootype, recLabel, recValue, - sumTypeConstructors, - sumTypeInfo, _recLabel, sigConstructor) import Language.PureScript.Bridge.TypeInfo (Language (PureScript), PSType, TypeInfo (TypeInfo), - typeParameters, _typeModule, _typeName, _typePackage, @@ -43,24 +49,23 @@ import System.FilePath (joinPath, import Text.PrettyPrint.Leijen.Text (Doc, comma, displayTStrict, - encloseSep, hcat, hsep, indent, - lbrace, line, - linebreak, lparen, + line, lparen, parens, punctuate, - rbrace, renderPretty, - rparen, space, + rparen, textStrict, vsep, - (<+>), hang, dquotes, braces, char, backslash) + (<+>), hang, dquotes, char, backslash, nest, linebreak, lbrace, rbrace, softline) import Data.List (unfoldr) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Char (isLower) +import Data.Char (isLower, toLower) import Language.PureScript.Bridge.PSTypes (psUnit) +import Control.Arrow ((&&&)) +import Data.Function ((&)) renderText :: Doc -> Text -renderText = displayTStrict . renderPretty 0.4 200 +renderText = T.replace " \n" "\n" . displayTStrict . renderPretty 0.4 200 data Module (lang :: Language) = PSModule @@ -84,6 +89,116 @@ type Modules = Map Text PSModule type ImportLines = Map Text ImportLine +sumTypesToModules :: [SumType 'PureScript] -> Modules +sumTypesToModules = foldr (Map.unionWith unionModules) Map.empty . fmap sumTypeToModule + +unionModules :: PSModule -> PSModule -> PSModule +unionModules m1 m2 = + m1 + { psImportLines = unionImportLines (psImportLines m1) (psImportLines m2) + , psTypes = psTypes m1 <> psTypes m2 + } + +sumTypeToModule :: SumType 'PureScript -> Modules +sumTypeToModule st@(SumType t _ is) = + Map.singleton + (_typeModule t) + $ PSModule + { psModuleName = _typeModule t + , psImportLines = + dropEmpty $ + dropPrelude $ + dropPrim $ + dropSelf $ + unionImportLines + (typesToImportLines (getUsedTypes st)) + (instancesToImportLines is) + , psQualifiedImports = instancesToQualifiedImports is + , psTypes = [st] + } + where + dropEmpty = Map.delete "" + dropPrelude = Map.delete "Prelude" + dropPrim = Map.delete "Prim" + dropSelf = Map.delete (_typeModule t) + +unionQualifiedImports :: Map Text Text -> Map Text Text -> Map Text Text +unionQualifiedImports = Map.unionWith const + +unionImportLines :: ImportLines -> ImportLines -> ImportLines +unionImportLines = Map.unionWith unionImportLine + +unionImportLine :: ImportLine -> ImportLine -> ImportLine +unionImportLine l1 l2 = + l1 { importTypes = Set.union (importTypes l1) (importTypes l2) } + +typesToImportLines :: Set PSType -> ImportLines +typesToImportLines = + foldr unionImportLines Map.empty . fmap typeToImportLines . Set.toList + +typeToImportLines :: PSType -> ImportLines +typeToImportLines t = + unionImportLines (typesToImportLines $ Set.fromList (_typeParameters t)) $ + importsFromList [ImportLine (_typeModule t) (Set.singleton (_typeName t))] + +instancesToQualifiedImports :: [Instance] -> Map Text Text +instancesToQualifiedImports = + foldr unionQualifiedImports Map.empty . fmap instanceToQualifiedImports + +instancesToImportLines :: [Instance] -> ImportLines +instancesToImportLines = + foldr unionImportLines Map.empty . fmap instanceToImportLines + +instanceToImportLines :: Instance -> ImportLines +instanceToImportLines GenericShow = + importsFromList [ ImportLine "Data.Show.Generic" $ Set.singleton "genericShow" ] +instanceToImportLines Json = + importsFromList + [ ImportLine "Control.Alt" $ Set.singleton "(<|>)" + , ImportLine "Data.Array" $ Set.singleton "index" + , ImportLine "Data.Bifunctor" $ Set.singleton "lmap" + , ImportLine "Data.Argonaut.Core" $ Set.fromList ["jsonEmptyArray", "jsonEmptyObject", "jsonNull", "fromArray", "fromString"] + , ImportLine "Data.Argonaut.Decode" $ Set.fromList ["JsonDecodeError(..)", "(.:)", "(.:?)", "(.!=)", "decodeJson"] + , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["Decoder", "()", "()", "()"] + , ImportLine "Data.Argonaut.Decode.Decoders" $ Set.fromList ["decodeJArray", "decodeJObject", "decodeArray", "decodeNull"] + , ImportLine "Data.Argonaut.Encode" $ Set.fromList ["(:=)", "(~>)", "encodeJson"] + , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["Encoder", "(>$<)", "(>*<)", "(>/\\<)", "(>|<)"] + , ImportLine "Data.Either" $ Set.singleton "Either(..)" + , ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)", "maybe"] + , ImportLine "Data.Newtype" $ Set.singleton "unwrap" + , ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" + ] +instanceToImportLines Enum = + importsFromList + [ ImportLine "Data.Enum.Generic" $ Set.fromList ["genericPred", "genericSucc"] + ] +instanceToImportLines Bounded = + importsFromList + [ ImportLine "Data.Bounded.Generic" $ Set.fromList ["genericBottom", "genericTop"] + ] +instanceToImportLines _ = Map.empty + +instanceToQualifiedImports :: Instance -> Map Text Text +instanceToQualifiedImports Json = + Map.fromList + [ ("Data.Argonaut.Decode.Aeson", "D") + , ("Data.Argonaut.Encode.Aeson", "E") + ] +instanceToQualifiedImports _ = Map.empty + +importsFromList :: [ImportLine] -> Map Text ImportLine +importsFromList ls = + let pairs = zip (importModule <$> ls) ls + merge a b = + ImportLine (importModule a) (importTypes a `Set.union` importTypes b) + in Map.fromListWith merge pairs + +mergeImportLines :: ImportLines -> ImportLines -> ImportLines +mergeImportLines = Map.unionWith mergeLines + where + mergeLines a b = + ImportLine (importModule a) (importTypes a `Set.union` importTypes b) + printModule :: Switches.Settings -> FilePath -> PSModule -> IO () printModule settings root m = do unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir @@ -103,26 +218,30 @@ sumTypeToNeededPackages st = moduleToText :: Switches.Settings -> Module 'PureScript -> Text moduleToText settings m = - T.unlines $ "-- File auto generated by purescript-bridge! --" : "module " <> - psModuleName m <> - " where\n" : - "import Prelude" : - (importLineToText <$> allImports) <> - (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) <> - [""] <> - (renderText . sumTypeToDoc settings <$> psTypes m) + renderText $ vsep $ + [ "-- File auto generated by purescript-bridge! --" + , "module" <+> textStrict (psModuleName m) <+> "where" <> linebreak + , "import Prelude" <> linebreak + , vsep + ( (importLineToText <$> allImports) + <> (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) + ) + <> linebreak + ] + <> punctuate (line <> line <> dashes <> line) (sumTypeToDocs settings =<< psTypes m) where otherImports = importsFromList - (_lensImports settings <> _genericsImports) + (lensImports settings <> genericsImports) allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) + dashes = textStrict (T.replicate 80 "-") -_genericsImports :: [ImportLine] -_genericsImports = +genericsImports :: [ImportLine] +genericsImports = [ ImportLine "Data.Generic.Rep" $ Set.singleton "class Generic" ] -_lensImports :: Switches.Settings -> [ImportLine] -_lensImports settings +lensImports :: Switches.Settings -> [ImportLine] +lensImports settings | Switches.generateLenses settings = [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] , ImportLine "Data.Lens" $ @@ -134,105 +253,115 @@ _lensImports settings | otherwise = [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] ] -qualifiedImportToText :: Text -> Text -> Text -qualifiedImportToText m q = "import " <> m <> " as " <> q +qualifiedImportToText :: Text -> Text -> Doc +qualifiedImportToText m q = hsep ["import", textStrict m, "as", textStrict q] -importLineToText :: ImportLine -> Text -importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")" - where - typeList = T.intercalate ", " (Set.toList (importTypes l)) +importLineToText :: ImportLine -> Doc +importLineToText l = + hsep ["import", textStrict $ importModule l, encloseHsep lparen rparen comma typeList] + where + typeList = textStrict <$> Set.toList (importTypes l) -sumTypeToDoc :: Switches.Settings -> SumType 'PureScript -> Doc -sumTypeToDoc settings st = vsep $ punctuate line [sumTypeToTypeDecls st, additionalCode] - where - additionalCode = - if Switches.generateLenses settings - then lenses - else dashes - lenses = vsep $ punctuate line [dashes, sumTypeToOptics st, dashes] - dashes = textStrict (T.replicate 80 "-") +sumTypeToDocs :: Switches.Settings -> SumType 'PureScript -> [Doc] +sumTypeToDocs settings st + | Switches.generateLenses settings = [sumTypeToTypeDecls st, sumTypeToOptics st] + | otherwise = [sumTypeToTypeDecls st] sumTypeToTypeDecls :: SumType 'PureScript -> Doc -sumTypeToTypeDecls (SumType t cs is) = - vsep $ punctuate line $ - (dataOrNewtype <+> typeInfoToDecl t - <> line - <> indent - 2 - (encloseVsep - ("=" <> space) - mempty - ("|" <> space) - (constructorToDoc <$> cs)) - ) : instances (SumType t cs is) +sumTypeToTypeDecls st@(SumType t cs _) = + vsep $ punctuate line $ typeDecl : instances st where - dataOrNewtype = - if isJust (nootype cs) - then "newtype" - else "data" + typeDecl + | isJust (nootype cs) = mkTypeDecl "newtype" + | otherwise = mkTypeDecl "data" + mkTypeDecl keyword = + keyword <+> typeInfoToDecl t <+> encloseVsep "=" mempty "|" (constructorToDoc <$> cs) + +typeInfoToDecl :: PSType -> Doc +typeInfoToDecl (TypeInfo _ _ name params) = + hsep $ textStrict name : (typeInfoToDoc <$> params) + +typeInfoToDoc :: PSType -> Doc +typeInfoToDoc t@(TypeInfo _ _ _ params) = + (if null params then id else parens) $ typeInfoToDecl t + +constructorToDoc :: DataConstructor 'PureScript -> Doc +constructorToDoc (DataConstructor n args) = + hsep $ textStrict n : case args of + Nullary -> [] + Normal ts -> NE.toList $ typeInfoToDoc <$> ts + Record rs -> [vrecord $ fieldSignatures rs] -- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. instances :: SumType 'PureScript -> [Doc] instances st@(SumType t _ is) = go <$> is where - stpLength = length sumTypeParameters - sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st - extras instanceConstraints - | stpLength == 0 = mempty - | otherwise = - constraintsInner (instanceConstraints <$> sumTypeParameters) <+> "=>" - name = textStrict (_typeName t) - go :: Instance -> Doc - go Bounded = - hang 2 $ vsep - [ "instance bounded" <> name <+> "::" <+> "Bounded" <+> typeInfoToDoc t <+> "where" - , "bottom = genericBottom" - , "top = genericTop" - ] - go Enum = - hang 2 $ vsep - [ "instance enum" <> name <+> "::" <+> "Enum" <+> typeInfoToDoc t <+> "where" - , "succ = genericSucc" - , "pred = genericPred" - ] - go Json = + mkConstraints :: (PSType -> [PSType]) -> [Doc] + mkConstraints getConstraints = case getConstraints t of + [] -> [] + constraints -> [encloseHsep lparen rparen comma (typeInfoToDecl <$> constraints), "=>"] + mkInstance name getConstraints ty methods = vsep - [ hang 2 $ vsep - [ "instance encodeJson" <> name <+> "::" <+> extras encodeJsonInstance <+> "EncodeJson" <+> typeInfoToDoc t <+> "where" - , hang 2 ("encodeJson = E.encode" <+> sumTypeToEncode st) - ] - , linebreak - , hang 2 $ vsep - [ "instance decodeJson" <> name <+> "::" <+> extras decodeJsonInstance <+> "DecodeJson" <+> typeInfoToDoc t <+> "where" - , hang 2 ("decodeJson = D.decode" <+> sumTypeToDecode st) - ] + [ hsep + [ "instance" + , textStrict $ T.cons (toLower $ T.head name) (T.tail name) <> _typeName ty + , "::" + , hsep $ mkConstraints getConstraints <> [typeInfoToDecl $ mkType name [ty]] + , "where" + ] + , indent 2 $ vsep methods ] - go GenericShow = - "instance show" <> name <+> "::" <+> extras showInstance <+> "Show" <+> - typeInfoToDoc t <+> - "where" <> - linebreak <> - indent 2 "show x = genericShow x" - go Functor = - "derive instance functor" <> name <+> "::" <+> "Functor" <+> name - go Eq = - "derive instance eq" <> name <+> "::" <+> extras eqInstance <+> "Eq" <+> - typeInfoToDoc t - go Eq1 = "derive instance eq1" <> name <+> "::" <+> "Eq1" <+> name - go Ord = - "derive instance ord" <> name <+> "::" <+> extras ordInstance <+> "Ord" <+> - typeInfoToDoc t - go i = - "derive instance " <> textStrict (T.toLower c) <> name <+> "::" <+> - textStrict c <+> - typeInfoToDoc t <> - postfix i - where - c = T.pack $ show i - postfix Newtype = " _" - postfix Generic = " _" - postfix _ = "" + mkDerivedInstance name getConstraints params ty = + hsep $ + [ "derive instance" + , textStrict $ T.cons (toLower $ T.head name) (T.tail name) <> _typeName ty + , "::" + , hsep $ mkConstraints getConstraints <> [typeInfoToDecl $ mkType name [ty]] + ] + <> params + toKind1 (TypeInfo p m n []) = TypeInfo p m n [] + toKind1 (TypeInfo p m n ps) = TypeInfo p m n $ init ps + go :: Instance -> Doc + go Bounded = mkInstance "Bounded" (const []) t + [ "bottom = genericBottom" + , "top = genericTop" + ] + go Enum = mkInstance "Enum" (const []) t + [ "succ = genericSucc" + , "pred = genericPred" + ] + go Json = vsep $ punctuate line + [ mkInstance "EncodeJson" encodeJsonConstraints t + [ "encodeJson = E.encode" <+> nest 2 (sumTypeToEncode st) ] + , mkInstance "DecodeJson" decodeJsonConstraints t + [ "decodeJson = D.decode" <+> nest 2 (sumTypeToDecode st) ] + ] + go GenericShow = mkInstance "Show" showConstraints t [ "show = genericShow" ] + go Functor = mkDerivedInstance "Functor" (const []) [] $ toKind1 t + go Eq = mkDerivedInstance "Eq" eqConstraints [] t + go Eq1 = mkDerivedInstance "Eq1" (const []) [] $ toKind1 t + go Ord = mkDerivedInstance "Ord" ordConstraints [] t + go Generic = mkDerivedInstance "Generic" (const []) ["_"] t + go Newtype = mkDerivedInstance "Newtype" (const []) ["_"] t + +constrainWith :: Text -> PSType -> [PSType] +constrainWith name = map (mkType name . pure) . typeParams + +eqConstraints :: PSType -> [PSType] +eqConstraints = constrainWith "Eq" + +ordConstraints :: PSType -> [PSType] +ordConstraints = constrainWith "Ord" + +showConstraints :: PSType -> [PSType] +showConstraints = constrainWith "Show" + +decodeJsonConstraints :: PSType -> [PSType] +decodeJsonConstraints = constrainWith "DecodeJson" + +encodeJsonConstraints :: PSType -> [PSType] +encodeJsonConstraints = constrainWith "EncodeJson" isEnum :: [DataConstructor lang] -> Bool isEnum = all $ (== Nullary) . _sigValues @@ -241,28 +370,25 @@ sumTypeToEncode :: SumType 'PureScript -> Doc sumTypeToEncode (SumType _ cs _) | isEnum cs = "E.enum" | otherwise = - line <> "$" <+> case cs of + linebreak <> "$" <+> vsep case cs of [dc@(DataConstructor _ args)] -> - vsep - [ if isJust (nootype [dc]) - then "unwrap" - else parens $ "case _ of" <+> branch (constructorPattern dc) (constructorExpr args) - , ">$<" <+> hang 2 (argsToEncode args) - ] - _ -> - vsep - [ "E.sumType" - , "$ toEither" - , indent 4 $ ">$<" <+> hsep (punctuate (line <> ">|<") (constructorToTagged <$> cs)) - , "where" - , "toEither =" <+> case_of (unfoldr toEither ("", cs)) - ] + [ if isJust (nootype [dc]) + then "unwrap" + else parens $ case_of [(constructorPattern dc, constructor args)] + , ">$<" <+> nest 2 (argsToEncode args) + ] + _ -> + [ "E.sumType" + , "$ toEither" <+> encloseVsep ">$<" mempty ">|<" (constructorToTagged <$> cs) + , "where" + , "toEither =" <+> case_of (unfoldr toEither ("", cs)) + ] where toEither (_, []) = Nothing toEither (prefix, dc@(DataConstructor _ args) : rest) = Just ( ( constructorPattern dc - , prefix <+> eitherCase rest <+> "$" <+> constructorExpr args + , prefix <+> eitherCase rest <+> "$" <+> constructor args ) , (nextPrefix rest, rest) ) @@ -276,13 +402,20 @@ sumTypeToEncode (SumType _ cs _) argsToEncode Nullary = "E.null" argsToEncode (Normal (t :| [])) = typeToEncode t argsToEncode (Normal ts) = - parens $ "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> NE.toList ts) - argsToEncode (Record fields) = parens $ vsep - [ "E.record" - , braces $ vsep $ punctuate comma $ fieldToEncode <$> NE.toList fields - ] - fieldToEncode (RecordEntry name t) = - textStrict name <> ":" <+> typeToEncode t <+> ":: Encoder" <+> typeInfoToDoc t + parens $ "E.tuple" <+> encloseHsep lparen rparen " >/\\<" (typeToEncode <$> NE.toList ts) + argsToEncode (Record rs) = + "E.record" <> softline <> vrecord (fieldSignatures $ fieldEncoder <$> rs) + where + fieldEncoder r = + r + & recValue %~ mkType "Encoder" . pure + & recLabel <>~ renderText (":" <+> typeToEncode (_recValue r)) + +flattenTuple :: [PSType] -> [PSType] +flattenTuple [] = [] +flattenTuple [a] = [a] +flattenTuple [a, TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts'] = a : flattenTuple ts' +flattenTuple (h : t) = h : flattenTuple t typeToEncode :: PSType -> Doc typeToEncode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = "E.unit" @@ -292,11 +425,6 @@ typeToEncode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = pare "E.either" <+> typeToEncode l <+> typeToEncode r typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) - where - flattenTuple [] = [] - flattenTuple [a] = [a] - flattenTuple [a, TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts'] = a : flattenTuple ts' - flattenTuple (h : t) = h : flattenTuple t typeToEncode _ = "E.value" @@ -306,13 +434,13 @@ sumTypeToDecode (SumType _ cs _) sumTypeToDecode (SumType _ [c] _) = "$" <+> constructorToDecode c sumTypeToDecode (SumType t cs _) = line <> vsep - [ "$ D.sumType" <+> dquotes (t ^. typeName . to textStrict) - , "$" <+> hang 2 (hsep $ punctuate (line <> "<|>") $ constructorToTagged <$> cs) + [ "$ D.sumType" <+> t ^. typeName . to textStrict . to dquotes + , "$" <+> encloseVsep mempty mempty "<|>" (constructorToTagged <$> cs) ] where constructorToTagged dc = "D.tagged" - <+> dc ^. sigConstructor . to textStrict . to dquotes + <+> dc ^. sigConstructor . to textStrict . to dquotes <+> dc ^. to constructorToDecode . to parens @@ -325,16 +453,17 @@ constructorToDecode (DataConstructor name (Normal as)) = "D.tuple" <+> "$" <+> textStrict name - <+> "" - <+> hsep (punctuate " " $ typeToDecode <$> NE.toList as) -constructorToDecode (DataConstructor name (Record fields)) = - vsep - [ textStrict name <+> "<$> D.record" <+> dquotes (textStrict name) - , braces $ vsep $ punctuate comma $ fieldToDecode <$> NE.toList fields - ] - where - fieldToDecode (RecordEntry n t) = - textStrict n <> ":" <+> typeToDecode t <+> ":: Decoder" <+> typeInfoToDoc t + <+> encloseHsep "" mempty " " (typeToDecode <$> NE.toList as) +constructorToDecode (DataConstructor name (Record rs)) = + textStrict name + <+> "<$> D.record" + <+> dquotes (textStrict name) + <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) + where + fieldDecoder r = + r + & recValue %~ mkType "Decoder" . pure + & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) typeToDecode :: PSType -> Doc typeToDecode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = "D.unit" @@ -343,89 +472,25 @@ typeToDecode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = parens $ typeToDecode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = parens $ "D.either" <+> typeToDecode l <+> typeToDecode r typeToDecode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ - "D.tuple" <+> parens (hsep $ punctuate " " $ typeToDecode <$> flattenTuple ts) - where - flattenTuple [] = [] - flattenTuple [a] = [a] - flattenTuple [a, TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts'] = a : flattenTuple ts' - flattenTuple (h : t) = h : flattenTuple t + "D.tuple" <+> encloseHsep lparen rparen " " (typeToDecode <$> flattenTuple ts) typeToDecode _ = "D.value" -constraintsInner :: [Doc] -> Doc -constraintsInner = encloseSep lparen rparen ("," <> space) - -isTypeParam :: PSType -> PSType -> Bool -isTypeParam t typ = _typeName typ `elem` map _typeName (_typeParameters t) - -eqInstance :: PSType -> Doc -eqInstance params = "Eq" <+> typeInfoToDoc params - -ordInstance :: PSType -> Doc -ordInstance params = "Ord" <+> typeInfoToDoc params - -showInstance :: PSType -> Doc -showInstance params = "Show" <+> typeInfoToDoc params - -decodeJsonInstance :: PSType -> Doc -decodeJsonInstance params = "DecodeJson" <+> typeInfoToDoc params - -encodeJsonInstance :: PSType -> Doc -encodeJsonInstance params = "EncodeJson" <+> typeInfoToDoc params - -genericInstance :: PSType -> Doc -genericInstance params = - "Generic" <+> typeInfoToDoc params <+> "r" <> mergedTypeInfoToDoc params sumTypeToOptics :: SumType 'PureScript -> Doc sumTypeToOptics st = vsep $ punctuate line $ constructorOptics st <> recordOptics st constructorOptics :: SumType 'PureScript -> [Doc] -constructorOptics st = - case st ^. sumTypeConstructors of - [] -> [] -- No work required. - [c] -> [constructorToOptic False typeInfo c] - cs -> constructorToOptic True typeInfo <$> cs - where - typeInfo = st ^. sumTypeInfo +constructorOptics (SumType t cs _) = constructorToOptic (length cs > 1) t <$> cs recordOptics :: SumType 'PureScript -> [Doc] -recordOptics st@(SumType _ [DataConstructor _ (Record fields)] _) = - recordEntryToLens st <$> filter hasUnderscore (NE.toList fields) +recordOptics st@(SumType _ [DataConstructor _ (Record rs)] _) = + recordEntryToLens st <$> filter hasUnderscore (NE.toList rs) recordOptics _ = mempty hasUnderscore :: RecordEntry lang -> Bool hasUnderscore (RecordEntry name _) = "_" `T.isPrefixOf` name -constructorToDoc :: DataConstructor 'PureScript -> Doc -constructorToDoc (DataConstructor n Nullary) = textStrict n -constructorToDoc (DataConstructor n (Normal ts)) = - textStrict n <+> hsep (typeInfoToDoc <$> NE.toList ts) -constructorToDoc (DataConstructor n (Record rs)) = - textStrict n <> line <> indent 4 (recordFields (recordEntryToDoc <$> NE.toList rs)) - -recordFields :: [Doc] -> Doc -recordFields = encloseVsep (lbrace <> space) (line <> rbrace) (comma <> space) - -encloseVsep :: Doc -> Doc -> Doc -> [Doc] -> Doc -encloseVsep left right sp ds = - case ds of - [] -> left <> right - [d] -> left <> d <> right - _ -> vsep (zipWith (<>) (left : repeat sp) ds) <> right - -typeNameAndForall :: TypeInfo 'PureScript -> (Doc, Doc) -typeNameAndForall typeInfo = (typName, forAll) - where - typName = typeInfoToDoc typeInfo - forAllParams = - typeInfo ^.. typeParameters . traversed . to typeInfoToDoc - forAll = - " :: " <> - case forAllParams of - [] -> mempty - cs -> "forall" <+> hsep cs <> ". " - constructorToOptic :: Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Doc constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = @@ -434,35 +499,31 @@ constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = (Nullary, True) -> prism pName typeInfo psUnit cName "unit" $ parens ("const" <+> cName) (Normal (t :| []), False) -> newtypeIso pName typeInfo t (Normal (t :| []), True) -> prism pName typeInfo t (normalPattern n [t]) "a" cName - (Normal ts, False) -> - iso - pName - typeInfo - (mkType (renderText $ recordType rec) []) - (parens (lambda (normalPattern n ts) (recordExpr rec))) - (parens (lambda (recordExpr rec) (normalPattern n ts))) - where - rec = argsToRecord ts - (Normal ts, True) -> - prism - pName - typeInfo - (mkType (renderText $ recordType rec) []) - (normalPattern n ts) - (recordExpr rec) - (parens (lambda (recordExpr rec) (normalPattern n ts))) + (Normal ts, _) + | hasOtherConstructors -> prism pName typeInfo toType fromExpr toExpr toMorph + | otherwise -> iso pName typeInfo toType fromMorph toMorph where - rec = argsToRecord ts - (Record rs, False) -> newtypeIso pName typeInfo (mkType (renderText $ recordType rs) []) - (Record rs, True) -> newtypeIso pName typeInfo (mkType (renderText $ recordType rs) []) + fields' = fields $ typesToRecord ts + toType = recordType $ typesToRecord ts + fromExpr = normalPattern n ts + toExpr = hrecord fields' + fromMorph = parens $ lambda fromExpr toExpr + toMorph = parens $ lambda toExpr fromExpr + (Record rs, False) -> newtypeIso pName typeInfo $ recordType rs + (Record rs, True) -> + prism pName typeInfo (recordType rs) fromExpr toExpr + $ parens + $ lambda toExpr fromExpr + where + fromExpr = pattern n "a" + toExpr = pattern n "a" where cName = textStrict n pName = "_" <> textStrict n - recordType = braces . hsep . punctuate ", " . map recordFieldSig . NE.toList - recordFieldSig (RecordEntry name t) = signature False (textStrict name) [] [] t + recordType = (`mkType` []) . renderText . hrecord . fieldSignatures -argsToRecord :: NonEmpty PSType -> NonEmpty (RecordEntry 'PureScript) -argsToRecord = fmap (uncurry RecordEntry) . NE.zip (T.singleton <$> ['a'..]) +typesToRecord :: NonEmpty PSType -> NonEmpty (RecordEntry 'PureScript) +typesToRecord = fmap (uncurry RecordEntry) . NE.zip (T.singleton <$> ['a'..]) iso :: Doc -> PSType -> PSType -> Doc -> Doc -> Doc iso name fromType toType fromMorph toMorph = @@ -496,150 +557,16 @@ newtypeIso name fromType toType = "_Newtype" recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Doc -recordEntryToLens st e = +recordEntryToLens (SumType t _ _) e = if hasUnderscore e then vsep - [ textStrict lensName <> forAll <> "Lens'" <+> typName <+> recType - , textStrict lensName <+> "= _Newtype <<< prop" <+> - parens ("Proxy :: _ \"" <> textStrict recName <> "\"") - ] + [ signature True lensName [] [] $ mkType "Lens'" [t, e ^. recValue] + , lensName <+> "= _Newtype <<< prop" <+> parens ("Proxy :: _" <> dquotes recName) + ] else mempty where - (typName, forAll) = typeNameAndForall (st ^. sumTypeInfo) - recName = e ^. recLabel - lensName = T.drop 1 recName - recType = typeInfoToDoc (e ^. recValue) - -recordEntryToDoc :: RecordEntry 'PureScript -> Doc -recordEntryToDoc e = - textStrict (_recLabel e) <+> "::" <+> typeInfoToDoc (e ^. recValue) - -typeInfoToText :: PSType -> Text -typeInfoToText = renderText . typeInfoToDoc - -typeInfoToDecl :: PSType -> Doc -typeInfoToDecl (TypeInfo _ _ name params) = - hsep $ textStrict name : (typeInfoToDoc <$> params) - -typeInfoToDoc :: PSType -> Doc -typeInfoToDoc t@(TypeInfo _ _ _ params) = - (if null params then id else parens) $ typeInfoToDecl t - -mergedTypeInfoToDoc :: PSType -> Doc -mergedTypeInfoToDoc t = textStrict (_typeName t) <> hcat textParameters - where - params = _typeParameters t - textParameters = mergedTypeInfoToDoc <$> params - -sumTypesToModules :: [SumType 'PureScript] -> Modules -sumTypesToModules = foldr (Map.unionWith unionModules) Map.empty . fmap sumTypeToModule - -unionModules :: PSModule -> PSModule -> PSModule -unionModules m1 m2 = - m1 - { psImportLines = unionImportLines (psImportLines m1) (psImportLines m2) - , psTypes = psTypes m1 <> psTypes m2 - } - -sumTypeToModule :: SumType 'PureScript -> Modules -sumTypeToModule st@(SumType t _ is) = - Map.singleton - (_typeModule t) - $ PSModule - { psModuleName = _typeModule t - , psImportLines = - dropEmpty $ - dropPrelude $ - dropPrim $ - dropSelf $ - unionImportLines - (typesToImportLines (getUsedTypes st)) - (instancesToImportLines is) - , psQualifiedImports = instancesToQualifiedImports is - , psTypes = [st] - } - where - dropEmpty = Map.delete "" - dropPrelude = Map.delete "Prelude" - dropPrim = Map.delete "Prim" - dropSelf = Map.delete (_typeModule t) - -unionQualifiedImports :: Map Text Text -> Map Text Text -> Map Text Text -unionQualifiedImports = Map.unionWith const - -unionImportLines :: ImportLines -> ImportLines -> ImportLines -unionImportLines = Map.unionWith unionImportLine - -unionImportLine :: ImportLine -> ImportLine -> ImportLine -unionImportLine l1 l2 = - l1 { importTypes = Set.union (importTypes l1) (importTypes l2) } - -typesToImportLines :: Set PSType -> ImportLines -typesToImportLines = - foldr unionImportLines Map.empty . fmap typeToImportLines . Set.toList - -typeToImportLines :: PSType -> ImportLines -typeToImportLines t = - unionImportLines (typesToImportLines $ Set.fromList (_typeParameters t)) $ - importsFromList [ImportLine (_typeModule t) (Set.singleton (_typeName t))] - -instancesToQualifiedImports :: [Instance] -> Map Text Text -instancesToQualifiedImports = - foldr unionQualifiedImports Map.empty . fmap instanceToQualifiedImports - -instancesToImportLines :: [Instance] -> ImportLines -instancesToImportLines = - foldr unionImportLines Map.empty . fmap instanceToImportLines - -instanceToImportLines :: Instance -> ImportLines -instanceToImportLines GenericShow = - importsFromList [ ImportLine "Data.Show.Generic" $ Set.singleton "genericShow" ] -instanceToImportLines Json = - importsFromList - [ ImportLine "Control.Alt" $ Set.singleton "(<|>)" - , ImportLine "Data.Array" $ Set.singleton "index" - , ImportLine "Data.Bifunctor" $ Set.singleton "lmap" - , ImportLine "Data.Argonaut.Core" $ Set.fromList ["jsonEmptyArray", "jsonEmptyObject", "jsonNull", "fromArray", "fromString"] - , ImportLine "Data.Argonaut.Decode" $ Set.fromList ["JsonDecodeError(..)", "(.:)", "(.:?)", "(.!=)", "decodeJson"] - , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["Decoder", "()", "()", "()"] - , ImportLine "Data.Argonaut.Decode.Decoders" $ Set.fromList ["decodeJArray", "decodeJObject", "decodeArray", "decodeNull"] - , ImportLine "Data.Argonaut.Encode" $ Set.fromList ["(:=)", "(~>)", "encodeJson"] - , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["Encoder", "(>$<)", "(>*<)", "(>/\\<)", "(>|<)"] - , ImportLine "Data.Either" $ Set.singleton "Either(..)" - , ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)", "maybe"] - , ImportLine "Data.Newtype" $ Set.singleton "unwrap" - , ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" - ] -instanceToImportLines Enum = - importsFromList - [ ImportLine "Data.Enum.Generic" $ Set.fromList ["genericPred", "genericSucc"] - ] -instanceToImportLines Bounded = - importsFromList - [ ImportLine "Data.Bounded.Generic" $ Set.fromList ["genericBottom", "genericTop"] - ] -instanceToImportLines _ = Map.empty - -instanceToQualifiedImports :: Instance -> Map Text Text -instanceToQualifiedImports Json = - Map.fromList - [ ("Data.Argonaut.Decode.Aeson", "D") - , ("Data.Argonaut.Encode.Aeson", "E") - ] -instanceToQualifiedImports _ = Map.empty - -importsFromList :: [ImportLine] -> Map Text ImportLine -importsFromList ls = - let pairs = zip (importModule <$> ls) ls - merge a b = - ImportLine (importModule a) (importTypes a `Set.union` importTypes b) - in Map.fromListWith merge pairs - -mergeImportLines :: ImportLines -> ImportLines -> ImportLines -mergeImportLines = Map.unionWith mergeLines - where - mergeLines a b = - ImportLine (importModule a) (importTypes a `Set.union` importTypes b) + recName = e ^. recLabel . to textStrict + lensName = e ^. recLabel . to (T.drop 1) . to textStrict unlessM :: Monad m => m Bool -> m () -> m () unlessM mbool action = mbool >>= flip unless action @@ -649,10 +576,10 @@ constructorPattern (DataConstructor name Nullary) = nullaryPattern name constructorPattern (DataConstructor name (Normal ts)) = normalPattern name ts constructorPattern (DataConstructor name (Record rs)) = recordPattern name rs -constructorExpr :: DataConstructorArgs 'PureScript -> Doc -constructorExpr Nullary = nullaryExpr -constructorExpr (Normal ts) = normalExpr ts -constructorExpr (Record rs) = recordExpr rs +constructor :: DataConstructorArgs 'PureScript -> Doc +constructor Nullary = nullaryExpr +constructor (Normal ts) = normalExpr ts +constructor (Record rs) = vrecord $ fields rs nullaryPattern :: Text -> Doc nullaryPattern = textStrict @@ -661,7 +588,7 @@ nullaryExpr :: Doc nullaryExpr = "unit" normalPattern :: Text -> NonEmpty PSType -> Doc -normalPattern name = parens . (textStrict name <+>) . hsep . normalLabels +normalPattern name = pattern name . hsep . normalLabels normalExpr :: NonEmpty PSType -> Doc normalExpr = parens . hsep . punctuate " /\\" . normalLabels @@ -670,46 +597,62 @@ normalLabels :: NonEmpty PSType -> [Doc] normalLabels = fmap char . zipWith const ['a'..] . NE.toList recordPattern :: Text -> NonEmpty (RecordEntry 'PureScript) -> Doc -recordPattern name = parens . (textStrict name <+>) . recordExpr +recordPattern name = pattern name . vrecord . fields + +vrecord :: [Doc] -> Doc +vrecord = encloseVsep lbrace rbrace comma -recordExpr :: NonEmpty (RecordEntry 'PureScript) -> Doc -recordExpr = braces . hsep . punctuate ", " . recordLabels +hrecord :: [Doc] -> Doc +hrecord = encloseHsep lbrace rbrace comma -recordLabels :: NonEmpty (RecordEntry 'PureScript) -> [Doc] -recordLabels = fmap recordLabel . NE.toList +fields :: NonEmpty (RecordEntry 'PureScript) -> [Doc] +fields = fmap field . NE.toList -recordLabel :: RecordEntry 'PureScript -> Doc -recordLabel = textStrict . _recLabel +field :: RecordEntry 'PureScript -> Doc +field = textStrict . _recLabel + +fieldSignatures :: NonEmpty (RecordEntry 'PureScript) -> [Doc] +fieldSignatures = fmap fieldSignature . NE.toList + +fieldSignature :: RecordEntry 'PureScript -> Doc +fieldSignature = uncurry signature' . (field &&& _recValue) + +pattern :: Text -> Doc -> Doc +pattern name = parens . (textStrict name <+>) case_of :: [(Doc, Doc)] -> Doc case_of = caseOf "_" caseOf :: Doc -> [(Doc, Doc)] -> Doc +caseOf scrutinee [(p, b)] = + hsep ["case", scrutinee, "of", branch p b] caseOf scrutinee branches = vsep $ hsep ["case", scrutinee, "of"] : (indent 2 . uncurry branch <$> branches) branch :: Doc -> Doc -> Doc -branch pattern body = hsep [pattern, "->", body] +branch p body = hsep [p, "->", body] lambda :: Doc -> Doc -> Doc lambda variables body = backslash <> branch variables body +signature' :: Doc -> PSType-> Doc +signature' name = signature False name [] [] + signature :: Bool -> Doc -> [PSType] -> [PSType] -> PSType-> Doc signature topLevel name constraints params ret = - hsep $ catMaybes [Just name, Just "::", forAll, constraintsDoc, paramsDoc, Just $ typeInfoToDoc ret] + hsep $ catMaybes [Just name, Just "::", forAll, constraintsDoc, paramsDoc, Just $ typeInfoToDecl ret] where - forAll = case (topLevel, typeParams) of + forAll = case (topLevel, allTypes >>= typeParams) of (False, _) -> Nothing (_, []) -> Nothing - (_, ps) -> Just $ "forall" <+> hsep (textStrict <$> ps) <> "." - typeParams = filter (isLower . T.head) $ _typeName <$> allTypes - allTypes = concatMap flattenTypeInfo $ constraints <> params <> [ret] + (_, ps) -> Just $ "forall" <+> hsep (typeInfoToDoc <$> ps) <> "." + allTypes = ret : constraints <> params constraintsDoc = case constraints of [] -> Nothing - cs -> Just $ hsep ((<+> "=>") . typeInfoToDecl <$> cs) + cs -> Just $ hsep ((<+> "=>") . typeInfoToDecl <$> cs) paramsDoc = case params of [] -> Nothing - ps -> Just $ hsep ((<+> "->") . typeInfoToDecl <$> ps) + ps -> Just $ hsep ((<+> "->") . typeInfoToDecl <$> ps) def :: Doc -> [PSType] -> [(Doc, PSType)] -> PSType -> Doc -> Doc def name constraints params ret body = vsep @@ -719,3 +662,20 @@ def name constraints params ret body = vsep mkType :: Text -> [PSType] -> PSType mkType = TypeInfo "" "" + +typeParams :: PSType -> [PSType] +typeParams = filter (isLower . T.head . _typeName) . flattenTypeInfo + +encloseHsep :: Doc -> Doc -> Doc -> [Doc] -> Doc +encloseHsep left right sp ds = + case ds of + [] -> left <> right + _ -> left <> hsep (punctuate sp ds) <> right + +encloseVsep :: Doc -> Doc -> Doc -> [Doc] -> Doc +encloseVsep left right sp ds = + case ds of + [] -> left <> right + [d] -> left <+> d <+> right + _ -> nest 2 $ linebreak <> vsep (zipWith (<+>) (left : repeat (hang 2 sp)) ds <> [right]) + diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 3a632210..e53171a0 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -53,7 +53,7 @@ roundtripSpec = do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" assertBool stderr $ not $ "[warn]" `isInfixOf` stderr it "should produce aeson-compatible argonaut instances" $ - property $ + once $ property $ \testData -> bracket runApp killApp $ \(hin, hout, hproc) -> do hPutStrLn hin $ toString $ encode @TestData testData diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index c40da35b..8499321c 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -2,6 +2,7 @@ module RoundTrip.Types where import Prelude + import Control.Alt ((<|>)) import Data.Argonaut.Core (fromArray, fromString, jsonEmptyArray, jsonEmptyObject, jsonNull) import Data.Argonaut.Decode ((.!=), (.:), (.:?), JsonDecodeError(..), class DecodeJson, decodeJson) @@ -36,43 +37,44 @@ data TestData derive instance eqTestData :: Eq TestData instance showTestData :: Show TestData where - show x = genericShow x + show = genericShow derive instance ordTestData :: Ord TestData instance encodeJsonTestData :: EncodeJson TestData where - encodeJson = E.encode + encodeJson = E.encode $ E.sumType $ toEither - >$< E.tagged "Maybe" (E.maybe E.value) - >|< E.tagged "Either" (E.either (E.maybe E.value) (E.maybe E.value)) + >$< E.tagged "Maybe" (E.maybe E.value) + >|< E.tagged "Either" (E.either (E.maybe E.value) (E.maybe E.value)) where toEither = case _ of (Maybe a) -> Left $ (a) (Either a) -> Right $ (a) - instance decodeJsonTestData :: DecodeJson TestData where - decodeJson = D.decode + decodeJson = D.decode $ D.sumType "TestData" - $ D.tagged "Maybe" (Maybe <$> (D.maybe D.value)) - <|> D.tagged "Either" (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) + $ + D.tagged "Maybe" (Maybe <$> (D.maybe D.value)) + <|> D.tagged "Either" (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) derive instance genericTestData :: Generic TestData _ -------------------------------------------------------------------------------- -_Maybe :: (Prism' TestData (Maybe TestSum)) +_Maybe :: Prism' TestData (Maybe TestSum) _Maybe = prism' Maybe case _ of (Maybe a) -> Just a _ -> Nothing -_Either :: (Prism' TestData (Either (Maybe Int) (Maybe Boolean))) +_Either :: Prism' TestData (Either (Maybe Int) (Maybe Boolean)) _Either = prism' Either case _ of (Either a) -> Just a _ -> Nothing -------------------------------------------------------------------------------- + data TestSum = Nullary | Bool Boolean @@ -95,31 +97,31 @@ data TestSum derive instance eqTestSum :: Eq TestSum instance showTestSum :: Show TestSum where - show x = genericShow x + show = genericShow derive instance ordTestSum :: Ord TestSum instance encodeJsonTestSum :: EncodeJson TestSum where - encodeJson = E.encode + encodeJson = E.encode $ E.sumType $ toEither - >$< E.tagged "Nullary" E.null - >|< E.tagged "Bool" E.value - >|< E.tagged "Int" E.value - >|< E.tagged "Number" E.value - >|< E.tagged "String" E.value - >|< E.tagged "Array" E.value - >|< E.tagged "Record" E.value - >|< E.tagged "NestedRecord" E.value - >|< E.tagged "NT" E.value - >|< E.tagged "NTRecord" E.value - >|< E.tagged "Unit" E.unit - >|< E.tagged "MyUnit" E.value - >|< E.tagged "Pair" (E.tuple (E.value >/\< E.value)) - >|< E.tagged "Triple" (E.tuple (E.value >/\< E.unit >/\< E.value)) - >|< E.tagged "Quad" (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) - >|< E.tagged "QuadSimple" (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) - >|< E.tagged "Enum" E.value + >$< E.tagged "Nullary" E.null + >|< E.tagged "Bool" E.value + >|< E.tagged "Int" E.value + >|< E.tagged "Number" E.value + >|< E.tagged "String" E.value + >|< E.tagged "Array" E.value + >|< E.tagged "Record" E.value + >|< E.tagged "NestedRecord" E.value + >|< E.tagged "NT" E.value + >|< E.tagged "NTRecord" E.value + >|< E.tagged "Unit" E.unit + >|< E.tagged "MyUnit" E.value + >|< E.tagged "Pair" (E.tuple (E.value >/\< E.value)) + >|< E.tagged "Triple" (E.tuple (E.value >/\< E.unit >/\< E.value)) + >|< E.tagged "Quad" (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + >|< E.tagged "QuadSimple" (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + >|< E.tagged "Enum" E.value where toEither = case _ of Nullary -> Left $ unit @@ -140,145 +142,146 @@ instance encodeJsonTestSum :: EncodeJson TestSum where (QuadSimple a b c d) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a /\ b /\ c /\ d) (Enum a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ (a) - instance decodeJsonTestSum :: DecodeJson TestSum where - decodeJson = D.decode + decodeJson = D.decode $ D.sumType "TestSum" - $ D.tagged "Nullary" (Nullary <$ D.null) - <|> D.tagged "Bool" (Bool <$> D.value) - <|> D.tagged "Int" (Int <$> D.value) - <|> D.tagged "Number" (Number <$> D.value) - <|> D.tagged "String" (String <$> D.value) - <|> D.tagged "Array" (Array <$> D.value) - <|> D.tagged "Record" (Record <$> D.value) - <|> D.tagged "NestedRecord" (NestedRecord <$> D.value) - <|> D.tagged "NT" (NT <$> D.value) - <|> D.tagged "NTRecord" (NTRecord <$> D.value) - <|> D.tagged "Unit" (Unit <$> D.unit) - <|> D.tagged "MyUnit" (MyUnit <$> D.value) - <|> D.tagged "Pair" (Pair <$> (D.tuple (D.value D.value))) - <|> D.tagged "Triple" (Triple <$> (D.tuple (D.value D.unit D.value))) - <|> D.tagged "Quad" (Quad <$> (D.tuple (D.value D.value D.value D.value))) - <|> D.tagged "QuadSimple" (D.tuple $ QuadSimple D.value D.value D.value D.value) - <|> D.tagged "Enum" (Enum <$> D.value) + $ + D.tagged "Nullary" (Nullary <$ D.null) + <|> D.tagged "Bool" (Bool <$> D.value) + <|> D.tagged "Int" (Int <$> D.value) + <|> D.tagged "Number" (Number <$> D.value) + <|> D.tagged "String" (String <$> D.value) + <|> D.tagged "Array" (Array <$> D.value) + <|> D.tagged "Record" (Record <$> D.value) + <|> D.tagged "NestedRecord" (NestedRecord <$> D.value) + <|> D.tagged "NT" (NT <$> D.value) + <|> D.tagged "NTRecord" (NTRecord <$> D.value) + <|> D.tagged "Unit" (Unit <$> D.unit) + <|> D.tagged "MyUnit" (MyUnit <$> D.value) + <|> D.tagged "Pair" (Pair <$> (D.tuple (D.value D.value))) + <|> D.tagged "Triple" (Triple <$> (D.tuple (D.value D.unit D.value))) + <|> D.tagged "Quad" (Quad <$> (D.tuple (D.value D.value D.value D.value))) + <|> D.tagged "QuadSimple" (D.tuple $ QuadSimple D.value D.value D.value D.value) + <|> D.tagged "Enum" (Enum <$> D.value) derive instance genericTestSum :: Generic TestSum _ -------------------------------------------------------------------------------- -_Nullary :: (Prism' TestSum Unit) +_Nullary :: Prism' TestSum Unit _Nullary = prism' (const Nullary) case _ of Nullary -> Just unit _ -> Nothing -_Bool :: (Prism' TestSum Boolean) +_Bool :: Prism' TestSum Boolean _Bool = prism' Bool case _ of (Bool a) -> Just a _ -> Nothing -_Int :: (Prism' TestSum Int) +_Int :: Prism' TestSum Int _Int = prism' Int case _ of (Int a) -> Just a _ -> Nothing -_Number :: (Prism' TestSum Number) +_Number :: Prism' TestSum Number _Number = prism' Number case _ of (Number a) -> Just a _ -> Nothing -_String :: (Prism' TestSum String) +_String :: Prism' TestSum String _String = prism' String case _ of (String a) -> Just a _ -> Nothing -_Array :: (Prism' TestSum (Array Int)) +_Array :: Prism' TestSum (Array Int) _Array = prism' Array case _ of (Array a) -> Just a _ -> Nothing -_Record :: (Prism' TestSum (TestRecord Int)) +_Record :: Prism' TestSum (TestRecord Int) _Record = prism' Record case _ of (Record a) -> Just a _ -> Nothing -_NestedRecord :: (Prism' TestSum (TestRecord (TestRecord Int))) +_NestedRecord :: Prism' TestSum (TestRecord (TestRecord Int)) _NestedRecord = prism' NestedRecord case _ of (NestedRecord a) -> Just a _ -> Nothing -_NT :: (Prism' TestSum TestNewtype) +_NT :: Prism' TestSum TestNewtype _NT = prism' NT case _ of (NT a) -> Just a _ -> Nothing -_NTRecord :: (Prism' TestSum TestNewtypeRecord) +_NTRecord :: Prism' TestSum TestNewtypeRecord _NTRecord = prism' NTRecord case _ of (NTRecord a) -> Just a _ -> Nothing -_Unit :: (Prism' TestSum Unit) +_Unit :: Prism' TestSum Unit _Unit = prism' Unit case _ of (Unit a) -> Just a _ -> Nothing -_MyUnit :: (Prism' TestSum MyUnit) +_MyUnit :: Prism' TestSum MyUnit _MyUnit = prism' MyUnit case _ of (MyUnit a) -> Just a _ -> Nothing -_Pair :: (Prism' TestSum (Tuple Int Number)) +_Pair :: Prism' TestSum (Tuple Int Number) _Pair = prism' Pair case _ of (Pair a) -> Just a _ -> Nothing -_Triple :: (Prism' TestSum (Tuple Int (Tuple Unit Boolean))) +_Triple :: Prism' TestSum (Tuple Int (Tuple Unit Boolean)) _Triple = prism' Triple case _ of (Triple a) -> Just a _ -> Nothing -_Quad :: (Prism' TestSum (Tuple Int (Tuple Number (Tuple Boolean Number)))) +_Quad :: Prism' TestSum (Tuple Int (Tuple Number (Tuple Boolean Number))) _Quad = prism' Quad case _ of (Quad a) -> Just a _ -> Nothing -_QuadSimple :: (Prism' TestSum {a :: Int, b :: Number, c :: Boolean, d :: Number}) -_QuadSimple = prism' (\{a, b, c, d} -> (QuadSimple a b c d)) case _ of - (QuadSimple a b c d) -> Just {a, b, c, d} +_QuadSimple :: Prism' TestSum {a :: Int, b :: Number, c :: Boolean, d :: Number} +_QuadSimple = prism' (\{a, b, c, d} -> (QuadSimple a b c d)) case _ of + (QuadSimple a b c d) -> Just {a, b, c, d} _ -> Nothing -_Enum :: (Prism' TestSum TestEnum) +_Enum :: Prism' TestSum TestEnum _Enum = prism' Enum case _ of (Enum a) -> Just a _ -> Nothing -------------------------------------------------------------------------------- -newtype TestRecord a - = TestRecord - { _field1 :: (Maybe Int) - , _field2 :: a - } + +newtype TestRecord a = TestRecord + { _field1 :: Maybe Int + , _field2 :: a + } derive instance functorTestRecord :: Functor TestRecord derive instance eqTestRecord :: (Eq a) => Eq (TestRecord a) instance showTestRecord :: (Show a) => Show (TestRecord a) where - show x = genericShow x + show = genericShow derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where - encodeJson = E.encode + encodeJson = E.encode $ unwrap - >$< (E.record - {_field1: (E.maybe E.value) :: Encoder (Maybe Int), - _field2: E.value :: Encoder a}) - + >$< E.record + { _field1: (E.maybe E.value) :: Encoder (Maybe Int) + , _field2: E.value :: Encoder a + } instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) where decodeJson = D.decode $ TestRecord <$> D.record "TestRecord" - {_field1: (D.maybe D.value) :: Decoder (Maybe Int), - _field2: D.value :: Decoder a} + { _field1: (D.maybe D.value) :: Decoder (Maybe Int) + , _field2: D.value :: Decoder a + } derive instance genericTestRecord :: Generic (TestRecord a) _ @@ -286,32 +289,31 @@ derive instance newtypeTestRecord :: Newtype (TestRecord a) _ -------------------------------------------------------------------------------- -_TestRecord :: forall a. (Iso' (TestRecord a) {_field1 :: (Maybe Int), _field2 :: a}) +_TestRecord :: forall a. Iso' (TestRecord a) {_field1 :: Maybe Int, _field2 :: a} _TestRecord = _Newtype field1 :: forall a. Lens' (TestRecord a) (Maybe Int) -field1 = _Newtype <<< prop (Proxy :: _ "_field1") +field1 = _Newtype <<< prop (Proxy :: _"_field1") -field2 :: forall a. Lens' (TestRecord a) a -field2 = _Newtype <<< prop (Proxy :: _ "_field2") +field2 :: forall a a. Lens' (TestRecord a) a +field2 = _Newtype <<< prop (Proxy :: _"_field2") -------------------------------------------------------------------------------- -newtype TestNewtype - = TestNewtype (TestRecord Boolean) + +newtype TestNewtype = TestNewtype (TestRecord Boolean) derive instance eqTestNewtype :: Eq TestNewtype instance showTestNewtype :: Show TestNewtype where - show x = genericShow x + show = genericShow derive instance ordTestNewtype :: Ord TestNewtype instance encodeJsonTestNewtype :: EncodeJson TestNewtype where - encodeJson = E.encode + encodeJson = E.encode $ unwrap >$< E.value - instance decodeJsonTestNewtype :: DecodeJson TestNewtype where decodeJson = D.decode $ TestNewtype <$> D.value @@ -321,32 +323,27 @@ derive instance newtypeTestNewtype :: Newtype TestNewtype _ -------------------------------------------------------------------------------- -_TestNewtype :: (Iso' TestNewtype (TestRecord Boolean)) +_TestNewtype :: Iso' TestNewtype (TestRecord Boolean) _TestNewtype = _Newtype -------------------------------------------------------------------------------- -newtype TestNewtypeRecord - = TestNewtypeRecord - { unTestNewtypeRecord :: TestNewtype - } + +newtype TestNewtypeRecord = TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } derive instance eqTestNewtypeRecord :: Eq TestNewtypeRecord instance showTestNewtypeRecord :: Show TestNewtypeRecord where - show x = genericShow x + show = genericShow derive instance ordTestNewtypeRecord :: Ord TestNewtypeRecord instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where - encodeJson = E.encode + encodeJson = E.encode $ unwrap - >$< (E.record - {unTestNewtypeRecord: E.value :: Encoder TestNewtype}) - + >$< E.record { unTestNewtypeRecord: E.value :: Encoder TestNewtype } instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where - decodeJson = D.decode $ TestNewtypeRecord <$> D.record "TestNewtypeRecord" - {unTestNewtypeRecord: D.value :: Decoder TestNewtype} + decodeJson = D.decode $ TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: Decoder TestNewtype } derive instance genericTestNewtypeRecord :: Generic TestNewtypeRecord _ @@ -354,10 +351,11 @@ derive instance newtypeTestNewtypeRecord :: Newtype TestNewtypeRecord _ -------------------------------------------------------------------------------- -_TestNewtypeRecord :: (Iso' TestNewtypeRecord {unTestNewtypeRecord :: TestNewtype}) +_TestNewtypeRecord :: Iso' TestNewtypeRecord {unTestNewtypeRecord :: TestNewtype} _TestNewtypeRecord = _Newtype -------------------------------------------------------------------------------- + data TestEnum = Mon | Tue @@ -370,14 +368,13 @@ data TestEnum derive instance eqTestEnum :: Eq TestEnum instance showTestEnum :: Show TestEnum where - show x = genericShow x + show = genericShow derive instance ordTestEnum :: Ord TestEnum instance encodeJsonTestEnum :: EncodeJson TestEnum where encodeJson = E.encode E.enum - instance decodeJsonTestEnum :: DecodeJson TestEnum where decodeJson = D.decode D.enum @@ -393,56 +390,55 @@ instance boundedTestEnum :: Bounded TestEnum where -------------------------------------------------------------------------------- -_Mon :: (Prism' TestEnum Unit) +_Mon :: Prism' TestEnum Unit _Mon = prism' (const Mon) case _ of Mon -> Just unit _ -> Nothing -_Tue :: (Prism' TestEnum Unit) +_Tue :: Prism' TestEnum Unit _Tue = prism' (const Tue) case _ of Tue -> Just unit _ -> Nothing -_Wed :: (Prism' TestEnum Unit) +_Wed :: Prism' TestEnum Unit _Wed = prism' (const Wed) case _ of Wed -> Just unit _ -> Nothing -_Thu :: (Prism' TestEnum Unit) +_Thu :: Prism' TestEnum Unit _Thu = prism' (const Thu) case _ of Thu -> Just unit _ -> Nothing -_Fri :: (Prism' TestEnum Unit) +_Fri :: Prism' TestEnum Unit _Fri = prism' (const Fri) case _ of Fri -> Just unit _ -> Nothing -_Sat :: (Prism' TestEnum Unit) +_Sat :: Prism' TestEnum Unit _Sat = prism' (const Sat) case _ of Sat -> Just unit _ -> Nothing -_Sun :: (Prism' TestEnum Unit) +_Sun :: Prism' TestEnum Unit _Sun = prism' (const Sun) case _ of Sun -> Just unit _ -> Nothing -------------------------------------------------------------------------------- -data MyUnit - = U + +data MyUnit = U derive instance eqMyUnit :: Eq MyUnit instance showMyUnit :: Show MyUnit where - show x = genericShow x + show = genericShow derive instance ordMyUnit :: Ord MyUnit instance encodeJsonMyUnit :: EncodeJson MyUnit where encodeJson = E.encode E.enum - instance decodeJsonMyUnit :: DecodeJson MyUnit where decodeJson = D.decode D.enum @@ -458,7 +454,5 @@ instance boundedMyUnit :: Bounded MyUnit where -------------------------------------------------------------------------------- -_U :: (Iso' MyUnit Unit) -_U = iso (const unit) (const U) - --------------------------------------------------------------------------------- +_U :: Iso' MyUnit Unit +_U = iso (const unit) (const U) \ No newline at end of file diff --git a/test/Spec.hs b/test/Spec.hs index 8c92eafd..968c97f6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -32,11 +32,11 @@ allTests = do describe "buildBridge without lens-code-gen" $ do let settings = getSettings noLenses it "tests generation of typeclasses for custom type Foo" $ - let recType = + let sumType = bridgeSumType (buildBridge defaultBridge) (genericShow . order $ mkSumType @Foo) - recTypeText = sumTypeToDoc settings recType + doc = vsep $ sumTypeToDocs settings sumType txt = T.unlines [ "data Foo" @@ -45,40 +45,35 @@ allTests = do , " | FooBar Int String" , "" , "instance showFoo :: Show Foo where" - , " show x = genericShow x" + , " show = genericShow" , "" , "derive instance eqFoo :: Eq Foo" , "" , "derive instance ordFoo :: Ord Foo" , "" , "derive instance genericFoo :: Generic Foo _" - , "" - , "--------------------------------------------------------------------------------" ] - in recTypeText `shouldRender` txt + in doc `shouldRender` txt it "tests generation of typeclasses for custom type Func" $ - let recType = + let sumType = bridgeSumType (buildBridge defaultBridge) (equal1 . functor . genericShow $ mkSumType @(Func A)) - recTypeText = sumTypeToDoc settings recType + doc = vsep $ sumTypeToDocs settings sumType txt = T.unlines - [ "data Func a" - , " = Func Int a" + [ "data Func a = Func Int a" , "" , "derive instance eq1Func :: Eq1 Func" , "" , "derive instance functorFunc :: Functor Func" , "" , "instance showFunc :: (Show a) => Show (Func a) where" - , " show x = genericShow x" + , " show = genericShow" , "" , "derive instance genericFunc :: Generic (Func a) _" - , "" - , "--------------------------------------------------------------------------------" ] - in recTypeText `shouldRender` txt + in doc `shouldRender` txt it "tests the generation of a whole (dummy) module" $ let advanced' = bridgeSumType @@ -87,141 +82,123 @@ allTests = do modules = sumTypeToModule advanced' m = head . map (moduleToText settings) . Map.elems $ modules txt = - T.unlines - [ "-- File auto generated by purescript-bridge! --" - , "module TestData where" - , "" - , "import Prelude" - , "import Data.Either (Either)" - , "import Data.Generic.Rep (class Generic)" - , "import Data.Maybe (Maybe, Maybe(..))" - , "" - , "data Bar a b m c" - , " = Bar1 (Maybe a)" - , " | Bar2 (Either a b)" - , " | Bar3 a" - , " | Bar4" - , " { myMonadicResult :: (m b)" - , " }" - , "" - , "derive instance genericBar :: Generic (Bar a b m c) _" - , "" - , "--------------------------------------------------------------------------------" - ] + T.dropWhileEnd (== '\n') $ + T.unlines + [ "-- File auto generated by purescript-bridge! --" + , "module TestData where" + , "" + , "import Prelude" + , "" + , "import Data.Either (Either)" + , "import Data.Generic.Rep (class Generic)" + , "import Data.Maybe (Maybe, Maybe(..))" + , "" + , "data Bar a b m c" + , " = Bar1 (Maybe a)" + , " | Bar2 (Either a b)" + , " | Bar3 a" + , " | Bar4 { myMonadicResult :: m b }" + , "" + , "derive instance genericBar :: 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 @(SingleRecord A B)) - recTypeText = sumTypeToDoc settings recType' + doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleRecord a b" - , " = SingleRecord" - , " { _a :: a" - , " , _b :: b" - , " , c :: String" - , " }" + [ "newtype SingleRecord a b = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" , "" , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" , "" , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" - , "" - , "--------------------------------------------------------------------------------" ] - in recTypeText `shouldRender` txt + in doc `shouldRender` txt it "tests generation of newtypes for haskell newtype" $ let recType' = bridgeSumType (buildBridge defaultBridge) (mkSumType @SomeNewtype) - recTypeText = sumTypeToDoc settings recType' + doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SomeNewtype" - , " = SomeNewtype Int" + [ "newtype SomeNewtype = SomeNewtype Int" , "" , "derive instance genericSomeNewtype :: Generic SomeNewtype _" , "" , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" - , "" - , "--------------------------------------------------------------------------------" ] - in recTypeText `shouldRender` txt + in doc `shouldRender` txt it "tests generation of newtypes for haskell data type with one argument" $ let recType' = bridgeSumType (buildBridge defaultBridge) (mkSumType @SingleValueConstr) - recTypeText = sumTypeToDoc settings recType' + doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleValueConstr" - , " = SingleValueConstr Int" + [ "newtype SingleValueConstr = SingleValueConstr Int" , "" , "derive instance genericSingleValueConstr :: Generic SingleValueConstr _" , "" , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" - , "" - , "--------------------------------------------------------------------------------" ] - in recTypeText `shouldRender` txt + in doc `shouldRender` txt it "tests generation for haskell data type with one constructor, two arguments" $ let recType' = bridgeSumType (buildBridge defaultBridge) (mkSumType @SingleProduct) - recTypeText = sumTypeToDoc settings recType' + doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "data SingleProduct" - , " = SingleProduct String Int" + [ "data SingleProduct = SingleProduct String Int" , "" , "derive instance genericSingleProduct :: Generic SingleProduct _" - , "" - , "--------------------------------------------------------------------------------" ] - in recTypeText `shouldRender` txt + in doc `shouldRender` txt it "tests generation Eq instances for polymorphic types" $ let recType' = bridgeSumType (buildBridge defaultBridge) (equal $ mkSumType @(SingleRecord A B)) - recTypeText = sumTypeToDoc settings recType' + doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleRecord a b" - , " = SingleRecord" - , " { _a :: a" - , " , _b :: b" - , " , c :: String" - , " }" + [ "newtype SingleRecord a b = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" , "" , "derive instance eqSingleRecord :: (Eq a, Eq b) => Eq (SingleRecord a b)" , "" , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" , "" , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" - , "" - , "--------------------------------------------------------------------------------" ] - in recTypeText `shouldRender` txt + in doc `shouldRender` txt it "tests generation of Ord instances for polymorphic types" $ let recType' = bridgeSumType (buildBridge defaultBridge) (order $ mkSumType @(SingleRecord A B)) - recTypeText = sumTypeToDoc settings recType' + doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleRecord a b" - , " = SingleRecord" - , " { _a :: a" - , " , _b :: b" - , " , c :: String" - , " }" + [ "newtype SingleRecord a b = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" , "" , "derive instance eqSingleRecord :: (Eq a, Eq b) => Eq (SingleRecord a b)" , "" @@ -230,10 +207,8 @@ allTests = do , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" , "" , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" - , "" - , "--------------------------------------------------------------------------------" ] - in recTypeText `shouldRender` txt + in doc `shouldRender` txt shouldRender :: Doc -> Text -> Expectation shouldRender actual expected = renderText actual `shouldBe` T.stripEnd expected From e6d4f98037b88e6719fc30ab8f0034900ed8bdfd Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 20 Oct 2021 15:01:49 -0400 Subject: [PATCH 041/111] Export everything again --- src/Language/PureScript/Bridge/Printer.hs | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index a76eac2e..8fb150b0 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -4,15 +4,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE BlockArguments #-} -module Language.PureScript.Bridge.Printer - ( printModule - , sumTypesToNeededPackages - , sumTypesToModules - , sumTypeToModule - , sumTypeToDocs - , renderText - , moduleToText - ) where +module Language.PureScript.Bridge.Printer where import Control.Lens (to,(^.), (%~), (<>~)) import Control.Monad (unless) From c898b46e79ba00dc28f8f365ab4c9a555bdd94c7 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Mon, 25 Oct 2021 10:19:52 -0400 Subject: [PATCH 042/111] Fix problems with inline records in sum types --- src/Language/PureScript/Bridge/Printer.hs | 14 ++--- test/RoundTrip/Types.hs | 2 + test/RoundTrip/app/src/RoundTrip/Types.purs | 62 ++++++++++++++------- 3 files changed, 51 insertions(+), 27 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 8fb150b0..d2d747e2 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -396,11 +396,11 @@ sumTypeToEncode (SumType _ cs _) argsToEncode (Normal ts) = parens $ "E.tuple" <+> encloseHsep lparen rparen " >/\\<" (typeToEncode <$> NE.toList ts) argsToEncode (Record rs) = - "E.record" <> softline <> vrecord (fieldSignatures $ fieldEncoder <$> rs) + parens $ "E.record" <> softline <> vrecord (fieldSignatures $ fieldEncoder <$> rs) where fieldEncoder r = r - & recValue %~ mkType "Encoder" . pure + & recValue %~ mkType "_" . pure & recLabel <>~ renderText (":" <+> typeToEncode (_recValue r)) flattenTuple :: [PSType] -> [PSType] @@ -454,7 +454,7 @@ constructorToDecode (DataConstructor name (Record rs)) = where fieldDecoder r = r - & recValue %~ mkType "Decoder" . pure + & recValue %~ mkType "_" . pure & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) typeToDecode :: PSType -> Doc @@ -503,12 +503,10 @@ constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = toMorph = parens $ lambda toExpr fromExpr (Record rs, False) -> newtypeIso pName typeInfo $ recordType rs (Record rs, True) -> - prism pName typeInfo (recordType rs) fromExpr toExpr - $ parens - $ lambda toExpr fromExpr + prism pName typeInfo (recordType rs) fromExpr toExpr cName where - fromExpr = pattern n "a" - toExpr = pattern n "a" + fromExpr = pattern n toExpr + toExpr = "a" where cName = textStrict n pName = "_" <> textStrict n diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index b6ca6ea0..f5cd4268 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -42,6 +42,7 @@ data TestSum | Number Double | String String | Array [Int] + | InlineRecord { why :: String, wouldYouDoThis :: Int } | Record (TestRecord Int) | NestedRecord (TestRecord (TestRecord Int)) | NT TestNewtype @@ -68,6 +69,7 @@ instance Arbitrary TestSum where Number <$> arbitrary, String <$> arbitrary, Array <$> arbitrary, + InlineRecord <$> arbitrary <*> arbitrary, Record <$> arbitrary, NestedRecord <$> arbitrary, NT <$> arbitrary, diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 8499321c..8703270d 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -82,6 +82,10 @@ data TestSum | Number Number | String String | Array (Array Int) + | InlineRecord + { why :: String + , wouldYouDoThis :: Int + } | Record (TestRecord Int) | NestedRecord (TestRecord (TestRecord Int)) | NT TestNewtype @@ -111,6 +115,10 @@ instance encodeJsonTestSum :: EncodeJson TestSum where >|< E.tagged "Number" E.value >|< E.tagged "String" E.value >|< E.tagged "Array" E.value + >|< E.tagged "InlineRecord" (E.record + { why: E.value :: _ String + , wouldYouDoThis: E.value :: _ Int + }) >|< E.tagged "Record" E.value >|< E.tagged "NestedRecord" E.value >|< E.tagged "NT" E.value @@ -130,17 +138,24 @@ instance encodeJsonTestSum :: EncodeJson TestSum where (Number a) -> Right $ Right $ Right $ Left $ (a) (String a) -> Right $ Right $ Right $ Right $ Left $ (a) (Array a) -> Right $ Right $ Right $ Right $ Right $ Left $ (a) - (Record a) -> Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (NestedRecord a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (NT a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (NTRecord a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (Unit a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (MyUnit a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (Pair a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (Triple a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (Quad a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (QuadSimple a b c d) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a /\ b /\ c /\ d) - (Enum a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ (a) + (InlineRecord + { why + , wouldYouDoThis + }) -> Right $ Right $ Right $ Right $ Right $ Right $ Left $ + { why + , wouldYouDoThis + } + (Record a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (NestedRecord a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (NT a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (NTRecord a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (Unit a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (MyUnit a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (Pair a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (Triple a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (Quad a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) + (QuadSimple a b c d) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a /\ b /\ c /\ d) + (Enum a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ (a) instance decodeJsonTestSum :: DecodeJson TestSum where decodeJson = D.decode @@ -152,6 +167,10 @@ instance decodeJsonTestSum :: DecodeJson TestSum where <|> D.tagged "Number" (Number <$> D.value) <|> D.tagged "String" (String <$> D.value) <|> D.tagged "Array" (Array <$> D.value) + <|> D.tagged "InlineRecord" (InlineRecord <$> D.record "InlineRecord" + { why: D.value :: _ String + , wouldYouDoThis: D.value :: _ Int + }) <|> D.tagged "Record" (Record <$> D.value) <|> D.tagged "NestedRecord" (NestedRecord <$> D.value) <|> D.tagged "NT" (NT <$> D.value) @@ -198,6 +217,11 @@ _Array = prism' Array case _ of (Array a) -> Just a _ -> Nothing +_InlineRecord :: Prism' TestSum {why :: String, wouldYouDoThis :: Int} +_InlineRecord = prism' InlineRecord case _ of + (InlineRecord a) -> Just a + _ -> Nothing + _Record :: Prism' TestSum (TestRecord Int) _Record = prism' Record case _ of (Record a) -> Just a @@ -272,15 +296,15 @@ derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where encodeJson = E.encode $ unwrap - >$< E.record - { _field1: (E.maybe E.value) :: Encoder (Maybe Int) - , _field2: E.value :: Encoder a - } + >$< (E.record + { _field1: (E.maybe E.value) :: _ (Maybe Int) + , _field2: E.value :: _ a + }) instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) where decodeJson = D.decode $ TestRecord <$> D.record "TestRecord" - { _field1: (D.maybe D.value) :: Decoder (Maybe Int) - , _field2: D.value :: Decoder a + { _field1: (D.maybe D.value) :: _ (Maybe Int) + , _field2: D.value :: _ a } derive instance genericTestRecord :: Generic (TestRecord a) _ @@ -340,10 +364,10 @@ derive instance ordTestNewtypeRecord :: Ord TestNewtypeRecord instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where encodeJson = E.encode $ unwrap - >$< E.record { unTestNewtypeRecord: E.value :: Encoder TestNewtype } + >$< (E.record { unTestNewtypeRecord: E.value :: _ TestNewtype }) instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where - decodeJson = D.decode $ TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: Decoder TestNewtype } + decodeJson = D.decode $ TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: _ TestNewtype } derive instance genericTestNewtypeRecord :: Generic TestNewtypeRecord _ From 55c951dc25468d40b6f7c28f878cc368e5493177 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Mon, 25 Oct 2021 11:03:18 -0400 Subject: [PATCH 043/111] Make sum type encoding better --- src/Language/PureScript/Bridge/Printer.hs | 67 +++---- test/RoundTrip/Spec.hs | 1 + test/RoundTrip/Types.hs | 12 ++ test/RoundTrip/app/src/RoundTrip/Types.purs | 197 +++++++++++++------- 4 files changed, 173 insertions(+), 104 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index d2d747e2..5110334d 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -48,13 +48,13 @@ import Text.PrettyPrint.Leijen.Text (Doc, rparen, textStrict, vsep, (<+>), hang, dquotes, char, backslash, nest, linebreak, lbrace, rbrace, softline) -import Data.List (unfoldr) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty((:|))) import Data.Char (isLower, toLower) import Language.PureScript.Bridge.PSTypes (psUnit) import Control.Arrow ((&&&)) -import Data.Function ((&)) +import Data.Function ((&), on) +import Data.List (nubBy) renderText :: Doc -> Text renderText = T.replace " \n" "\n" . displayTStrict . renderPretty 0.4 200 @@ -325,7 +325,7 @@ instances st@(SumType t _ is) = go <$> is ] go Json = vsep $ punctuate line [ mkInstance "EncodeJson" encodeJsonConstraints t - [ "encodeJson = E.encode" <+> nest 2 (sumTypeToEncode st) ] + [ "encodeJson =" <+> nest 2 (sumTypeToEncode st) ] , mkInstance "DecodeJson" decodeJsonConstraints t [ "decodeJson = D.decode" <+> nest 2 (sumTypeToDecode st) ] ] @@ -360,37 +360,27 @@ isEnum = all $ (== Nullary) . _sigValues sumTypeToEncode :: SumType 'PureScript -> Doc sumTypeToEncode (SumType _ cs _) - | isEnum cs = "E.enum" + | isEnum cs = "E.encode E.enum" | otherwise = - linebreak <> "$" <+> vsep case cs of + linebreak <> case cs of [dc@(DataConstructor _ args)] -> - [ if isJust (nootype [dc]) - then "unwrap" - else parens $ case_of [(constructorPattern dc, constructor args)] - , ">$<" <+> nest 2 (argsToEncode args) - ] + "E.encode $" + <+> vsep + [ if isJust (nootype [dc]) + then "unwrap" + else parens $ case_of [(constructorPattern dc, constructor args)] + , ">$<" <+> nest 2 (argsToEncode args) + ] _ -> - [ "E.sumType" - , "$ toEither" <+> encloseVsep ">$<" mempty ">|<" (constructorToTagged <$> cs) - , "where" - , "toEither =" <+> case_of (unfoldr toEither ("", cs)) - ] + "encodeJson <<< " <+> case_of (constructorToEncode <$> cs) where - toEither (_, []) = Nothing - toEither (prefix, dc@(DataConstructor _ args) : rest) = - Just - ( ( constructorPattern dc - , prefix <+> eitherCase rest <+> "$" <+> constructor args - ) - , (nextPrefix rest, rest) - ) - where - eitherCase [] = "Right" - eitherCase _ = "Left" - nextPrefix [_] = prefix - nextPrefix _ = prefix <+> "Right $" - constructorToTagged (DataConstructor name args) = - "E.tagged" <+> dquotes (textStrict name) <+> argsToEncode args + constructorToEncode c@(DataConstructor name args) = + ( constructorPattern c + , vrecord + [ "tag:" <+> dquotes (textStrict name) + , "contents:" <+> "flip E.encode" <+> constructor args <+> argsToEncode args + ] + ) argsToEncode Nullary = "E.null" argsToEncode (Normal (t :| [])) = typeToEncode t argsToEncode (Normal ts) = @@ -490,14 +480,14 @@ constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = (Nullary, False) -> iso pName typeInfo psUnit "(const unit)" $ parens ("const" <+> cName) (Nullary, True) -> prism pName typeInfo psUnit cName "unit" $ parens ("const" <+> cName) (Normal (t :| []), False) -> newtypeIso pName typeInfo t - (Normal (t :| []), True) -> prism pName typeInfo t (normalPattern n [t]) "a" cName + (Normal (t :| []), True) -> prism pName typeInfo t (parens $ normalPattern n [t]) "a" cName (Normal ts, _) | hasOtherConstructors -> prism pName typeInfo toType fromExpr toExpr toMorph | otherwise -> iso pName typeInfo toType fromMorph toMorph where fields' = fields $ typesToRecord ts toType = recordType $ typesToRecord ts - fromExpr = normalPattern n ts + fromExpr = parens $ normalPattern n ts toExpr = hrecord fields' fromMorph = parens $ lambda fromExpr toExpr toMorph = parens $ lambda toExpr fromExpr @@ -505,7 +495,7 @@ constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = (Record rs, True) -> prism pName typeInfo (recordType rs) fromExpr toExpr cName where - fromExpr = pattern n toExpr + fromExpr = parens $ pattern n toExpr toExpr = "a" where cName = textStrict n @@ -569,7 +559,7 @@ constructorPattern (DataConstructor name (Record rs)) = recordPattern name rs constructor :: DataConstructorArgs 'PureScript -> Doc constructor Nullary = nullaryExpr constructor (Normal ts) = normalExpr ts -constructor (Record rs) = vrecord $ fields rs +constructor (Record rs) = hrecord $ fields rs nullaryPattern :: Text -> Doc nullaryPattern = textStrict @@ -581,13 +571,14 @@ normalPattern :: Text -> NonEmpty PSType -> Doc normalPattern name = pattern name . hsep . normalLabels normalExpr :: NonEmpty PSType -> Doc -normalExpr = parens . hsep . punctuate " /\\" . normalLabels +normalExpr (_ :| []) = "a" +normalExpr ts = parens . hsep . punctuate " /\\" $ normalLabels ts normalLabels :: NonEmpty PSType -> [Doc] normalLabels = fmap char . zipWith const ['a'..] . NE.toList recordPattern :: Text -> NonEmpty (RecordEntry 'PureScript) -> Doc -recordPattern name = pattern name . vrecord . fields +recordPattern name = pattern name . hrecord . fields vrecord :: [Doc] -> Doc vrecord = encloseVsep lbrace rbrace comma @@ -608,7 +599,7 @@ fieldSignature :: RecordEntry 'PureScript -> Doc fieldSignature = uncurry signature' . (field &&& _recValue) pattern :: Text -> Doc -> Doc -pattern name = parens . (textStrict name <+>) +pattern name = (textStrict name <+>) case_of :: [(Doc, Doc)] -> Doc case_of = caseOf "_" @@ -635,7 +626,7 @@ signature topLevel name constraints params ret = forAll = case (topLevel, allTypes >>= typeParams) of (False, _) -> Nothing (_, []) -> Nothing - (_, ps) -> Just $ "forall" <+> hsep (typeInfoToDoc <$> ps) <> "." + (_, ps) -> Just $ "forall" <+> hsep (typeInfoToDoc <$> nubBy (on (==) _typeName) ps) <> "." allTypes = ret : constraints <> params constraintsDoc = case constraints of [] -> Nothing diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index e53171a0..223a0d58 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -38,6 +38,7 @@ myTypes = functor . equal . genericShow . order . argonaut $ mkSumType @(TestRecord A), equal . genericShow . order . argonaut $ mkSumType @TestNewtype, equal . genericShow . order . argonaut $ mkSumType @TestNewtypeRecord, + equal . genericShow . order . argonaut $ mkSumType @TestTwoFields, equal . genericShow . order . argonaut $ mkSumType @TestEnum, equal . genericShow . order . argonaut $ mkSumType @MyUnit ] diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index f5cd4268..e500d3da 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -47,6 +47,7 @@ data TestSum | NestedRecord (TestRecord (TestRecord Int)) | NT TestNewtype | NTRecord TestNewtypeRecord + | TwoFields TestTwoFields | Unit () | MyUnit MyUnit | Pair (Int, Double) @@ -74,6 +75,7 @@ instance Arbitrary TestSum where NestedRecord <$> arbitrary, NT <$> arbitrary, NTRecord <$> arbitrary, + TwoFields <$> arbitrary, pure $ Unit (), Pair <$> arbitrary, Triple <$> arbitrary, @@ -95,6 +97,16 @@ instance (ToJSON a) => ToJSON (TestRecord a) instance (Arbitrary a) => Arbitrary (TestRecord a) where arbitrary = TestRecord <$> arbitrary <*> arbitrary +data TestTwoFields = TestTwoFields Bool Int + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TestTwoFields + +instance ToJSON TestTwoFields + +instance Arbitrary TestTwoFields where + arbitrary = TestTwoFields <$> arbitrary <*> arbitrary + newtype TestNewtype = TestNewtype (TestRecord Bool) deriving (Show, Eq, Ord, Generic) diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 8703270d..1443b1e0 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -42,15 +42,16 @@ instance showTestData :: Show TestData where derive instance ordTestData :: Ord TestData instance encodeJsonTestData :: EncodeJson TestData where - encodeJson = E.encode - $ E.sumType - $ toEither - >$< E.tagged "Maybe" (E.maybe E.value) - >|< E.tagged "Either" (E.either (E.maybe E.value) (E.maybe E.value)) - where - toEither = case _ of - (Maybe a) -> Left $ (a) - (Either a) -> Right $ (a) + encodeJson = + encodeJson <<< case _ of + Maybe a -> + { tag: "Maybe" + , contents: flip E.encode a (E.maybe E.value) + } + Either a -> + { tag: "Either" + , contents: flip E.encode a (E.either (E.maybe E.value) (E.maybe E.value)) + } instance decodeJsonTestData :: DecodeJson TestData where decodeJson = D.decode @@ -90,6 +91,7 @@ data TestSum | NestedRecord (TestRecord (TestRecord Int)) | NT TestNewtype | NTRecord TestNewtypeRecord + | TwoFields TestTwoFields | Unit Unit | MyUnit MyUnit | Pair (Tuple Int Number) @@ -106,56 +108,87 @@ instance showTestSum :: Show TestSum where derive instance ordTestSum :: Ord TestSum instance encodeJsonTestSum :: EncodeJson TestSum where - encodeJson = E.encode - $ E.sumType - $ toEither - >$< E.tagged "Nullary" E.null - >|< E.tagged "Bool" E.value - >|< E.tagged "Int" E.value - >|< E.tagged "Number" E.value - >|< E.tagged "String" E.value - >|< E.tagged "Array" E.value - >|< E.tagged "InlineRecord" (E.record - { why: E.value :: _ String - , wouldYouDoThis: E.value :: _ Int - }) - >|< E.tagged "Record" E.value - >|< E.tagged "NestedRecord" E.value - >|< E.tagged "NT" E.value - >|< E.tagged "NTRecord" E.value - >|< E.tagged "Unit" E.unit - >|< E.tagged "MyUnit" E.value - >|< E.tagged "Pair" (E.tuple (E.value >/\< E.value)) - >|< E.tagged "Triple" (E.tuple (E.value >/\< E.unit >/\< E.value)) - >|< E.tagged "Quad" (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) - >|< E.tagged "QuadSimple" (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) - >|< E.tagged "Enum" E.value - where - toEither = case _ of - Nullary -> Left $ unit - (Bool a) -> Right $ Left $ (a) - (Int a) -> Right $ Right $ Left $ (a) - (Number a) -> Right $ Right $ Right $ Left $ (a) - (String a) -> Right $ Right $ Right $ Right $ Left $ (a) - (Array a) -> Right $ Right $ Right $ Right $ Right $ Left $ (a) - (InlineRecord - { why - , wouldYouDoThis - }) -> Right $ Right $ Right $ Right $ Right $ Right $ Left $ - { why - , wouldYouDoThis + encodeJson = + encodeJson <<< case _ of + Nullary -> + { tag: "Nullary" + , contents: flip E.encode unit E.null + } + Bool a -> + { tag: "Bool" + , contents: flip E.encode a E.value + } + Int a -> + { tag: "Int" + , contents: flip E.encode a E.value + } + Number a -> + { tag: "Number" + , contents: flip E.encode a E.value + } + String a -> + { tag: "String" + , contents: flip E.encode a E.value + } + Array a -> + { tag: "Array" + , contents: flip E.encode a E.value + } + InlineRecord {why, wouldYouDoThis} -> + { tag: "InlineRecord" + , contents: flip E.encode {why, wouldYouDoThis} (E.record + { why: E.value :: _ String + , wouldYouDoThis: E.value :: _ Int + }) + } + Record a -> + { tag: "Record" + , contents: flip E.encode a E.value + } + NestedRecord a -> + { tag: "NestedRecord" + , contents: flip E.encode a E.value + } + NT a -> + { tag: "NT" + , contents: flip E.encode a E.value + } + NTRecord a -> + { tag: "NTRecord" + , contents: flip E.encode a E.value + } + TwoFields a -> + { tag: "TwoFields" + , contents: flip E.encode a E.value + } + Unit a -> + { tag: "Unit" + , contents: flip E.encode a E.unit + } + MyUnit a -> + { tag: "MyUnit" + , contents: flip E.encode a E.value + } + Pair a -> + { tag: "Pair" + , contents: flip E.encode a (E.tuple (E.value >/\< E.value)) + } + Triple a -> + { tag: "Triple" + , contents: flip E.encode a (E.tuple (E.value >/\< E.unit >/\< E.value)) + } + Quad a -> + { tag: "Quad" + , contents: flip E.encode a (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + } + QuadSimple a b c d -> + { tag: "QuadSimple" + , contents: flip E.encode (a /\ b /\ c /\ d) (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + } + Enum a -> + { tag: "Enum" + , contents: flip E.encode a E.value } - (Record a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (NestedRecord a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (NT a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (NTRecord a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (Unit a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (MyUnit a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (Pair a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (Triple a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (Quad a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a) - (QuadSimple a b c d) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Left $ (a /\ b /\ c /\ d) - (Enum a) -> Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ Right $ (a) instance decodeJsonTestSum :: DecodeJson TestSum where decodeJson = D.decode @@ -175,6 +208,7 @@ instance decodeJsonTestSum :: DecodeJson TestSum where <|> D.tagged "NestedRecord" (NestedRecord <$> D.value) <|> D.tagged "NT" (NT <$> D.value) <|> D.tagged "NTRecord" (NTRecord <$> D.value) + <|> D.tagged "TwoFields" (TwoFields <$> D.value) <|> D.tagged "Unit" (Unit <$> D.unit) <|> D.tagged "MyUnit" (MyUnit <$> D.value) <|> D.tagged "Pair" (Pair <$> (D.tuple (D.value D.value))) @@ -242,6 +276,11 @@ _NTRecord = prism' NTRecord case _ of (NTRecord a) -> Just a _ -> Nothing +_TwoFields :: Prism' TestSum TestTwoFields +_TwoFields = prism' TwoFields case _ of + (TwoFields a) -> Just a + _ -> Nothing + _Unit :: Prism' TestSum Unit _Unit = prism' Unit case _ of (Unit a) -> Just a @@ -294,8 +333,8 @@ instance showTestRecord :: (Show a) => Show (TestRecord a) where derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where - encodeJson = E.encode - $ unwrap + encodeJson = + E.encode $ unwrap >$< (E.record { _field1: (E.maybe E.value) :: _ (Maybe Int) , _field2: E.value :: _ a @@ -319,7 +358,7 @@ _TestRecord = _Newtype field1 :: forall a. Lens' (TestRecord a) (Maybe Int) field1 = _Newtype <<< prop (Proxy :: _"_field1") -field2 :: forall a a. Lens' (TestRecord a) a +field2 :: forall a. Lens' (TestRecord a) a field2 = _Newtype <<< prop (Proxy :: _"_field2") -------------------------------------------------------------------------------- @@ -334,8 +373,8 @@ instance showTestNewtype :: Show TestNewtype where derive instance ordTestNewtype :: Ord TestNewtype instance encodeJsonTestNewtype :: EncodeJson TestNewtype where - encodeJson = E.encode - $ unwrap + encodeJson = + E.encode $ unwrap >$< E.value instance decodeJsonTestNewtype :: DecodeJson TestNewtype where @@ -362,8 +401,8 @@ instance showTestNewtypeRecord :: Show TestNewtypeRecord where derive instance ordTestNewtypeRecord :: Ord TestNewtypeRecord instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where - encodeJson = E.encode - $ unwrap + encodeJson = + E.encode $ unwrap >$< (E.record { unTestNewtypeRecord: E.value :: _ TestNewtype }) instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where @@ -380,6 +419,32 @@ _TestNewtypeRecord = _Newtype -------------------------------------------------------------------------------- +data TestTwoFields = TestTwoFields Boolean Int + +derive instance eqTestTwoFields :: Eq TestTwoFields + +instance showTestTwoFields :: Show TestTwoFields where + show = genericShow + +derive instance ordTestTwoFields :: Ord TestTwoFields + +instance encodeJsonTestTwoFields :: EncodeJson TestTwoFields where + encodeJson = + E.encode $ (case _ of TestTwoFields a b -> (a /\ b)) + >$< (E.tuple (E.value >/\< E.value)) + +instance decodeJsonTestTwoFields :: DecodeJson TestTwoFields where + decodeJson = D.decode $ D.tuple $ TestTwoFields D.value D.value + +derive instance genericTestTwoFields :: Generic TestTwoFields _ + +-------------------------------------------------------------------------------- + +_TestTwoFields :: Iso' TestTwoFields {a :: Boolean, b :: Int} +_TestTwoFields = iso (\(TestTwoFields a b) -> {a, b}) (\{a, b} -> (TestTwoFields a b)) + +-------------------------------------------------------------------------------- + data TestEnum = Mon | Tue @@ -479,4 +544,4 @@ instance boundedMyUnit :: Bounded MyUnit where -------------------------------------------------------------------------------- _U :: Iso' MyUnit Unit -_U = iso (const unit) (const U) \ No newline at end of file +_U = iso (const unit) (const U) From 2953fb1b4c9bceb4161dc37bb4f15774792d0f06 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Mon, 25 Oct 2021 11:55:32 -0400 Subject: [PATCH 044/111] Update sum type encode/decode --- src/Language/PureScript/Bridge/Printer.hs | 34 ++-- test/RoundTrip/app/packages.dhall | 2 +- test/RoundTrip/app/spago.dhall | 1 + test/RoundTrip/app/src/RoundTrip/Types.purs | 185 +++++++------------- 4 files changed, 82 insertions(+), 140 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 5110334d..7af0b8ad 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -47,7 +47,7 @@ import Text.PrettyPrint.Leijen.Text (Doc, renderPretty, rparen, textStrict, vsep, - (<+>), hang, dquotes, char, backslash, nest, linebreak, lbrace, rbrace, softline) + (<+>), hang, dquotes, char, backslash, nest, linebreak, lbrace, rbrace, softline, lbracket, rbracket) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty((:|))) import Data.Char (isLower, toLower) @@ -154,7 +154,7 @@ instanceToImportLines Json = , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["Decoder", "()", "()", "()"] , ImportLine "Data.Argonaut.Decode.Decoders" $ Set.fromList ["decodeJArray", "decodeJObject", "decodeArray", "decodeNull"] , ImportLine "Data.Argonaut.Encode" $ Set.fromList ["(:=)", "(~>)", "encodeJson"] - , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["Encoder", "(>$<)", "(>*<)", "(>/\\<)", "(>|<)"] + , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["Encoder", "(>$<)", "(>*<)", "(>/\\<)"] , ImportLine "Data.Either" $ Set.singleton "Either(..)" , ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)", "maybe"] , ImportLine "Data.Newtype" $ Set.singleton "unwrap" @@ -175,6 +175,7 @@ instanceToQualifiedImports Json = Map.fromList [ ("Data.Argonaut.Decode.Aeson", "D") , ("Data.Argonaut.Encode.Aeson", "E") + , ("Data.Map", "Map") ] instanceToQualifiedImports _ = Map.empty @@ -371,15 +372,11 @@ sumTypeToEncode (SumType _ cs _) else parens $ case_of [(constructorPattern dc, constructor args)] , ">$<" <+> nest 2 (argsToEncode args) ] - _ -> - "encodeJson <<< " <+> case_of (constructorToEncode <$> cs) + _ -> case_of (constructorToEncode <$> cs) where constructorToEncode c@(DataConstructor name args) = ( constructorPattern c - , vrecord - [ "tag:" <+> dquotes (textStrict name) - , "contents:" <+> "flip E.encode" <+> constructor args <+> argsToEncode args - ] + , "E.encodeTagged" <+> dquotes (textStrict name) <+> constructor args <+> argsToEncode args ) argsToEncode Nullary = "E.null" argsToEncode (Normal (t :| [])) = typeToEncode t @@ -417,27 +414,30 @@ sumTypeToDecode (SumType _ [c] _) = "$" <+> constructorToDecode c sumTypeToDecode (SumType t cs _) = line <> vsep [ "$ D.sumType" <+> t ^. typeName . to textStrict . to dquotes - , "$" <+> encloseVsep mempty mempty "<|>" (constructorToTagged <$> cs) + , hang 2 + $ "$ Map.fromFoldable" + <+> encloseVsep lbracket rbracket comma (constructorToTagged <$> cs) ] where - constructorToTagged dc = - "D.tagged" - <+> dc ^. sigConstructor . to textStrict . to dquotes - <+> dc ^. to constructorToDecode . to parens + constructorToTagged dc = hsep + [ dc ^. sigConstructor . to textStrict . to dquotes + , "/\\" + , constructorToDecode dc + ] constructorToDecode :: DataConstructor 'PureScript -> Doc constructorToDecode (DataConstructor name Nullary) = - textStrict name <+> "<$" <+> "D.null" + parens $ textStrict name <+> "<$" <+> "D.null" constructorToDecode (DataConstructor name (Normal (a :| []))) = - textStrict name <+> "<$>" <+> typeToDecode a + parens $ textStrict name <+> "<$>" <+> typeToDecode a constructorToDecode (DataConstructor name (Normal as)) = - "D.tuple" + parens $ "D.tuple" <+> "$" <+> textStrict name <+> encloseHsep "" mempty " " (typeToDecode <$> NE.toList as) constructorToDecode (DataConstructor name (Record rs)) = - textStrict name + parens $ textStrict name <+> "<$> D.record" <+> dquotes (textStrict name) <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall index 1d31d537..39671eaa 100644 --- a/test/RoundTrip/app/packages.dhall +++ b/test/RoundTrip/app/packages.dhall @@ -25,6 +25,6 @@ in upstream // { , "typelevel-prelude" ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "68265aaacc1a56c00a7625d424ff13d619681e5e" + , version = "16de087fde6e2d07e6bdae51383131ab81efa82d" } } diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index 2f5e5091..7db005cd 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -14,6 +14,7 @@ , "newtype" , "node-process" , "node-readline" + , "ordered-collections" , "prelude" , "profunctor-lenses" , "psci-support" diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 1443b1e0..09308d69 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -9,7 +9,7 @@ import Data.Argonaut.Decode ((.!=), (.:), (.:?), JsonDecodeError(..), class Deco import Data.Argonaut.Decode.Aeson ((), (), (), Decoder) import Data.Argonaut.Decode.Decoders (decodeArray, decodeJArray, decodeJObject, decodeNull) import Data.Argonaut.Encode ((:=), (~>), class EncodeJson, encodeJson) -import Data.Argonaut.Encode.Aeson ((>$<), (>*<), (>/\<), (>|<), Encoder) +import Data.Argonaut.Encode.Aeson ((>$<), (>*<), (>/\<), Encoder) import Data.Array (index) import Data.Bifunctor (lmap) import Data.Bounded.Generic (genericBottom, genericTop) @@ -29,6 +29,7 @@ import Data.Tuple.Nested ((/\)) import Type.Proxy (Proxy(Proxy)) import Data.Argonaut.Decode.Aeson as D import Data.Argonaut.Encode.Aeson as E +import Data.Map as Map data TestData = Maybe (Maybe TestSum) @@ -43,22 +44,17 @@ derive instance ordTestData :: Ord TestData instance encodeJsonTestData :: EncodeJson TestData where encodeJson = - encodeJson <<< case _ of - Maybe a -> - { tag: "Maybe" - , contents: flip E.encode a (E.maybe E.value) - } - Either a -> - { tag: "Either" - , contents: flip E.encode a (E.either (E.maybe E.value) (E.maybe E.value)) - } + case _ of + Maybe a -> E.encodeTagged "Maybe" a (E.maybe E.value) + Either a -> E.encodeTagged "Either" a (E.either (E.maybe E.value) (E.maybe E.value)) instance decodeJsonTestData :: DecodeJson TestData where decodeJson = D.decode $ D.sumType "TestData" - $ - D.tagged "Maybe" (Maybe <$> (D.maybe D.value)) - <|> D.tagged "Either" (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) + $ Map.fromFoldable + [ "Maybe" /\ (Maybe <$> (D.maybe D.value)) + , "Either" /\ (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) + ] derive instance genericTestData :: Generic TestData _ @@ -109,113 +105,58 @@ derive instance ordTestSum :: Ord TestSum instance encodeJsonTestSum :: EncodeJson TestSum where encodeJson = - encodeJson <<< case _ of - Nullary -> - { tag: "Nullary" - , contents: flip E.encode unit E.null - } - Bool a -> - { tag: "Bool" - , contents: flip E.encode a E.value - } - Int a -> - { tag: "Int" - , contents: flip E.encode a E.value - } - Number a -> - { tag: "Number" - , contents: flip E.encode a E.value - } - String a -> - { tag: "String" - , contents: flip E.encode a E.value - } - Array a -> - { tag: "Array" - , contents: flip E.encode a E.value - } - InlineRecord {why, wouldYouDoThis} -> - { tag: "InlineRecord" - , contents: flip E.encode {why, wouldYouDoThis} (E.record - { why: E.value :: _ String - , wouldYouDoThis: E.value :: _ Int - }) - } - Record a -> - { tag: "Record" - , contents: flip E.encode a E.value - } - NestedRecord a -> - { tag: "NestedRecord" - , contents: flip E.encode a E.value - } - NT a -> - { tag: "NT" - , contents: flip E.encode a E.value - } - NTRecord a -> - { tag: "NTRecord" - , contents: flip E.encode a E.value - } - TwoFields a -> - { tag: "TwoFields" - , contents: flip E.encode a E.value - } - Unit a -> - { tag: "Unit" - , contents: flip E.encode a E.unit - } - MyUnit a -> - { tag: "MyUnit" - , contents: flip E.encode a E.value - } - Pair a -> - { tag: "Pair" - , contents: flip E.encode a (E.tuple (E.value >/\< E.value)) - } - Triple a -> - { tag: "Triple" - , contents: flip E.encode a (E.tuple (E.value >/\< E.unit >/\< E.value)) - } - Quad a -> - { tag: "Quad" - , contents: flip E.encode a (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) - } - QuadSimple a b c d -> - { tag: "QuadSimple" - , contents: flip E.encode (a /\ b /\ c /\ d) (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) - } - Enum a -> - { tag: "Enum" - , contents: flip E.encode a E.value - } + case _ of + Nullary -> E.encodeTagged "Nullary" unit E.null + Bool a -> E.encodeTagged "Bool" a E.value + Int a -> E.encodeTagged "Int" a E.value + Number a -> E.encodeTagged "Number" a E.value + String a -> E.encodeTagged "String" a E.value + Array a -> E.encodeTagged "Array" a E.value + InlineRecord {why, wouldYouDoThis} -> E.encodeTagged "InlineRecord" {why, wouldYouDoThis} (E.record + + { why: E.value :: _ String + , wouldYouDoThis: E.value :: _ Int + }) + Record a -> E.encodeTagged "Record" a E.value + NestedRecord a -> E.encodeTagged "NestedRecord" a E.value + NT a -> E.encodeTagged "NT" a E.value + NTRecord a -> E.encodeTagged "NTRecord" a E.value + TwoFields a -> E.encodeTagged "TwoFields" a E.value + Unit a -> E.encodeTagged "Unit" a E.unit + MyUnit a -> E.encodeTagged "MyUnit" a E.value + Pair a -> E.encodeTagged "Pair" a (E.tuple (E.value >/\< E.value)) + Triple a -> E.encodeTagged "Triple" a (E.tuple (E.value >/\< E.unit >/\< E.value)) + Quad a -> E.encodeTagged "Quad" a (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + QuadSimple a b c d -> E.encodeTagged "QuadSimple" (a /\ b /\ c /\ d) (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + Enum a -> E.encodeTagged "Enum" a E.value instance decodeJsonTestSum :: DecodeJson TestSum where decodeJson = D.decode $ D.sumType "TestSum" - $ - D.tagged "Nullary" (Nullary <$ D.null) - <|> D.tagged "Bool" (Bool <$> D.value) - <|> D.tagged "Int" (Int <$> D.value) - <|> D.tagged "Number" (Number <$> D.value) - <|> D.tagged "String" (String <$> D.value) - <|> D.tagged "Array" (Array <$> D.value) - <|> D.tagged "InlineRecord" (InlineRecord <$> D.record "InlineRecord" - { why: D.value :: _ String - , wouldYouDoThis: D.value :: _ Int - }) - <|> D.tagged "Record" (Record <$> D.value) - <|> D.tagged "NestedRecord" (NestedRecord <$> D.value) - <|> D.tagged "NT" (NT <$> D.value) - <|> D.tagged "NTRecord" (NTRecord <$> D.value) - <|> D.tagged "TwoFields" (TwoFields <$> D.value) - <|> D.tagged "Unit" (Unit <$> D.unit) - <|> D.tagged "MyUnit" (MyUnit <$> D.value) - <|> D.tagged "Pair" (Pair <$> (D.tuple (D.value D.value))) - <|> D.tagged "Triple" (Triple <$> (D.tuple (D.value D.unit D.value))) - <|> D.tagged "Quad" (Quad <$> (D.tuple (D.value D.value D.value D.value))) - <|> D.tagged "QuadSimple" (D.tuple $ QuadSimple D.value D.value D.value D.value) - <|> D.tagged "Enum" (Enum <$> D.value) + $ Map.fromFoldable + [ "Nullary" /\ (Nullary <$ D.null) + , "Bool" /\ (Bool <$> D.value) + , "Int" /\ (Int <$> D.value) + , "Number" /\ (Number <$> D.value) + , "String" /\ (String <$> D.value) + , "Array" /\ (Array <$> D.value) + , "InlineRecord" /\ (InlineRecord <$> D.record "InlineRecord" + { why: D.value :: _ String + , wouldYouDoThis: D.value :: _ Int + }) + , "Record" /\ (Record <$> D.value) + , "NestedRecord" /\ (NestedRecord <$> D.value) + , "NT" /\ (NT <$> D.value) + , "NTRecord" /\ (NTRecord <$> D.value) + , "TwoFields" /\ (TwoFields <$> D.value) + , "Unit" /\ (Unit <$> D.unit) + , "MyUnit" /\ (MyUnit <$> D.value) + , "Pair" /\ (Pair <$> (D.tuple (D.value D.value))) + , "Triple" /\ (Triple <$> (D.tuple (D.value D.unit D.value))) + , "Quad" /\ (Quad <$> (D.tuple (D.value D.value D.value D.value))) + , "QuadSimple" /\ (D.tuple $ QuadSimple D.value D.value D.value D.value) + , "Enum" /\ (Enum <$> D.value) + ] derive instance genericTestSum :: Generic TestSum _ @@ -341,10 +282,10 @@ instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) whe }) instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) where - decodeJson = D.decode $ TestRecord <$> D.record "TestRecord" + decodeJson = D.decode $ (TestRecord <$> D.record "TestRecord" { _field1: (D.maybe D.value) :: _ (Maybe Int) , _field2: D.value :: _ a - } + }) derive instance genericTestRecord :: Generic (TestRecord a) _ @@ -378,7 +319,7 @@ instance encodeJsonTestNewtype :: EncodeJson TestNewtype where >$< E.value instance decodeJsonTestNewtype :: DecodeJson TestNewtype where - decodeJson = D.decode $ TestNewtype <$> D.value + decodeJson = D.decode $ (TestNewtype <$> D.value) derive instance genericTestNewtype :: Generic TestNewtype _ @@ -406,7 +347,7 @@ instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where >$< (E.record { unTestNewtypeRecord: E.value :: _ TestNewtype }) instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where - decodeJson = D.decode $ TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: _ TestNewtype } + decodeJson = D.decode $ (TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: _ TestNewtype }) derive instance genericTestNewtypeRecord :: Generic TestNewtypeRecord _ @@ -434,7 +375,7 @@ instance encodeJsonTestTwoFields :: EncodeJson TestTwoFields where >$< (E.tuple (E.value >/\< E.value)) instance decodeJsonTestTwoFields :: DecodeJson TestTwoFields where - decodeJson = D.decode $ D.tuple $ TestTwoFields D.value D.value + decodeJson = D.decode $ (D.tuple $ TestTwoFields D.value D.value) derive instance genericTestTwoFields :: Generic TestTwoFields _ @@ -544,4 +485,4 @@ instance boundedMyUnit :: Bounded MyUnit where -------------------------------------------------------------------------------- _U :: Iso' MyUnit Unit -_U = iso (const unit) (const U) +_U = iso (const unit) (const U) \ No newline at end of file From 2f91764a321319fcb3df058911ff56b16d8d2b5a Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Mon, 25 Oct 2021 13:26:41 -0400 Subject: [PATCH 045/111] Add recursive types to test --- src/Language/PureScript/Bridge/Printer.hs | 63 ++--- src/Language/PureScript/Bridge/SumType.hs | 2 +- test/RoundTrip/Spec.hs | 2 + test/RoundTrip/Types.hs | 25 +- test/RoundTrip/app/packages.dhall | 7 +- test/RoundTrip/app/spago.dhall | 2 - test/RoundTrip/app/src/RoundTrip/Types.purs | 267 ++++++++++++-------- test/Spec.hs | 6 +- 8 files changed, 230 insertions(+), 144 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 7af0b8ad..fbb04f08 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -10,7 +10,7 @@ import Control.Lens (to,(^.), (%~), (<>~ import Control.Monad (unless) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, catMaybes) +import Data.Maybe (isJust, catMaybes, fromMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -54,7 +54,7 @@ import Data.Char (isLower, toLower) import Language.PureScript.Bridge.PSTypes (psUnit) import Control.Arrow ((&&&)) import Data.Function ((&), on) -import Data.List (nubBy) +import Data.List (nubBy, sortBy, groupBy) renderText :: Doc -> Text renderText = T.replace " \n" "\n" . displayTStrict . renderPretty 0.4 200 @@ -146,17 +146,9 @@ instanceToImportLines GenericShow = importsFromList [ ImportLine "Data.Show.Generic" $ Set.singleton "genericShow" ] instanceToImportLines Json = importsFromList - [ ImportLine "Control.Alt" $ Set.singleton "(<|>)" - , ImportLine "Data.Array" $ Set.singleton "index" - , ImportLine "Data.Bifunctor" $ Set.singleton "lmap" - , ImportLine "Data.Argonaut.Core" $ Set.fromList ["jsonEmptyArray", "jsonEmptyObject", "jsonNull", "fromArray", "fromString"] - , ImportLine "Data.Argonaut.Decode" $ Set.fromList ["JsonDecodeError(..)", "(.:)", "(.:?)", "(.!=)", "decodeJson"] - , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["Decoder", "()", "()", "()"] - , ImportLine "Data.Argonaut.Decode.Decoders" $ Set.fromList ["decodeJArray", "decodeJObject", "decodeArray", "decodeNull"] - , ImportLine "Data.Argonaut.Encode" $ Set.fromList ["(:=)", "(~>)", "encodeJson"] - , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["Encoder", "(>$<)", "(>*<)", "(>/\\<)"] - , ImportLine "Data.Either" $ Set.singleton "Either(..)" - , ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)", "maybe"] + [ ImportLine "Control.Lazy" $ Set.singleton "defer" + , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["()", "()", "()"] + , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["(>$<)", "(>/\\<)"] , ImportLine "Data.Newtype" $ Set.singleton "unwrap" , ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" ] @@ -238,7 +230,7 @@ lensImports settings | Switches.generateLenses settings = [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] , ImportLine "Data.Lens" $ - Set.fromList ["Iso'", "Prism'", "Lens'", "prism'", "lens", "iso"] + Set.fromList ["Iso'", "Prism'", "Lens'", "iso", "prism'"] , ImportLine "Data.Lens.Record" $ Set.fromList ["prop"] , ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"] , ImportLine "Type.Proxy" $ Set.fromList ["Proxy(Proxy)"] @@ -253,7 +245,16 @@ importLineToText :: ImportLine -> Doc importLineToText l = hsep ["import", textStrict $ importModule l, encloseHsep lparen rparen comma typeList] where - typeList = textStrict <$> Set.toList (importTypes l) + typeList = + map (textStrict . last) + . groupBy ((==) `on` importedType) + . sortBy importOrder + . Set.toList + $ importTypes l + importOrder imp1 imp2 + | T.isPrefixOf "class" imp1 = if T.isPrefixOf "class" imp2 then compare imp1 imp2 else LT + | otherwise = compare imp1 imp2 + importedType imp = fromMaybe imp $ T.stripSuffix "(..)" imp sumTypeToDocs :: Switches.Settings -> SumType 'PureScript -> [Doc] sumTypeToDocs settings st @@ -326,11 +327,11 @@ instances st@(SumType t _ is) = go <$> is ] go Json = vsep $ punctuate line [ mkInstance "EncodeJson" encodeJsonConstraints t - [ "encodeJson =" <+> nest 2 (sumTypeToEncode st) ] + [ "encodeJson = defer \\_ ->" <+> sumTypeToEncode st ] , mkInstance "DecodeJson" decodeJsonConstraints t - [ "decodeJson = D.decode" <+> nest 2 (sumTypeToDecode st) ] + [ hang 2 $ "decodeJson = defer \\_ -> D.decode" <+> sumTypeToDecode st ] ] - go GenericShow = mkInstance "Show" showConstraints t [ "show = genericShow" ] + go GenericShow = mkInstance "Show" showConstraints t [ "show a = genericShow a" ] go Functor = mkDerivedInstance "Functor" (const []) [] $ toKind1 t go Eq = mkDerivedInstance "Eq" eqConstraints [] t go Eq1 = mkDerivedInstance "Eq1" (const []) [] $ toKind1 t @@ -363,15 +364,15 @@ sumTypeToEncode :: SumType 'PureScript -> Doc sumTypeToEncode (SumType _ cs _) | isEnum cs = "E.encode E.enum" | otherwise = - linebreak <> case cs of + case cs of [dc@(DataConstructor _ args)] -> - "E.encode $" - <+> vsep - [ if isJust (nootype [dc]) - then "unwrap" - else parens $ case_of [(constructorPattern dc, constructor args)] - , ">$<" <+> nest 2 (argsToEncode args) - ] + hsep + ["E.encode $" + , if isJust (nootype [dc]) + then "unwrap" + else parens $ case_of [(constructorPattern dc, constructor args)] + , hang 2 $ ">$<" <+> nest 2 (argsToEncode args) + ] _ -> case_of (constructorToEncode <$> cs) where constructorToEncode c@(DataConstructor name args) = @@ -412,11 +413,11 @@ sumTypeToDecode (SumType _ cs _) | isEnum cs = "D.enum" sumTypeToDecode (SumType _ [c] _) = "$" <+> constructorToDecode c sumTypeToDecode (SumType t cs _) = line <> - vsep - [ "$ D.sumType" <+> t ^. typeName . to textStrict . to dquotes - , hang 2 - $ "$ Map.fromFoldable" - <+> encloseVsep lbracket rbracket comma (constructorToTagged <$> cs) + hsep + [ "$ D.sumType" + , t ^. typeName . to textStrict . to dquotes + , "$ Map.fromFoldable" + , encloseVsep lbracket rbracket comma (constructorToTagged <$> cs) ] where constructorToTagged dc = hsep diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 4f9a3dbc..89d40679 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -229,7 +229,7 @@ instanceToTypes Json = instanceToTypes Newtype = Set.singleton $ TypeInfo "purescript-newtype" "Data.Newtype" "class Newtype" [] instanceToTypes Functor = - Set.singleton $ TypeInfo "purescript-functor" "Data.Functor" "class Functor" [] + Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Functor" [] instanceToTypes Eq = Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Eq" [] instanceToTypes Eq1 = diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 223a0d58..125c9238 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -35,6 +35,8 @@ myTypes :: [SumType 'Haskell] myTypes = [ equal . genericShow . order . argonaut $ mkSumType @TestData, equal . genericShow . order . argonaut $ mkSumType @TestSum, + equal . genericShow . order . argonaut $ mkSumType @TestRecursiveA, + equal . genericShow . order . argonaut $ mkSumType @TestRecursiveB, functor . equal . genericShow . order . argonaut $ mkSumType @(TestRecord A), equal . genericShow . order . argonaut $ mkSumType @TestNewtype, equal . genericShow . order . argonaut $ mkSumType @TestNewtypeRecord, diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index e500d3da..ea540537 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module RoundTrip.Types where @@ -17,7 +18,7 @@ import System.Process (readProcessWithExitCode) import Test.HUnit (assertEqual) import Test.Hspec (Spec, aroundAll_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) -import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof) +import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, sized) data TestData = Maybe (Maybe TestSum) @@ -54,6 +55,7 @@ data TestSum | Triple (Int, (), Bool) | Quad (Int, Double, Bool, Double) | QuadSimple Int Double Bool Double + | Recursive TestRecursiveA | Enum TestEnum deriving (Show, Eq, Ord, Generic) @@ -84,6 +86,27 @@ instance Arbitrary TestSum where Enum <$> arbitrary ] +data TestRecursiveA = Nil | Recurse TestRecursiveB + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TestRecursiveA + +instance ToJSON TestRecursiveA + +instance Arbitrary TestRecursiveA where + arbitrary = sized go + where + go size + | size > 0 = oneof [pure Nil, resize (size - 1) $ Recurse <$> arbitrary] + | otherwise = pure Nil + +newtype TestRecursiveB = RecurseB TestRecursiveB + deriving (Show, Eq, Ord, Generic, Arbitrary) + +instance FromJSON TestRecursiveB + +instance ToJSON TestRecursiveB + data TestRecord a = TestRecord { _field1 :: Maybe Int, _field2 :: a diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall index 39671eaa..95c78583 100644 --- a/test/RoundTrip/app/packages.dhall +++ b/test/RoundTrip/app/packages.dhall @@ -4,12 +4,14 @@ let upstream = in upstream // { json-helpers = { dependencies = - [ "argonaut-codecs" + [ "aff" + , "argonaut-codecs" , "argonaut-core" , "arrays" , "bifunctors" , "contravariant" , "control" + , "effect" , "either" , "enums" , "foreign-object" @@ -19,7 +21,10 @@ in upstream // { , "prelude" , "profunctor" , "psci-support" + , "quickcheck" , "record" + , "spec" + , "spec-quickcheck" , "transformers" , "tuples" , "typelevel-prelude" diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index 7db005cd..6948b426 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -2,8 +2,6 @@ , dependencies = [ "argonaut-codecs" , "argonaut-core" - , "arrays" - , "bifunctors" , "console" , "control" , "effect" diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 09308d69..97f62350 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -3,25 +3,20 @@ module RoundTrip.Types where import Prelude -import Control.Alt ((<|>)) -import Data.Argonaut.Core (fromArray, fromString, jsonEmptyArray, jsonEmptyObject, jsonNull) -import Data.Argonaut.Decode ((.!=), (.:), (.:?), JsonDecodeError(..), class DecodeJson, decodeJson) -import Data.Argonaut.Decode.Aeson ((), (), (), Decoder) -import Data.Argonaut.Decode.Decoders (decodeArray, decodeJArray, decodeJObject, decodeNull) -import Data.Argonaut.Encode ((:=), (~>), class EncodeJson, encodeJson) -import Data.Argonaut.Encode.Aeson ((>$<), (>*<), (>/\<), Encoder) -import Data.Array (index) -import Data.Bifunctor (lmap) +import Control.Lazy (defer) +import Data.Argonaut.Decode (class DecodeJson) +import Data.Argonaut.Decode.Aeson ((), (), ()) +import Data.Argonaut.Encode (class EncodeJson) +import Data.Argonaut.Encode.Aeson ((>$<), (>/\<)) import Data.Bounded.Generic (genericBottom, genericTop) -import Data.Either (Either, Either(..)) +import Data.Either (Either) import Data.Enum (class Enum) import Data.Enum.Generic (genericPred, genericSucc) -import Data.Functor (class Functor) import Data.Generic.Rep (class Generic) -import Data.Lens (Iso', Lens', Prism', iso, lens, prism') +import Data.Lens (Iso', Lens', Prism', iso, prism') import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) -import Data.Maybe (Maybe, Maybe(..), maybe) +import Data.Maybe (Maybe(..)) import Data.Newtype (class Newtype, unwrap) import Data.Show.Generic (genericShow) import Data.Tuple (Tuple) @@ -38,23 +33,21 @@ data TestData derive instance eqTestData :: Eq TestData instance showTestData :: Show TestData where - show = genericShow + show a = genericShow a derive instance ordTestData :: Ord TestData instance encodeJsonTestData :: EncodeJson TestData where - encodeJson = - case _ of - Maybe a -> E.encodeTagged "Maybe" a (E.maybe E.value) - Either a -> E.encodeTagged "Either" a (E.either (E.maybe E.value) (E.maybe E.value)) + encodeJson = defer \_ -> case _ of + Maybe a -> E.encodeTagged "Maybe" a (E.maybe E.value) + Either a -> E.encodeTagged "Either" a (E.either (E.maybe E.value) (E.maybe E.value)) instance decodeJsonTestData :: DecodeJson TestData where - decodeJson = D.decode - $ D.sumType "TestData" - $ Map.fromFoldable - [ "Maybe" /\ (Maybe <$> (D.maybe D.value)) - , "Either" /\ (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) - ] + decodeJson = defer \_ -> D.decode + $ D.sumType "TestData" $ Map.fromFoldable + [ "Maybe" /\ (Maybe <$> (D.maybe D.value)) + , "Either" /\ (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) + ] derive instance genericTestData :: Generic TestData _ @@ -94,69 +87,70 @@ data TestSum | Triple (Tuple Int (Tuple Unit Boolean)) | Quad (Tuple Int (Tuple Number (Tuple Boolean Number))) | QuadSimple Int Number Boolean Number + | Recursive TestRecursiveA | Enum TestEnum derive instance eqTestSum :: Eq TestSum instance showTestSum :: Show TestSum where - show = genericShow + show a = genericShow a derive instance ordTestSum :: Ord TestSum instance encodeJsonTestSum :: EncodeJson TestSum where - encodeJson = - case _ of - Nullary -> E.encodeTagged "Nullary" unit E.null - Bool a -> E.encodeTagged "Bool" a E.value - Int a -> E.encodeTagged "Int" a E.value - Number a -> E.encodeTagged "Number" a E.value - String a -> E.encodeTagged "String" a E.value - Array a -> E.encodeTagged "Array" a E.value - InlineRecord {why, wouldYouDoThis} -> E.encodeTagged "InlineRecord" {why, wouldYouDoThis} (E.record - - { why: E.value :: _ String - , wouldYouDoThis: E.value :: _ Int - }) - Record a -> E.encodeTagged "Record" a E.value - NestedRecord a -> E.encodeTagged "NestedRecord" a E.value - NT a -> E.encodeTagged "NT" a E.value - NTRecord a -> E.encodeTagged "NTRecord" a E.value - TwoFields a -> E.encodeTagged "TwoFields" a E.value - Unit a -> E.encodeTagged "Unit" a E.unit - MyUnit a -> E.encodeTagged "MyUnit" a E.value - Pair a -> E.encodeTagged "Pair" a (E.tuple (E.value >/\< E.value)) - Triple a -> E.encodeTagged "Triple" a (E.tuple (E.value >/\< E.unit >/\< E.value)) - Quad a -> E.encodeTagged "Quad" a (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) - QuadSimple a b c d -> E.encodeTagged "QuadSimple" (a /\ b /\ c /\ d) (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) - Enum a -> E.encodeTagged "Enum" a E.value + encodeJson = defer \_ -> case _ of + Nullary -> E.encodeTagged "Nullary" unit E.null + Bool a -> E.encodeTagged "Bool" a E.value + Int a -> E.encodeTagged "Int" a E.value + Number a -> E.encodeTagged "Number" a E.value + String a -> E.encodeTagged "String" a E.value + Array a -> E.encodeTagged "Array" a E.value + InlineRecord {why, wouldYouDoThis} -> E.encodeTagged "InlineRecord" {why, wouldYouDoThis} (E.record + + { why: E.value :: _ String + , wouldYouDoThis: E.value :: _ Int + }) + Record a -> E.encodeTagged "Record" a E.value + NestedRecord a -> E.encodeTagged "NestedRecord" a E.value + NT a -> E.encodeTagged "NT" a E.value + NTRecord a -> E.encodeTagged "NTRecord" a E.value + TwoFields a -> E.encodeTagged "TwoFields" a E.value + Unit a -> E.encodeTagged "Unit" a E.unit + MyUnit a -> E.encodeTagged "MyUnit" a E.value + Pair a -> E.encodeTagged "Pair" a (E.tuple (E.value >/\< E.value)) + Triple a -> E.encodeTagged "Triple" a (E.tuple (E.value >/\< E.unit >/\< E.value)) + Quad a -> E.encodeTagged "Quad" a (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + QuadSimple a b c d -> E.encodeTagged "QuadSimple" (a /\ b /\ c /\ d) (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + Recursive a -> E.encodeTagged "Recursive" a E.value + Enum a -> E.encodeTagged "Enum" a E.value instance decodeJsonTestSum :: DecodeJson TestSum where - decodeJson = D.decode - $ D.sumType "TestSum" - $ Map.fromFoldable - [ "Nullary" /\ (Nullary <$ D.null) - , "Bool" /\ (Bool <$> D.value) - , "Int" /\ (Int <$> D.value) - , "Number" /\ (Number <$> D.value) - , "String" /\ (String <$> D.value) - , "Array" /\ (Array <$> D.value) - , "InlineRecord" /\ (InlineRecord <$> D.record "InlineRecord" - { why: D.value :: _ String - , wouldYouDoThis: D.value :: _ Int - }) - , "Record" /\ (Record <$> D.value) - , "NestedRecord" /\ (NestedRecord <$> D.value) - , "NT" /\ (NT <$> D.value) - , "NTRecord" /\ (NTRecord <$> D.value) - , "TwoFields" /\ (TwoFields <$> D.value) - , "Unit" /\ (Unit <$> D.unit) - , "MyUnit" /\ (MyUnit <$> D.value) - , "Pair" /\ (Pair <$> (D.tuple (D.value D.value))) - , "Triple" /\ (Triple <$> (D.tuple (D.value D.unit D.value))) - , "Quad" /\ (Quad <$> (D.tuple (D.value D.value D.value D.value))) - , "QuadSimple" /\ (D.tuple $ QuadSimple D.value D.value D.value D.value) - , "Enum" /\ (Enum <$> D.value) - ] + decodeJson = defer \_ -> D.decode + $ D.sumType "TestSum" $ Map.fromFoldable + [ "Nullary" /\ (Nullary <$ D.null) + , "Bool" /\ (Bool <$> D.value) + , "Int" /\ (Int <$> D.value) + , "Number" /\ (Number <$> D.value) + , "String" /\ (String <$> D.value) + , "Array" /\ (Array <$> D.value) + , "InlineRecord" /\ (InlineRecord <$> D.record "InlineRecord" + { why: D.value :: _ String + , wouldYouDoThis: D.value :: _ Int + }) + , "Record" /\ (Record <$> D.value) + , "NestedRecord" /\ (NestedRecord <$> D.value) + , "NT" /\ (NT <$> D.value) + , "NTRecord" /\ (NTRecord <$> D.value) + , "TwoFields" /\ (TwoFields <$> D.value) + , "Unit" /\ (Unit <$> D.unit) + , "MyUnit" /\ (MyUnit <$> D.value) + , "Pair" /\ (Pair <$> (D.tuple (D.value D.value))) + , "Triple" /\ (Triple <$> (D.tuple (D.value D.unit D.value))) + , "Quad" /\ (Quad <$> (D.tuple (D.value D.value D.value D.value))) + , "QuadSimple" /\ (D.tuple $ QuadSimple D.value D.value D.value D.value) + , "Recursive" /\ (Recursive <$> D.value) + , "Enum" /\ (Enum <$> D.value) + ] derive instance genericTestSum :: Generic TestSum _ @@ -252,6 +246,11 @@ _QuadSimple = prism' (\{a, b, c, d} -> (QuadSimple a b c d)) case _ of (QuadSimple a b c d) -> Just {a, b, c, d} _ -> Nothing +_Recursive :: Prism' TestSum TestRecursiveA +_Recursive = prism' Recursive case _ of + (Recursive a) -> Just a + _ -> Nothing + _Enum :: Prism' TestSum TestEnum _Enum = prism' Enum case _ of (Enum a) -> Just a @@ -259,6 +258,71 @@ _Enum = prism' Enum case _ of -------------------------------------------------------------------------------- +data TestRecursiveA + = Nil + | Recurse TestRecursiveB + +derive instance eqTestRecursiveA :: Eq TestRecursiveA + +instance showTestRecursiveA :: Show TestRecursiveA where + show a = genericShow a + +derive instance ordTestRecursiveA :: Ord TestRecursiveA + +instance encodeJsonTestRecursiveA :: EncodeJson TestRecursiveA where + encodeJson = defer \_ -> case _ of + Nil -> E.encodeTagged "Nil" unit E.null + Recurse a -> E.encodeTagged "Recurse" a E.value + +instance decodeJsonTestRecursiveA :: DecodeJson TestRecursiveA where + decodeJson = defer \_ -> D.decode + $ D.sumType "TestRecursiveA" $ Map.fromFoldable + [ "Nil" /\ (Nil <$ D.null) + , "Recurse" /\ (Recurse <$> D.value) + ] + +derive instance genericTestRecursiveA :: Generic TestRecursiveA _ + +-------------------------------------------------------------------------------- + +_Nil :: Prism' TestRecursiveA Unit +_Nil = prism' (const Nil) case _ of + Nil -> Just unit + _ -> Nothing + +_Recurse :: Prism' TestRecursiveA TestRecursiveB +_Recurse = prism' Recurse case _ of + (Recurse a) -> Just a + _ -> Nothing + +-------------------------------------------------------------------------------- + +newtype TestRecursiveB = RecurseB TestRecursiveB + +derive instance eqTestRecursiveB :: Eq TestRecursiveB + +instance showTestRecursiveB :: Show TestRecursiveB where + show a = genericShow a + +derive instance ordTestRecursiveB :: Ord TestRecursiveB + +instance encodeJsonTestRecursiveB :: EncodeJson TestRecursiveB where + encodeJson = defer \_ -> E.encode $ unwrap >$< E.value + +instance decodeJsonTestRecursiveB :: DecodeJson TestRecursiveB where + decodeJson = defer \_ -> D.decode $ (RecurseB <$> D.value) + +derive instance genericTestRecursiveB :: Generic TestRecursiveB _ + +derive instance newtypeTestRecursiveB :: Newtype TestRecursiveB _ + +-------------------------------------------------------------------------------- + +_RecurseB :: Iso' TestRecursiveB TestRecursiveB +_RecurseB = _Newtype + +-------------------------------------------------------------------------------- + newtype TestRecord a = TestRecord { _field1 :: Maybe Int , _field2 :: a @@ -269,20 +333,18 @@ derive instance functorTestRecord :: Functor TestRecord derive instance eqTestRecord :: (Eq a) => Eq (TestRecord a) instance showTestRecord :: (Show a) => Show (TestRecord a) where - show = genericShow + show a = genericShow a derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where - encodeJson = - E.encode $ unwrap - >$< (E.record - { _field1: (E.maybe E.value) :: _ (Maybe Int) - , _field2: E.value :: _ a - }) + encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record + { _field1: (E.maybe E.value) :: _ (Maybe Int) + , _field2: E.value :: _ a + }) instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) where - decodeJson = D.decode $ (TestRecord <$> D.record "TestRecord" + decodeJson = defer \_ -> D.decode $ (TestRecord <$> D.record "TestRecord" { _field1: (D.maybe D.value) :: _ (Maybe Int) , _field2: D.value :: _ a }) @@ -309,17 +371,15 @@ newtype TestNewtype = TestNewtype (TestRecord Boolean) derive instance eqTestNewtype :: Eq TestNewtype instance showTestNewtype :: Show TestNewtype where - show = genericShow + show a = genericShow a derive instance ordTestNewtype :: Ord TestNewtype instance encodeJsonTestNewtype :: EncodeJson TestNewtype where - encodeJson = - E.encode $ unwrap - >$< E.value + encodeJson = defer \_ -> E.encode $ unwrap >$< E.value instance decodeJsonTestNewtype :: DecodeJson TestNewtype where - decodeJson = D.decode $ (TestNewtype <$> D.value) + decodeJson = defer \_ -> D.decode $ (TestNewtype <$> D.value) derive instance genericTestNewtype :: Generic TestNewtype _ @@ -337,17 +397,16 @@ newtype TestNewtypeRecord = TestNewtypeRecord { unTestNewtypeRecord :: TestNewty derive instance eqTestNewtypeRecord :: Eq TestNewtypeRecord instance showTestNewtypeRecord :: Show TestNewtypeRecord where - show = genericShow + show a = genericShow a derive instance ordTestNewtypeRecord :: Ord TestNewtypeRecord instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where - encodeJson = - E.encode $ unwrap - >$< (E.record { unTestNewtypeRecord: E.value :: _ TestNewtype }) + encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record + { unTestNewtypeRecord: E.value :: _ TestNewtype }) instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where - decodeJson = D.decode $ (TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: _ TestNewtype }) + decodeJson = defer \_ -> D.decode $ (TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: _ TestNewtype }) derive instance genericTestNewtypeRecord :: Generic TestNewtypeRecord _ @@ -365,17 +424,15 @@ data TestTwoFields = TestTwoFields Boolean Int derive instance eqTestTwoFields :: Eq TestTwoFields instance showTestTwoFields :: Show TestTwoFields where - show = genericShow + show a = genericShow a derive instance ordTestTwoFields :: Ord TestTwoFields instance encodeJsonTestTwoFields :: EncodeJson TestTwoFields where - encodeJson = - E.encode $ (case _ of TestTwoFields a b -> (a /\ b)) - >$< (E.tuple (E.value >/\< E.value)) + encodeJson = defer \_ -> E.encode $ (case _ of TestTwoFields a b -> (a /\ b)) >$< (E.tuple (E.value >/\< E.value)) instance decodeJsonTestTwoFields :: DecodeJson TestTwoFields where - decodeJson = D.decode $ (D.tuple $ TestTwoFields D.value D.value) + decodeJson = defer \_ -> D.decode $ (D.tuple $ TestTwoFields D.value D.value) derive instance genericTestTwoFields :: Generic TestTwoFields _ @@ -398,15 +455,15 @@ data TestEnum derive instance eqTestEnum :: Eq TestEnum instance showTestEnum :: Show TestEnum where - show = genericShow + show a = genericShow a derive instance ordTestEnum :: Ord TestEnum instance encodeJsonTestEnum :: EncodeJson TestEnum where - encodeJson = E.encode E.enum + encodeJson = defer \_ -> E.encode E.enum instance decodeJsonTestEnum :: DecodeJson TestEnum where - decodeJson = D.decode D.enum + decodeJson = defer \_ -> D.decode D.enum derive instance genericTestEnum :: Generic TestEnum _ @@ -462,15 +519,15 @@ data MyUnit = U derive instance eqMyUnit :: Eq MyUnit instance showMyUnit :: Show MyUnit where - show = genericShow + show a = genericShow a derive instance ordMyUnit :: Ord MyUnit instance encodeJsonMyUnit :: EncodeJson MyUnit where - encodeJson = E.encode E.enum + encodeJson = defer \_ -> E.encode E.enum instance decodeJsonMyUnit :: DecodeJson MyUnit where - decodeJson = D.decode D.enum + decodeJson = defer \_ -> D.decode D.enum derive instance genericMyUnit :: Generic MyUnit _ diff --git a/test/Spec.hs b/test/Spec.hs index 968c97f6..2672538c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -45,7 +45,7 @@ allTests = do , " | FooBar Int String" , "" , "instance showFoo :: Show Foo where" - , " show = genericShow" + , " show a = genericShow a" , "" , "derive instance eqFoo :: Eq Foo" , "" @@ -69,7 +69,7 @@ allTests = do , "derive instance functorFunc :: Functor Func" , "" , "instance showFunc :: (Show a) => Show (Func a) where" - , " show = genericShow" + , " show a = genericShow a" , "" , "derive instance genericFunc :: Generic (Func a) _" ] @@ -91,7 +91,7 @@ allTests = do , "" , "import Data.Either (Either)" , "import Data.Generic.Rep (class Generic)" - , "import Data.Maybe (Maybe, Maybe(..))" + , "import Data.Maybe (Maybe(..))" , "" , "data Bar a b m c" , " = Bar1 (Maybe a)" From 132a6d1574b9b26925090ec5c5392d4931ad5268 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 27 Oct 2021 16:43:05 -0400 Subject: [PATCH 046/111] Fix handling of multi record constructors --- src/Language/PureScript/Bridge/Printer.hs | 58 +++++++-- test/RoundTrip/Spec.hs | 3 +- test/RoundTrip/Types.hs | 30 ++++- test/RoundTrip/app/packages.dhall | 2 +- test/RoundTrip/app/src/RoundTrip/Types.purs | 134 +++++++++++++++----- 5 files changed, 182 insertions(+), 45 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index fbb04f08..ee78b5c7 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -47,7 +47,7 @@ import Text.PrettyPrint.Leijen.Text (Doc, renderPretty, rparen, textStrict, vsep, - (<+>), hang, dquotes, char, backslash, nest, linebreak, lbrace, rbrace, softline, lbracket, rbracket) + (<+>), hang, dquotes, char, backslash, nest, linebreak, lbrace, rbrace, softline, lbracket, rbracket, colon) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty((:|))) import Data.Char (isLower, toLower) @@ -147,7 +147,9 @@ instanceToImportLines GenericShow = instanceToImportLines Json = importsFromList [ ImportLine "Control.Lazy" $ Set.singleton "defer" + , ImportLine "Data.Argonaut.Core" $ Set.singleton "jsonNull" , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["()", "()", "()"] + , ImportLine "Data.Argonaut.Encode" $ Set.singleton "encodeJson" , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["(>$<)", "(>/\\<)"] , ImportLine "Data.Newtype" $ Set.singleton "unwrap" , ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" @@ -377,8 +379,30 @@ sumTypeToEncode (SumType _ cs _) where constructorToEncode c@(DataConstructor name args) = ( constructorPattern c - , "E.encodeTagged" <+> dquotes (textStrict name) <+> constructor args <+> argsToEncode args + , case args of + Nullary -> "jsonNull" + Normal as -> "E.encodeTagged" + <+> dquotes (textStrict name) + <+> normalExpr as + <+> argsToEncode args + Record rs + | any ((== "tag") . _recLabel) rs -> "E.encodeTagged" + <+> dquotes (textStrict name) + <+> hrecord (fields rs) + <+> argsToEncode args + | otherwise -> hsep + [ "encodeJson" + , vrecord + $ ("tag:" <+> dquotes (textStrict name)) + : (recordFieldToJson <$> NE.toList rs) + ] ) + recordFieldToJson (RecordEntry name t) = + textStrict name + <> colon + <+> "flip E.encode" + <+> textStrict name + <+> typeToEncode t argsToEncode Nullary = "E.null" argsToEncode (Normal (t :| [])) = typeToEncode t argsToEncode (Normal ts) = @@ -411,7 +435,7 @@ typeToEncode _ = "E.value" sumTypeToDecode :: SumType 'PureScript -> Doc sumTypeToDecode (SumType _ cs _) | isEnum cs = "D.enum" -sumTypeToDecode (SumType _ [c] _) = "$" <+> constructorToDecode c +sumTypeToDecode (SumType _ [c] _) = "$" <+> constructorToDecode False c sumTypeToDecode (SumType t cs _) = line <> hsep [ "$ D.sumType" @@ -423,21 +447,37 @@ sumTypeToDecode (SumType t cs _) = line <> constructorToTagged dc = hsep [ dc ^. sigConstructor . to textStrict . to dquotes , "/\\" - , constructorToDecode dc + , constructorToDecode True dc ] -constructorToDecode :: DataConstructor 'PureScript -> Doc -constructorToDecode (DataConstructor name Nullary) = +constructorToDecode :: Bool -> DataConstructor 'PureScript -> Doc +constructorToDecode True (DataConstructor name Nullary) = + "pure" <+> textStrict name +constructorToDecode False (DataConstructor name Nullary) = parens $ textStrict name <+> "<$" <+> "D.null" -constructorToDecode (DataConstructor name (Normal (a :| []))) = +constructorToDecode True dc@(DataConstructor _ (Normal _)) = + "D.content" <+> constructorToDecode False dc +constructorToDecode False (DataConstructor name (Normal (a :| []))) = parens $ textStrict name <+> "<$>" <+> typeToDecode a -constructorToDecode (DataConstructor name (Normal as)) = +constructorToDecode False (DataConstructor name (Normal as)) = parens $ "D.tuple" <+> "$" <+> textStrict name <+> encloseHsep "" mempty " " (typeToDecode <$> NE.toList as) -constructorToDecode (DataConstructor name (Record rs)) = +constructorToDecode True dc@(DataConstructor name (Record rs)) + | any ((== "tag") . _recLabel) rs = + "D.content" <+> constructorToDecode False dc + | otherwise = parens $ textStrict name + <+> "<$> D.object" + <+> dquotes (textStrict name) + <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) + where + fieldDecoder r = + r + & recValue %~ mkType "_" . pure + & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) +constructorToDecode False (DataConstructor name (Record rs)) = parens $ textStrict name <+> "<$> D.record" <+> dquotes (textStrict name) diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 125c9238..76a20c11 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -40,6 +40,7 @@ myTypes = functor . equal . genericShow . order . argonaut $ mkSumType @(TestRecord A), equal . genericShow . order . argonaut $ mkSumType @TestNewtype, equal . genericShow . order . argonaut $ mkSumType @TestNewtypeRecord, + equal . genericShow . order . argonaut $ mkSumType @TestMultiInlineRecords, equal . genericShow . order . argonaut $ mkSumType @TestTwoFields, equal . genericShow . order . argonaut $ mkSumType @TestEnum, equal . genericShow . order . argonaut $ mkSumType @MyUnit @@ -56,7 +57,7 @@ roundtripSpec = do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" assertBool stderr $ not $ "[warn]" `isInfixOf` stderr it "should produce aeson-compatible argonaut instances" $ - once $ property $ + property $ \testData -> bracket runApp killApp $ \(hin, hout, hproc) -> do hPutStrLn hin $ toString $ encode @TestData testData diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index ea540537..4b4118f3 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -1,14 +1,15 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} module RoundTrip.Types where import Control.Applicative ((<|>)) import Data.Aeson (FromJSON, ToJSON) import Data.Proxy (Proxy (..)) +import Data.Text (Text) import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, mkSumType, writePSTypes, writePSTypesWith) import Language.PureScript.Bridge.TypeParameters (A) @@ -43,7 +44,8 @@ data TestSum | Number Double | String String | Array [Int] - | InlineRecord { why :: String, wouldYouDoThis :: Int } + | InlineRecord {why :: String, wouldYouDoThis :: Int} + | MultiInlineRecords TestMultiInlineRecords | Record (TestRecord Int) | NestedRecord (TestRecord (TestRecord Int)) | NT TestNewtype @@ -73,6 +75,7 @@ instance Arbitrary TestSum where String <$> arbitrary, Array <$> arbitrary, InlineRecord <$> arbitrary <*> arbitrary, + MultiInlineRecords <$> arbitrary, Record <$> arbitrary, NestedRecord <$> arbitrary, NT <$> arbitrary, @@ -107,6 +110,29 @@ instance FromJSON TestRecursiveB instance ToJSON TestRecursiveB +data TestMultiInlineRecords + = Foo + { _foo1 :: Maybe Int, + _foo2 :: (), + tag :: String + } + | Bar + { _bar1 :: String, + _bar2 :: Bool + } + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TestMultiInlineRecords + +instance ToJSON TestMultiInlineRecords + +instance Arbitrary TestMultiInlineRecords where + arbitrary = + oneof + [ Foo <$> arbitrary <*> arbitrary <*> arbitrary, + Bar <$> arbitrary <*> arbitrary + ] + data TestRecord a = TestRecord { _field1 :: Maybe Int, _field2 :: a diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall index 95c78583..6c45c88b 100644 --- a/test/RoundTrip/app/packages.dhall +++ b/test/RoundTrip/app/packages.dhall @@ -30,6 +30,6 @@ in upstream // { , "typelevel-prelude" ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "16de087fde6e2d07e6bdae51383131ab81efa82d" + , version = "0556c336c06fea6e388946271ae8965e775e3ed0" } } diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 97f62350..e5536c78 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -4,9 +4,10 @@ module RoundTrip.Types where import Prelude import Control.Lazy (defer) +import Data.Argonaut.Core (jsonNull) import Data.Argonaut.Decode (class DecodeJson) import Data.Argonaut.Decode.Aeson ((), (), ()) -import Data.Argonaut.Encode (class EncodeJson) +import Data.Argonaut.Encode (class EncodeJson, encodeJson) import Data.Argonaut.Encode.Aeson ((>$<), (>/\<)) import Data.Bounded.Generic (genericBottom, genericTop) import Data.Either (Either) @@ -45,8 +46,8 @@ instance encodeJsonTestData :: EncodeJson TestData where instance decodeJsonTestData :: DecodeJson TestData where decodeJson = defer \_ -> D.decode $ D.sumType "TestData" $ Map.fromFoldable - [ "Maybe" /\ (Maybe <$> (D.maybe D.value)) - , "Either" /\ (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) + [ "Maybe" /\ D.content (Maybe <$> (D.maybe D.value)) + , "Either" /\ D.content (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) ] derive instance genericTestData :: Generic TestData _ @@ -76,6 +77,7 @@ data TestSum { why :: String , wouldYouDoThis :: Int } + | MultiInlineRecords TestMultiInlineRecords | Record (TestRecord Int) | NestedRecord (TestRecord (TestRecord Int)) | NT TestNewtype @@ -99,17 +101,18 @@ derive instance ordTestSum :: Ord TestSum instance encodeJsonTestSum :: EncodeJson TestSum where encodeJson = defer \_ -> case _ of - Nullary -> E.encodeTagged "Nullary" unit E.null + Nullary -> jsonNull Bool a -> E.encodeTagged "Bool" a E.value Int a -> E.encodeTagged "Int" a E.value Number a -> E.encodeTagged "Number" a E.value String a -> E.encodeTagged "String" a E.value Array a -> E.encodeTagged "Array" a E.value - InlineRecord {why, wouldYouDoThis} -> E.encodeTagged "InlineRecord" {why, wouldYouDoThis} (E.record - - { why: E.value :: _ String - , wouldYouDoThis: E.value :: _ Int - }) + InlineRecord {why, wouldYouDoThis} -> encodeJson + { tag: "InlineRecord" + , why: flip E.encode why E.value + , wouldYouDoThis: flip E.encode wouldYouDoThis E.value + } + MultiInlineRecords a -> E.encodeTagged "MultiInlineRecords" a E.value Record a -> E.encodeTagged "Record" a E.value NestedRecord a -> E.encodeTagged "NestedRecord" a E.value NT a -> E.encodeTagged "NT" a E.value @@ -127,29 +130,30 @@ instance encodeJsonTestSum :: EncodeJson TestSum where instance decodeJsonTestSum :: DecodeJson TestSum where decodeJson = defer \_ -> D.decode $ D.sumType "TestSum" $ Map.fromFoldable - [ "Nullary" /\ (Nullary <$ D.null) - , "Bool" /\ (Bool <$> D.value) - , "Int" /\ (Int <$> D.value) - , "Number" /\ (Number <$> D.value) - , "String" /\ (String <$> D.value) - , "Array" /\ (Array <$> D.value) - , "InlineRecord" /\ (InlineRecord <$> D.record "InlineRecord" + [ "Nullary" /\ pure Nullary + , "Bool" /\ D.content (Bool <$> D.value) + , "Int" /\ D.content (Int <$> D.value) + , "Number" /\ D.content (Number <$> D.value) + , "String" /\ D.content (String <$> D.value) + , "Array" /\ D.content (Array <$> D.value) + , "InlineRecord" /\ (InlineRecord <$> D.object "InlineRecord" { why: D.value :: _ String , wouldYouDoThis: D.value :: _ Int }) - , "Record" /\ (Record <$> D.value) - , "NestedRecord" /\ (NestedRecord <$> D.value) - , "NT" /\ (NT <$> D.value) - , "NTRecord" /\ (NTRecord <$> D.value) - , "TwoFields" /\ (TwoFields <$> D.value) - , "Unit" /\ (Unit <$> D.unit) - , "MyUnit" /\ (MyUnit <$> D.value) - , "Pair" /\ (Pair <$> (D.tuple (D.value D.value))) - , "Triple" /\ (Triple <$> (D.tuple (D.value D.unit D.value))) - , "Quad" /\ (Quad <$> (D.tuple (D.value D.value D.value D.value))) - , "QuadSimple" /\ (D.tuple $ QuadSimple D.value D.value D.value D.value) - , "Recursive" /\ (Recursive <$> D.value) - , "Enum" /\ (Enum <$> D.value) + , "MultiInlineRecords" /\ D.content (MultiInlineRecords <$> D.value) + , "Record" /\ D.content (Record <$> D.value) + , "NestedRecord" /\ D.content (NestedRecord <$> D.value) + , "NT" /\ D.content (NT <$> D.value) + , "NTRecord" /\ D.content (NTRecord <$> D.value) + , "TwoFields" /\ D.content (TwoFields <$> D.value) + , "Unit" /\ D.content (Unit <$> D.unit) + , "MyUnit" /\ D.content (MyUnit <$> D.value) + , "Pair" /\ D.content (Pair <$> (D.tuple (D.value D.value))) + , "Triple" /\ D.content (Triple <$> (D.tuple (D.value D.unit D.value))) + , "Quad" /\ D.content (Quad <$> (D.tuple (D.value D.value D.value D.value))) + , "QuadSimple" /\ D.content (D.tuple $ QuadSimple D.value D.value D.value D.value) + , "Recursive" /\ D.content (Recursive <$> D.value) + , "Enum" /\ D.content (Enum <$> D.value) ] derive instance genericTestSum :: Generic TestSum _ @@ -191,6 +195,11 @@ _InlineRecord = prism' InlineRecord case _ of (InlineRecord a) -> Just a _ -> Nothing +_MultiInlineRecords :: Prism' TestSum TestMultiInlineRecords +_MultiInlineRecords = prism' MultiInlineRecords case _ of + (MultiInlineRecords a) -> Just a + _ -> Nothing + _Record :: Prism' TestSum (TestRecord Int) _Record = prism' Record case _ of (Record a) -> Just a @@ -271,14 +280,14 @@ derive instance ordTestRecursiveA :: Ord TestRecursiveA instance encodeJsonTestRecursiveA :: EncodeJson TestRecursiveA where encodeJson = defer \_ -> case _ of - Nil -> E.encodeTagged "Nil" unit E.null + Nil -> jsonNull Recurse a -> E.encodeTagged "Recurse" a E.value instance decodeJsonTestRecursiveA :: DecodeJson TestRecursiveA where decodeJson = defer \_ -> D.decode $ D.sumType "TestRecursiveA" $ Map.fromFoldable - [ "Nil" /\ (Nil <$ D.null) - , "Recurse" /\ (Recurse <$> D.value) + [ "Nil" /\ pure Nil + , "Recurse" /\ D.content (Recurse <$> D.value) ] derive instance genericTestRecursiveA :: Generic TestRecursiveA _ @@ -419,6 +428,67 @@ _TestNewtypeRecord = _Newtype -------------------------------------------------------------------------------- +data TestMultiInlineRecords + = Foo + { _foo1 :: Maybe Int + , _foo2 :: Unit + , tag :: String + } + | Bar + { _bar1 :: String + , _bar2 :: Boolean + } + +derive instance eqTestMultiInlineRecords :: Eq TestMultiInlineRecords + +instance showTestMultiInlineRecords :: Show TestMultiInlineRecords where + show a = genericShow a + +derive instance ordTestMultiInlineRecords :: Ord TestMultiInlineRecords + +instance encodeJsonTestMultiInlineRecords :: EncodeJson TestMultiInlineRecords where + encodeJson = defer \_ -> case _ of + Foo {_foo1, _foo2, tag} -> E.encodeTagged "Foo" {_foo1, _foo2, tag} (E.record + { _foo1: (E.maybe E.value) :: _ (Maybe Int) + , _foo2: E.unit :: _ Unit + , tag: E.value :: _ String + }) + Bar {_bar1, _bar2} -> encodeJson + { tag: "Bar" + , _bar1: flip E.encode _bar1 E.value + , _bar2: flip E.encode _bar2 E.value + } + +instance decodeJsonTestMultiInlineRecords :: DecodeJson TestMultiInlineRecords where + decodeJson = defer \_ -> D.decode + $ D.sumType "TestMultiInlineRecords" $ Map.fromFoldable + [ "Foo" /\ D.content (Foo <$> D.record "Foo" + { _foo1: (D.maybe D.value) :: _ (Maybe Int) + , _foo2: D.unit :: _ Unit + , tag: D.value :: _ String + }) + , "Bar" /\ (Bar <$> D.object "Bar" + { _bar1: D.value :: _ String + , _bar2: D.value :: _ Boolean + }) + ] + +derive instance genericTestMultiInlineRecords :: Generic TestMultiInlineRecords _ + +-------------------------------------------------------------------------------- + +_Foo :: Prism' TestMultiInlineRecords {_foo1 :: Maybe Int, _foo2 :: Unit, tag :: String} +_Foo = prism' Foo case _ of + (Foo a) -> Just a + _ -> Nothing + +_Bar :: Prism' TestMultiInlineRecords {_bar1 :: String, _bar2 :: Boolean} +_Bar = prism' Bar case _ of + (Bar a) -> Just a + _ -> Nothing + +-------------------------------------------------------------------------------- + data TestTwoFields = TestTwoFields Boolean Int derive instance eqTestTwoFields :: Eq TestTwoFields From 27501feac92234fad5b39bd10708a8d525f698fe Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Thu, 28 Oct 2021 08:21:08 -0400 Subject: [PATCH 047/111] Fix encoding of nullary constructors --- src/Language/PureScript/Bridge/Printer.hs | 2 +- test/RoundTrip/Types.hs | 5 ++--- test/RoundTrip/app/packages.dhall | 2 +- test/RoundTrip/app/src/RoundTrip/Types.purs | 20 +++++++++----------- 4 files changed, 13 insertions(+), 16 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index ee78b5c7..35b9aef4 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -380,7 +380,7 @@ sumTypeToEncode (SumType _ cs _) constructorToEncode c@(DataConstructor name args) = ( constructorPattern c , case args of - Nullary -> "jsonNull" + Nullary -> "encodeJson { tag:" <+> dquotes (textStrict name) <> ", contents: jsonNull }" Normal as -> "E.encodeTagged" <+> dquotes (textStrict name) <+> normalExpr as diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index 4b4118f3..5d4c4dd0 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -113,8 +113,7 @@ instance ToJSON TestRecursiveB data TestMultiInlineRecords = Foo { _foo1 :: Maybe Int, - _foo2 :: (), - tag :: String + _foo2 :: () } | Bar { _bar1 :: String, @@ -129,7 +128,7 @@ instance ToJSON TestMultiInlineRecords instance Arbitrary TestMultiInlineRecords where arbitrary = oneof - [ Foo <$> arbitrary <*> arbitrary <*> arbitrary, + [ Foo <$> arbitrary <*> arbitrary, Bar <$> arbitrary <*> arbitrary ] diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall index 6c45c88b..d6c32279 100644 --- a/test/RoundTrip/app/packages.dhall +++ b/test/RoundTrip/app/packages.dhall @@ -30,6 +30,6 @@ in upstream // { , "typelevel-prelude" ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "0556c336c06fea6e388946271ae8965e775e3ed0" + , version = "e837d9ad8bf8c2ab666e511c08754085f08f6340" } } diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index e5536c78..9f4805eb 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -101,7 +101,7 @@ derive instance ordTestSum :: Ord TestSum instance encodeJsonTestSum :: EncodeJson TestSum where encodeJson = defer \_ -> case _ of - Nullary -> jsonNull + Nullary -> encodeJson { tag: "Nullary", contents: jsonNull } Bool a -> E.encodeTagged "Bool" a E.value Int a -> E.encodeTagged "Int" a E.value Number a -> E.encodeTagged "Number" a E.value @@ -280,7 +280,7 @@ derive instance ordTestRecursiveA :: Ord TestRecursiveA instance encodeJsonTestRecursiveA :: EncodeJson TestRecursiveA where encodeJson = defer \_ -> case _ of - Nil -> jsonNull + Nil -> encodeJson { tag: "Nil", contents: jsonNull } Recurse a -> E.encodeTagged "Recurse" a E.value instance decodeJsonTestRecursiveA :: DecodeJson TestRecursiveA where @@ -432,7 +432,6 @@ data TestMultiInlineRecords = Foo { _foo1 :: Maybe Int , _foo2 :: Unit - , tag :: String } | Bar { _bar1 :: String @@ -448,11 +447,11 @@ derive instance ordTestMultiInlineRecords :: Ord TestMultiInlineRecords instance encodeJsonTestMultiInlineRecords :: EncodeJson TestMultiInlineRecords where encodeJson = defer \_ -> case _ of - Foo {_foo1, _foo2, tag} -> E.encodeTagged "Foo" {_foo1, _foo2, tag} (E.record - { _foo1: (E.maybe E.value) :: _ (Maybe Int) - , _foo2: E.unit :: _ Unit - , tag: E.value :: _ String - }) + Foo {_foo1, _foo2} -> encodeJson + { tag: "Foo" + , _foo1: flip E.encode _foo1 (E.maybe E.value) + , _foo2: flip E.encode _foo2 E.unit + } Bar {_bar1, _bar2} -> encodeJson { tag: "Bar" , _bar1: flip E.encode _bar1 E.value @@ -462,10 +461,9 @@ instance encodeJsonTestMultiInlineRecords :: EncodeJson TestMultiInlineRecords w instance decodeJsonTestMultiInlineRecords :: DecodeJson TestMultiInlineRecords where decodeJson = defer \_ -> D.decode $ D.sumType "TestMultiInlineRecords" $ Map.fromFoldable - [ "Foo" /\ D.content (Foo <$> D.record "Foo" + [ "Foo" /\ (Foo <$> D.object "Foo" { _foo1: (D.maybe D.value) :: _ (Maybe Int) , _foo2: D.unit :: _ Unit - , tag: D.value :: _ String }) , "Bar" /\ (Bar <$> D.object "Bar" { _bar1: D.value :: _ String @@ -477,7 +475,7 @@ derive instance genericTestMultiInlineRecords :: Generic TestMultiInlineRecords -------------------------------------------------------------------------------- -_Foo :: Prism' TestMultiInlineRecords {_foo1 :: Maybe Int, _foo2 :: Unit, tag :: String} +_Foo :: Prism' TestMultiInlineRecords {_foo1 :: Maybe Int, _foo2 :: Unit} _Foo = prism' Foo case _ of (Foo a) -> Just a _ -> Nothing From 366fc70b341e2633f3ad0158a577d52e1cd2b138 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Thu, 28 Oct 2021 11:04:49 -0400 Subject: [PATCH 048/111] Add support for set and map json --- src/Language/PureScript/Bridge.hs | 8 ++- src/Language/PureScript/Bridge/PSTypes.hs | 8 +++ src/Language/PureScript/Bridge/Primitives.hs | 12 +++++ src/Language/PureScript/Bridge/Printer.hs | 6 +++ test/RoundTrip/Spec.hs | 52 +++++++++++++------- test/RoundTrip/Types.hs | 6 +++ test/RoundTrip/app/packages.dhall | 2 +- test/RoundTrip/app/spago.dhall | 1 - test/RoundTrip/app/src/Main.purs | 25 +++++----- test/RoundTrip/app/src/RoundTrip/Types.purs | 18 +++++++ 10 files changed, 105 insertions(+), 33 deletions(-) diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index 6c7af282..47abc2e2 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -133,12 +133,18 @@ bridgeSumType br (SumType t cs is) = -- "Language.PureScript.Bridge.Tuple". defaultBridge :: BridgePart defaultBridge = - textBridge <|> stringBridge <|> listBridge <|> maybeBridge <|> eitherBridge <|> + textBridge <|> + stringBridge <|> + listBridge <|> + maybeBridge <|> + eitherBridge <|> boolBridge <|> intBridge <|> doubleBridge <|> tupleBridge <|> unitBridge <|> + mapBridge <|> + setBridge <|> noContentBridge -- | Translate types in a constructor. diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs index 2162cf77..07f8154a 100644 --- a/src/Language/PureScript/Bridge/PSTypes.hs +++ b/src/Language/PureScript/Bridge/PSTypes.hs @@ -83,3 +83,11 @@ psUnit = , _typeName = "Unit" , _typeParameters = [] } + +psMap :: MonadReader BridgeData m => m PSType +psMap = + TypeInfo "purescript-ordered-collections" "Data.Map" "Map" <$> psTypeParameters + +psSet :: MonadReader BridgeData m => m PSType +psSet = + TypeInfo "purescript-ordered-collections" "Data.Set" "Set" <$> psTypeParameters diff --git a/src/Language/PureScript/Bridge/Primitives.hs b/src/Language/PureScript/Bridge/Primitives.hs index a671d2af..d6d5fd2c 100644 --- a/src/Language/PureScript/Bridge/Primitives.hs +++ b/src/Language/PureScript/Bridge/Primitives.hs @@ -16,6 +16,18 @@ boolBridge = typeName ^== "Bool" >> return psBool eitherBridge :: BridgePart eitherBridge = typeName ^== "Either" >> psEither +setBridge :: BridgePart +setBridge = do + typeName ^== "Set" + typeModule ^== "Data.Set" <|> typeModule ^== "Data.Set.Internal" + psSet + +mapBridge :: BridgePart +mapBridge = do + typeName ^== "Map" + typeModule ^== "Data.Map" <|> typeModule ^== "Data.Map.Internal" + psMap + -- | Dummy bridge, translates every type with 'clearPackageFixUp' dummyBridge :: MonadReader BridgeData m => m PSType dummyBridge = clearPackageFixUp diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 35b9aef4..6e1c6995 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -429,6 +429,10 @@ typeToEncode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = pare "E.either" <+> typeToEncode l <+> typeToEncode r typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) +typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ + "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) +typeToEncode (TypeInfo "purescript-ordered-collections" "Data.Map" "Map" [k, v]) = parens $ + "E.dictionary" <+> typeToEncode k <+> typeToEncode v typeToEncode _ = "E.value" @@ -496,6 +500,8 @@ typeToDecode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = pare "D.either" <+> typeToDecode l <+> typeToDecode r typeToDecode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ "D.tuple" <+> encloseHsep lparen rparen " " (typeToDecode <$> flattenTuple ts) +typeToDecode (TypeInfo "purescript-ordered-collections" "Data.Map" "Map" [k, v]) = parens $ + "D.dictionary" <+> typeToDecode k <+> typeToDecode v typeToDecode _ = "D.value" diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 76a20c11..b633a841 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -8,9 +8,10 @@ module RoundTrip.Spec where import Control.Exception (bracket) import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, encode, fromJSON) -import Data.ByteString.Lazy (stripSuffix, hGetContents) -import Data.ByteString.Lazy.UTF8 (toString, fromString) +import Data.ByteString.Lazy (hGetContents, stripSuffix) +import Data.ByteString.Lazy.UTF8 (fromString, toString) import Data.List (isInfixOf) +import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, argonaut, buildBridge, defaultBridge, defaultSwitch, equal, functor, genericShow, mkSumType, order, writePSTypes, writePSTypesWith) @@ -18,15 +19,14 @@ import Language.PureScript.Bridge.TypeParameters (A) import RoundTrip.Types import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) -import System.IO (BufferMode (..), hSetBuffering, hPutStrLn, stdout, stderr, hFlush) -import System.Process (CreateProcess (std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess, waitForProcess) +import System.IO (BufferMode (..), hFlush, hGetLine, hPutStrLn, hSetBuffering, stderr, stdout) +import System.Process (CreateProcess (..), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess, waitForProcess) import Test.HUnit (assertBool, assertEqual) -import Test.Hspec (Spec, around, aroundAll_, describe, it) +import Test.Hspec (Spec, around, aroundAll_, around_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (noShrinking, once, verbose, withMaxSuccess) import Test.QuickCheck.Property (Testable (property)) -import Data.Maybe (fromMaybe) -import Test.QuickCheck (verbose, once, noShrinking, withMaxSuccess) myBridge :: BridgePart myBridge = defaultBridge @@ -56,23 +56,37 @@ roundtripSpec = do it "should not warn of unused packages buildable" do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" assertBool stderr $ not $ "[warn]" `isInfixOf` stderr - it "should produce aeson-compatible argonaut instances" $ - property $ - \testData -> bracket runApp killApp $ - \(hin, hout, hproc) -> do - hPutStrLn hin $ toString $ encode @TestData testData - output <- hGetContents hout - assertEqual (toString output) ExitSuccess =<< waitForProcess hproc - assertEqual (toString output) (Right testData) $ eitherDecode @TestData output + around withApp $ + it "should produce aeson-compatible argonaut instances" $ + \(hin, hout, herr, hproc) -> + property $ + \testData -> do + let input = toString $ encode @TestData testData + hPutStrLn hin input + err <- hGetLine herr + output <- hGetLine hout + assertEqual input "" err + assertEqual output (Right testData) $ eitherDecode @TestData $ fromString output where + withApp = bracket runApp killApp runApp = do - (Just hin, Just hout, _, hproc) <- - createProcess (proc "spago" ["run"]) {std_in = CreatePipe, std_out = CreatePipe} + (Just hin, Just hout, Just herr, hproc) <- + createProcess + (proc "spago" ["run"]) + { std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe + } hSetBuffering hin LineBuffering hSetBuffering hout LineBuffering - pure (hin, hout, hproc) + hSetBuffering herr LineBuffering + -- flush stderr output from build + _ <- hGetLine herr + -- wait for initial log message + _ <- hGetLine hout + pure (hin, hout, herr, hproc) - killApp (_, _, hproc) = terminateProcess hproc + killApp (_, _, _, hproc) = terminateProcess hproc withProject runSpec = withCurrentDirectory "test/RoundTrip/app" $ generate *> runSpec diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index 5d4c4dd0..31f15b99 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -8,7 +8,9 @@ module RoundTrip.Types where import Control.Applicative ((<|>)) import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) import Data.Proxy (Proxy (..)) +import Data.Set (Set) import Data.Text (Text) import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, mkSumType, writePSTypes, writePSTypesWith) @@ -51,6 +53,8 @@ data TestSum | NT TestNewtype | NTRecord TestNewtypeRecord | TwoFields TestTwoFields + | Set (Set Int) + | Map (Map String Int) | Unit () | MyUnit MyUnit | Pair (Int, Double) @@ -80,6 +84,8 @@ instance Arbitrary TestSum where NestedRecord <$> arbitrary, NT <$> arbitrary, NTRecord <$> arbitrary, + Map <$> arbitrary, + Set <$> arbitrary, TwoFields <$> arbitrary, pure $ Unit (), Pair <$> arbitrary, diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall index d6c32279..a7044d0e 100644 --- a/test/RoundTrip/app/packages.dhall +++ b/test/RoundTrip/app/packages.dhall @@ -30,6 +30,6 @@ in upstream // { , "typelevel-prelude" ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "e837d9ad8bf8c2ab666e511c08754085f08f6340" + , version = "895db00f2fe97ee56b866bf1582b303d029c216a" } } diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index 6948b426..d0a9eaec 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -10,7 +10,6 @@ , "json-helpers" , "maybe" , "newtype" - , "node-process" , "node-readline" , "ordered-collections" , "prelude" diff --git a/test/RoundTrip/app/src/Main.purs b/test/RoundTrip/app/src/Main.purs index 47e1ffb1..52c14eba 100644 --- a/test/RoundTrip/app/src/Main.purs +++ b/test/RoundTrip/app/src/Main.purs @@ -7,24 +7,27 @@ import Data.Argonaut.Decode (JsonDecodeError, decodeJson, parseJson, printJsonDe import Data.Argonaut.Encode (encodeJson) import Data.Either (Either(..)) import Effect (Effect) -import Effect.Class.Console (log) -import Node.Process (exit) +import Effect.Class.Console (error, log) import Node.ReadLine (createConsoleInterface, noCompletion, question) import RoundTrip.Types (TestData) main :: Effect Unit main = do interface <- createConsoleInterface noCompletion - interface # question "" \input -> - let - parsed :: Either JsonDecodeError TestData - parsed = decodeJson =<< parseJson input - in + log "ready" + go interface + where + go interface = + interface # question "" \input -> do + let + parsed :: Either JsonDecodeError TestData + parsed = decodeJson =<< parseJson input case parsed of Left err -> do - log $ "got" <> input - log $ printJsonDecodeError err - exit 1 + error $ "got " <> input + error $ printJsonDecodeError err + log "" Right testData -> do + error "" log $ stringify $ encodeJson testData - exit 0 + go interface diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 9f4805eb..7313b477 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -17,8 +17,10 @@ import Data.Generic.Rep (class Generic) import Data.Lens (Iso', Lens', Prism', iso, prism') import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) +import Data.Map (Map) import Data.Maybe (Maybe(..)) import Data.Newtype (class Newtype, unwrap) +import Data.Set (Set) import Data.Show.Generic (genericShow) import Data.Tuple (Tuple) import Data.Tuple.Nested ((/\)) @@ -83,6 +85,8 @@ data TestSum | NT TestNewtype | NTRecord TestNewtypeRecord | TwoFields TestTwoFields + | Set (Set Int) + | Map (Map String Int) | Unit Unit | MyUnit MyUnit | Pair (Tuple Int Number) @@ -118,6 +122,8 @@ instance encodeJsonTestSum :: EncodeJson TestSum where NT a -> E.encodeTagged "NT" a E.value NTRecord a -> E.encodeTagged "NTRecord" a E.value TwoFields a -> E.encodeTagged "TwoFields" a E.value + Set a -> E.encodeTagged "Set" a E.value + Map a -> E.encodeTagged "Map" a E.value Unit a -> E.encodeTagged "Unit" a E.unit MyUnit a -> E.encodeTagged "MyUnit" a E.value Pair a -> E.encodeTagged "Pair" a (E.tuple (E.value >/\< E.value)) @@ -146,6 +152,8 @@ instance decodeJsonTestSum :: DecodeJson TestSum where , "NT" /\ D.content (NT <$> D.value) , "NTRecord" /\ D.content (NTRecord <$> D.value) , "TwoFields" /\ D.content (TwoFields <$> D.value) + , "Set" /\ D.content (Set <$> D.value) + , "Map" /\ D.content (Map <$> D.value) , "Unit" /\ D.content (Unit <$> D.unit) , "MyUnit" /\ D.content (MyUnit <$> D.value) , "Pair" /\ D.content (Pair <$> (D.tuple (D.value D.value))) @@ -225,6 +233,16 @@ _TwoFields = prism' TwoFields case _ of (TwoFields a) -> Just a _ -> Nothing +_Set :: Prism' TestSum (Set Int) +_Set = prism' Set case _ of + (Set a) -> Just a + _ -> Nothing + +_Map :: Prism' TestSum (Map String Int) +_Map = prism' Map case _ of + (Map a) -> Just a + _ -> Nothing + _Unit :: Prism' TestSum Unit _Unit = prism' Unit case _ of (Unit a) -> Just a From 569fc664427a14b4352edeed015baa98915f4584 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Thu, 4 Nov 2021 15:07:24 -0400 Subject: [PATCH 049/111] Update json-helpers dependency --- test/RoundTrip/app/packages.dhall | 3 ++- test/RoundTrip/app/src/RoundTrip/Types.purs | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall index a7044d0e..bac5b55b 100644 --- a/test/RoundTrip/app/packages.dhall +++ b/test/RoundTrip/app/packages.dhall @@ -14,6 +14,7 @@ in upstream // { , "effect" , "either" , "enums" + , "foldable-traversable" , "foreign-object" , "maybe" , "newtype" @@ -30,6 +31,6 @@ in upstream // { , "typelevel-prelude" ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "895db00f2fe97ee56b866bf1582b303d029c216a" + , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" } } diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 7313b477..5fda6a40 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -123,7 +123,7 @@ instance encodeJsonTestSum :: EncodeJson TestSum where NTRecord a -> E.encodeTagged "NTRecord" a E.value TwoFields a -> E.encodeTagged "TwoFields" a E.value Set a -> E.encodeTagged "Set" a E.value - Map a -> E.encodeTagged "Map" a E.value + Map a -> E.encodeTagged "Map" a (E.dictionary E.value E.value) Unit a -> E.encodeTagged "Unit" a E.unit MyUnit a -> E.encodeTagged "MyUnit" a E.value Pair a -> E.encodeTagged "Pair" a (E.tuple (E.value >/\< E.value)) @@ -153,7 +153,7 @@ instance decodeJsonTestSum :: DecodeJson TestSum where , "NTRecord" /\ D.content (NTRecord <$> D.value) , "TwoFields" /\ D.content (TwoFields <$> D.value) , "Set" /\ D.content (Set <$> D.value) - , "Map" /\ D.content (Map <$> D.value) + , "Map" /\ D.content (Map <$> (D.dictionary D.value D.value)) , "Unit" /\ D.content (Unit <$> D.unit) , "MyUnit" /\ D.content (MyUnit <$> D.value) , "Pair" /\ D.content (Pair <$> (D.tuple (D.value D.value))) From 7d3b750a41636c216c89e70d3f0e620bfe927283 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Thu, 20 Jan 2022 15:10:46 -0500 Subject: [PATCH 050/111] Add ormolu to nix shell --- flake.nix | 69 +++++++++++++++++++++++++++++-------------------------- 1 file changed, 36 insertions(+), 33 deletions(-) diff --git a/flake.nix b/flake.nix index 0b21af6c..67527868 100644 --- a/flake.nix +++ b/flake.nix @@ -9,39 +9,42 @@ }; outputs = { self, nixpkgs, flake-utils, haskellNix, easy-ps }: flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system: - let - overlays = [ haskellNix.overlay - (final: prev: { - # This overlay adds our project to pkgs - purescript-bridge = - final.haskell-nix.project' { - src = ./.; - compiler-nix-name = "ghc8107"; - }; - }) - ]; - pkgs = import nixpkgs { inherit system overlays; inherit (haskellNix) config; }; - flake = pkgs.purescript-bridge.flake {}; - in flake // { - # Built by `nix build .` - defaultPackage = flake.packages."purescript-bridge:test:purescript-bridge"; - devShell = pkgs.purescript-bridge.shellFor { - withHoogle = true; - tools = { - cabal = "latest"; - hlint = "latest"; - haskell-language-server = "latest"; - }; + let + overlays = [ + haskellNix.overlay + (final: prev: { + # This overlay adds our project to pkgs + purescript-bridge = + final.haskell-nix.project' { + src = ./.; + compiler-nix-name = "ghc8107"; + }; + }) + ]; + pkgs = import nixpkgs { inherit system overlays; inherit (haskellNix) config; }; + flake = pkgs.purescript-bridge.flake { }; + in + flake // { + # Built by `nix build .` + defaultPackage = flake.packages."purescript-bridge:test:purescript-bridge"; + devShell = pkgs.purescript-bridge.shellFor { + withHoogle = true; + tools = { + cabal = "latest"; + hlint = "latest"; + haskell-language-server = "latest"; + }; - exactDeps = true; + exactDeps = true; - buildInputs = with pkgs; with import easy-ps { inherit pkgs; }; [ - ghcid - nixpkgs-fmt - purs - purescript-language-server - spago - ]; - }; - }); + buildInputs = with pkgs; with import easy-ps { inherit pkgs; }; [ + ghcid + nixpkgs-fmt + purs + purescript-language-server + spago + haskellPackages.ormolu + ]; + }; + }); } From b4c4069031b9f4ec9d43d019700883d6a1c1418e Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Thu, 20 Jan 2022 16:21:13 -0500 Subject: [PATCH 051/111] Add support for custom instances --- src/Language/PureScript/Bridge.hs | 117 ++-- src/Language/PureScript/Bridge/Printer.hs | 618 +++++++++++--------- src/Language/PureScript/Bridge/SumType.hs | 170 +++--- test/RoundTrip/app/src/RoundTrip/Types.purs | 138 ++--- test/Spec.hs | 294 ++++++---- 5 files changed, 758 insertions(+), 579 deletions(-) diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index 47abc2e2..523c894f 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -1,29 +1,32 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Bridge - ( bridgeSumType - , defaultBridge - , module Bridge - , writePSTypes - , writePSTypesWith - , defaultSwitch - , noLenses - , genLenses - ) where + ( bridgeSumType, + defaultBridge, + module Bridge, + writePSTypes, + writePSTypesWith, + defaultSwitch, + noLenses, + genLenses, + ) +where -import Control.Applicative -import qualified Data.Map as M -import qualified Data.Set as Set -import qualified Data.Text.IO as T - -import Language.PureScript.Bridge.Builder as Bridge -import Language.PureScript.Bridge.CodeGenSwitches as Switches -import Language.PureScript.Bridge.Primitives as Bridge -import Language.PureScript.Bridge.Printer as Bridge -import Language.PureScript.Bridge.SumType as Bridge -import Language.PureScript.Bridge.Tuple as Bridge -import Language.PureScript.Bridge.TypeInfo as Bridge +import Control.Applicative +import Control.Lens (over, traversed) +import qualified Data.Map as M +import qualified Data.Set as Set +import qualified Data.Text.IO as T +import Language.PureScript.Bridge.Builder as Bridge +import Language.PureScript.Bridge.CodeGenSwitches as Switches +import Language.PureScript.Bridge.Primitives as Bridge +import Language.PureScript.Bridge.Printer as Bridge +import Language.PureScript.Bridge.SumType as Bridge +import Language.PureScript.Bridge.Tuple as Bridge +import Language.PureScript.Bridge.TypeInfo as Bridge -- | Your entry point to this library and quite likely all you will need. -- Make sure all your types derive `Generic` and `Typeable`. @@ -89,7 +92,7 @@ writePSTypes = writePSTypesWith Switches.defaultSwitch -- == /WARNING/: -- This function overwrites files - make backups or use version control! writePSTypesWith :: - Switches.Switch -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () + Switches.Switch -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypesWith switch root bridge sts = do mapM_ (printModule settings root) modules T.putStrLn @@ -103,8 +106,8 @@ writePSTypesWith switch root bridge sts = do packages = sumTypesToNeededPackages bridged <> Set.filter - (const $ Switches.generateLenses settings) - (Set.singleton "purescript-profunctor-lenses") + (const $ Switches.generateLenses settings) + (Set.singleton "purescript-profunctor-lenses") -- | Translate all 'TypeInfo' values in a 'SumType' to PureScript types. -- @@ -115,14 +118,32 @@ writePSTypesWith switch root bridge sts = do -- > bridgeSumType (buildBridge defaultBridge) (mkSumType @Foo) bridgeSumType :: FullBridge -> SumType 'Haskell -> SumType 'PureScript bridgeSumType br (SumType t cs is) = - SumType (br t) (map (bridgeConstructor br) cs) $ is <> extraInstances - where - extraInstances - | not (null cs) && all isNullary cs = [Enum, Bounded] - | otherwise = [] - isNullary (DataConstructor _ args) = args == Nullary - - + SumType (br t) (map (bridgeConstructor br) cs) $ bridgeInstance <$> (is <> extraInstances) + where + bridgeInstance (Custom CustomInstance {..}) = + Custom $ + CustomInstance + (br <$> _customConstraints) + (br _customHead) + case _customImplementation of + Derive -> Derive + DeriveNewtype -> DeriveNewtype + Explicit members -> Explicit $ bridgeMember <$> members + bridgeInstance Bounded = Bounded + bridgeInstance Enum = Enum + bridgeInstance Json = Json + bridgeInstance GenericShow = GenericShow + bridgeInstance Functor = Functor + bridgeInstance Eq = Eq + bridgeInstance Eq1 = Eq1 + bridgeInstance Ord = Ord + bridgeInstance Generic = Generic + bridgeInstance Newtype = Newtype + bridgeMember = over (memberDependencies . traversed) br + extraInstances + | not (null cs) && all isNullary cs = [Enum, Bounded] + | otherwise = [] + isNullary (DataConstructor _ args) = args == Nullary -- | Default bridge for mapping primitive/common types: -- You can append your own bridges like this: @@ -133,23 +154,23 @@ bridgeSumType br (SumType t cs is) = -- "Language.PureScript.Bridge.Tuple". defaultBridge :: BridgePart defaultBridge = - textBridge <|> - stringBridge <|> - listBridge <|> - maybeBridge <|> - eitherBridge <|> - boolBridge <|> - intBridge <|> - doubleBridge <|> - tupleBridge <|> - unitBridge <|> - mapBridge <|> - setBridge <|> - noContentBridge + textBridge + <|> stringBridge + <|> listBridge + <|> maybeBridge + <|> eitherBridge + <|> boolBridge + <|> intBridge + <|> doubleBridge + <|> tupleBridge + <|> unitBridge + <|> mapBridge + <|> setBridge + <|> noContentBridge -- | Translate types in a constructor. bridgeConstructor :: - FullBridge -> DataConstructor 'Haskell -> DataConstructor 'PureScript + FullBridge -> DataConstructor 'Haskell -> DataConstructor 'PureScript bridgeConstructor _ (DataConstructor name Nullary) = DataConstructor name Nullary bridgeConstructor br (DataConstructor name (Normal infos)) = @@ -159,5 +180,5 @@ bridgeConstructor br (DataConstructor name (Record record)) = -- | Translate types in a record entry. bridgeRecordEntry :: - FullBridge -> RecordEntry 'Haskell -> RecordEntry 'PureScript + FullBridge -> RecordEntry 'Haskell -> RecordEntry 'PureScript bridgeRecordEntry br (RecordEntry label value) = RecordEntry label $ br value diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 6e1c6995..a7aac7fa 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -1,80 +1,113 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Bridge.Printer where -import Control.Lens (to,(^.), (%~), (<>~)) -import Control.Monad (unless) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, catMaybes, fromMaybe) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches -import Language.PureScript.Bridge.SumType (DataConstructor (..), - Instance (..), - RecordEntry (..), - DataConstructorArgs (..), - SumType (SumType), - getUsedTypes, - nootype, recLabel, - recValue, - _recLabel, sigConstructor) -import Language.PureScript.Bridge.TypeInfo (Language (PureScript), - PSType, TypeInfo (TypeInfo), - _typeModule, - _typeName, - _typePackage, - _typeParameters, typeName, flattenTypeInfo) - -import System.Directory (createDirectoryIfMissing, - doesDirectoryExist) -import System.FilePath (joinPath, - takeDirectory, - ()) -import Text.PrettyPrint.Leijen.Text (Doc, - comma, - displayTStrict, - hsep, indent, - line, lparen, - parens, punctuate, - renderPretty, - rparen, - textStrict, vsep, - (<+>), hang, dquotes, char, backslash, nest, linebreak, lbrace, rbrace, softline, lbracket, rbracket, colon) +import Control.Arrow ((&&&)) +import Control.Lens (to, (%~), (<>~), (^.)) +import Control.Monad (unless) +import Data.Char (isLower) +import Data.Function (on, (&)) +import Data.List (groupBy, nubBy, sortBy) +import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Char (isLower, toLower) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.PSTypes (psUnit) -import Control.Arrow ((&&&)) -import Data.Function ((&), on) -import Data.List (nubBy, sortBy, groupBy) +import Language.PureScript.Bridge.SumType + ( CustomInstance (..), + DataConstructor (..), + DataConstructorArgs (..), + Instance (..), + InstanceImplementation (..), + InstanceMember (..), + PSInstance, + RecordEntry (..), + SumType (SumType), + getUsedTypes, + nootype, + recLabel, + recValue, + sigConstructor, + _recLabel, + ) +import Language.PureScript.Bridge.TypeInfo + ( Language (PureScript), + PSType, + TypeInfo (TypeInfo), + flattenTypeInfo, + typeName, + _typeModule, + _typeName, + _typePackage, + _typeParameters, + ) +import System.Directory + ( createDirectoryIfMissing, + doesDirectoryExist, + ) +import System.FilePath + ( joinPath, + takeDirectory, + (), + ) +import Text.PrettyPrint.Leijen.Text + ( Doc, + backslash, + char, + colon, + comma, + displayTStrict, + dquotes, + hang, + hsep, + indent, + lbrace, + lbracket, + line, + linebreak, + lparen, + nest, + parens, + punctuate, + rbrace, + rbracket, + renderPretty, + rparen, + softline, + textStrict, + vsep, + (<+>), + ) renderText :: Doc -> Text renderText = T.replace " \n" "\n" . displayTStrict . renderPretty 0.4 200 -data Module (lang :: Language) = - PSModule - { psModuleName :: !Text - , psImportLines :: !ImportLines - , psQualifiedImports :: !(Map Text Text) - , psTypes :: ![SumType lang] - } +data Module (lang :: Language) = PSModule + { psModuleName :: !Text, + psImportLines :: !ImportLines, + psQualifiedImports :: !(Map Text Text), + psTypes :: ![SumType lang] + } deriving (Show) type PSModule = Module 'PureScript -data ImportLine = - ImportLine - { importModule :: !Text - , importTypes :: !(Set Text) - } +data ImportLine = ImportLine + { importModule :: !Text, + importTypes :: !(Set Text) + } deriving (Show) type Modules = Map Text PSModule @@ -86,27 +119,27 @@ sumTypesToModules = foldr (Map.unionWith unionModules) Map.empty . fmap sumTypeT unionModules :: PSModule -> PSModule -> PSModule unionModules m1 m2 = - m1 - { psImportLines = unionImportLines (psImportLines m1) (psImportLines m2) - , psTypes = psTypes m1 <> psTypes m2 - } + m1 + { psImportLines = unionImportLines (psImportLines m1) (psImportLines m2), + psTypes = psTypes m1 <> psTypes m2 + } sumTypeToModule :: SumType 'PureScript -> Modules sumTypeToModule st@(SumType t _ is) = Map.singleton (_typeModule t) $ PSModule - { psModuleName = _typeModule t - , psImportLines = + { psModuleName = _typeModule t, + psImportLines = dropEmpty $ dropPrelude $ dropPrim $ dropSelf $ unionImportLines (typesToImportLines (getUsedTypes st)) - (instancesToImportLines is) - , psQualifiedImports = instancesToQualifiedImports is - , psTypes = [st] + (instancesToImportLines is), + psQualifiedImports = instancesToQualifiedImports is, + psTypes = [st] } where dropEmpty = Map.delete "" @@ -122,7 +155,7 @@ unionImportLines = Map.unionWith unionImportLine unionImportLine :: ImportLine -> ImportLine -> ImportLine unionImportLine l1 l2 = - l1 { importTypes = Set.union (importTypes l1) (importTypes l2) } + l1 {importTypes = Set.union (importTypes l1) (importTypes l2)} typesToImportLines :: Set PSType -> ImportLines typesToImportLines = @@ -133,26 +166,25 @@ typeToImportLines t = unionImportLines (typesToImportLines $ Set.fromList (_typeParameters t)) $ importsFromList [ImportLine (_typeModule t) (Set.singleton (_typeName t))] -instancesToQualifiedImports :: [Instance] -> Map Text Text +instancesToQualifiedImports :: [PSInstance] -> Map Text Text instancesToQualifiedImports = foldr unionQualifiedImports Map.empty . fmap instanceToQualifiedImports -instancesToImportLines :: [Instance] -> ImportLines +instancesToImportLines :: [PSInstance] -> ImportLines instancesToImportLines = foldr unionImportLines Map.empty . fmap instanceToImportLines -instanceToImportLines :: Instance -> ImportLines +instanceToImportLines :: PSInstance -> ImportLines instanceToImportLines GenericShow = - importsFromList [ ImportLine "Data.Show.Generic" $ Set.singleton "genericShow" ] + importsFromList [ImportLine "Data.Show.Generic" $ Set.singleton "genericShow"] instanceToImportLines Json = importsFromList - [ ImportLine "Control.Lazy" $ Set.singleton "defer" - , ImportLine "Data.Argonaut.Core" $ Set.singleton "jsonNull" - , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["()", "()", "()"] - , ImportLine "Data.Argonaut.Encode" $ Set.singleton "encodeJson" - , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["(>$<)", "(>/\\<)"] - , ImportLine "Data.Newtype" $ Set.singleton "unwrap" - , ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" + [ ImportLine "Control.Lazy" $ Set.singleton "defer", + ImportLine "Data.Argonaut" $ Set.fromList ["encodeJson", "jsonNull"], + ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["()", "()", "()"], + ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["(>$<)", "(>/\\<)"], + ImportLine "Data.Newtype" $ Set.singleton "unwrap", + ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" ] instanceToImportLines Enum = importsFromList @@ -164,12 +196,12 @@ instanceToImportLines Bounded = ] instanceToImportLines _ = Map.empty -instanceToQualifiedImports :: Instance -> Map Text Text +instanceToQualifiedImports :: PSInstance -> Map Text Text instanceToQualifiedImports Json = Map.fromList - [ ("Data.Argonaut.Decode.Aeson", "D") - , ("Data.Argonaut.Encode.Aeson", "E") - , ("Data.Map", "Map") + [ ("Data.Argonaut.Decode.Aeson", "D"), + ("Data.Argonaut.Encode.Aeson", "E"), + ("Data.Map", "Map") ] instanceToQualifiedImports _ = Map.empty @@ -205,17 +237,18 @@ sumTypeToNeededPackages st = moduleToText :: Switches.Settings -> Module 'PureScript -> Text moduleToText settings m = - renderText $ vsep $ - [ "-- File auto generated by purescript-bridge! --" - , "module" <+> textStrict (psModuleName m) <+> "where" <> linebreak - , "import Prelude" <> linebreak - , vsep - ( (importLineToText <$> allImports) - <> (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) - ) + renderText $ + vsep $ + [ "-- File auto generated by purescript-bridge! --", + "module" <+> textStrict (psModuleName m) <+> "where" <> linebreak, + "import Prelude" <> linebreak, + vsep + ( (importLineToText <$> allImports) + <> (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) + ) <> linebreak - ] - <> punctuate (line <> line <> dashes <> line) (sumTypeToDocs settings =<< psTypes m) + ] + <> punctuate (line <> line <> dashes <> line) (sumTypeToDocs settings =<< psTypes m) where otherImports = importsFromList @@ -225,20 +258,20 @@ moduleToText settings m = genericsImports :: [ImportLine] genericsImports = - [ ImportLine "Data.Generic.Rep" $ Set.singleton "class Generic" ] + [ImportLine "Data.Generic.Rep" $ Set.singleton "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'", "iso", "prism'"] - , ImportLine "Data.Lens.Record" $ Set.fromList ["prop"] - , ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"] - , ImportLine "Type.Proxy" $ Set.fromList ["Proxy(Proxy)"] + [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"], + ImportLine "Data.Lens" $ + Set.fromList ["Iso'", "Prism'", "Lens'", "iso", "prism'"], + ImportLine "Data.Lens.Record" $ Set.fromList ["prop"], + ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"], + ImportLine "Type.Proxy" $ Set.fromList ["Proxy(Proxy)"] ] | otherwise = - [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] ] + [ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"]] qualifiedImportToText :: Text -> Text -> Doc qualifiedImportToText m q = hsep ["import", textStrict m, "as", textStrict q] @@ -246,17 +279,17 @@ qualifiedImportToText m q = hsep ["import", textStrict m, "as", textStrict q] importLineToText :: ImportLine -> Doc importLineToText l = hsep ["import", textStrict $ importModule l, encloseHsep lparen rparen comma typeList] - where - typeList = - map (textStrict . last) + where + typeList = + map (textStrict . last) . groupBy ((==) `on` importedType) . sortBy importOrder . Set.toList $ importTypes l - importOrder imp1 imp2 - | T.isPrefixOf "class" imp1 = if T.isPrefixOf "class" imp2 then compare imp1 imp2 else LT - | otherwise = compare imp1 imp2 - importedType imp = fromMaybe imp $ T.stripSuffix "(..)" imp + importOrder imp1 imp2 + | T.isPrefixOf "class" imp1 = if T.isPrefixOf "class" imp2 then compare imp1 imp2 else LT + | otherwise = compare imp1 imp2 + importedType imp = fromMaybe imp $ T.stripSuffix "(..)" imp sumTypeToDocs :: Switches.Settings -> SumType 'PureScript -> [Doc] sumTypeToDocs settings st @@ -274,19 +307,20 @@ sumTypeToTypeDecls st@(SumType t cs _) = keyword <+> typeInfoToDecl t <+> encloseVsep "=" mempty "|" (constructorToDoc <$> cs) typeInfoToDecl :: PSType -> Doc -typeInfoToDecl (TypeInfo _ _ name params) = +typeInfoToDecl (TypeInfo _ _ name params) = hsep $ textStrict name : (typeInfoToDoc <$> params) typeInfoToDoc :: PSType -> Doc -typeInfoToDoc t@(TypeInfo _ _ _ params) = +typeInfoToDoc t@(TypeInfo _ _ _ params) = (if null params then id else parens) $ typeInfoToDecl t constructorToDoc :: DataConstructor 'PureScript -> Doc constructorToDoc (DataConstructor n args) = - hsep $ textStrict n : case args of - Nullary -> [] - Normal ts -> NE.toList $ typeInfoToDoc <$> ts - Record rs -> [vrecord $ fieldSignatures rs] + hsep $ + textStrict n : case args of + Nullary -> [] + Normal ts -> NE.toList $ typeInfoToDoc <$> ts + Record rs -> [vrecord $ fieldSignatures rs] -- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. @@ -297,49 +331,74 @@ instances st@(SumType t _ is) = go <$> is mkConstraints getConstraints = case getConstraints t of [] -> [] constraints -> [encloseHsep lparen rparen comma (typeInfoToDecl <$> constraints), "=>"] - mkInstance name getConstraints ty methods = + mkInstance instanceHead getConstraints methods = vsep [ hsep - [ "instance" - , textStrict $ T.cons (toLower $ T.head name) (T.tail name) <> _typeName ty - , "::" - , hsep $ mkConstraints getConstraints <> [typeInfoToDecl $ mkType name [ty]] - , "where" - ] - , indent 2 $ vsep methods + [ "instance", + hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead], + "where" + ], + indent 2 $ vsep methods + ] + mkDerivedInstance instanceHead getConstraints = + hsep + [ "derive instance", + hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] ] - mkDerivedInstance name getConstraints params ty = - hsep $ - [ "derive instance" - , textStrict $ T.cons (toLower $ T.head name) (T.tail name) <> _typeName ty - , "::" - , hsep $ mkConstraints getConstraints <> [typeInfoToDecl $ mkType name [ty]] + mkDerivedNewtypeInstance instanceHead getConstraints = + hsep + [ "derive newtype instance", + hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] ] - <> params toKind1 (TypeInfo p m n []) = TypeInfo p m n [] toKind1 (TypeInfo p m n ps) = TypeInfo p m n $ init ps - go :: Instance -> Doc - go Bounded = mkInstance "Bounded" (const []) t - [ "bottom = genericBottom" - , "top = genericTop" - ] - go Enum = mkInstance "Enum" (const []) t - [ "succ = genericSucc" - , "pred = genericPred" - ] - go Json = vsep $ punctuate line - [ mkInstance "EncodeJson" encodeJsonConstraints t - [ "encodeJson = defer \\_ ->" <+> sumTypeToEncode st ] - , mkInstance "DecodeJson" decodeJsonConstraints t - [ hang 2 $ "decodeJson = defer \\_ -> D.decode" <+> sumTypeToDecode st ] + go :: PSInstance -> Doc + go (Custom CustomInstance {..}) = case _customImplementation of + Derive -> mkDerivedInstance _customHead (const _customConstraints) + DeriveNewtype -> mkDerivedNewtypeInstance _customHead (const _customConstraints) + Explicit members -> mkInstance _customHead (const _customConstraints) $ memberToMethod <$> members + go Bounded = + mkInstance + (mkType "Bounded" [t]) + (const []) + [ "bottom = genericBottom", + "top = genericTop" + ] + go Enum = + mkInstance + (mkType "Enum" [t]) + (const []) + [ "succ = genericSucc", + "pred = genericPred" + ] + go Json = + vsep $ + punctuate + line + [ mkInstance + (mkType "EncodeJson" [t]) + encodeJsonConstraints + ["encodeJson = defer \\_ ->" <+> sumTypeToEncode st], + mkInstance + (mkType "DecodeJson" [t]) + decodeJsonConstraints + [hang 2 $ "decodeJson = defer \\_ -> D.decode" <+> sumTypeToDecode st] + ] + go GenericShow = mkInstance (mkType "Show" [t]) showConstraints ["show a = genericShow a"] + go Functor = mkDerivedInstance (mkType "Functor" [toKind1 t]) (const []) + go Eq = mkDerivedInstance (mkType "Eq" [t]) eqConstraints + go Eq1 = mkDerivedInstance (mkType "Eq1" [toKind1 t]) (const []) + go Ord = mkDerivedInstance (mkType "Ord" [t]) ordConstraints + go Generic = mkDerivedInstance (mkType "Generic" [t, mkType "_" []]) (const []) + go Newtype = mkDerivedInstance (mkType "Newtype" [t, mkType "_" []]) (const []) + +memberToMethod :: InstanceMember 'PureScript -> Doc +memberToMethod InstanceMember {..} = + hang 2 $ + hsep + [ hsep $ textStrict <$> _memberName : _memberBindings <> ["="], + vsep $ textStrict <$> T.lines _memberBody ] - go GenericShow = mkInstance "Show" showConstraints t [ "show a = genericShow a" ] - go Functor = mkDerivedInstance "Functor" (const []) [] $ toKind1 t - go Eq = mkDerivedInstance "Eq" eqConstraints [] t - go Eq1 = mkDerivedInstance "Eq1" (const []) [] $ toKind1 t - go Ord = mkDerivedInstance "Ord" ordConstraints [] t - go Generic = mkDerivedInstance "Generic" (const []) ["_"] t - go Newtype = mkDerivedInstance "Newtype" (const []) ["_"] t constrainWith :: Text -> PSType -> [PSType] constrainWith name = map (mkType name . pure) . typeParams @@ -369,33 +428,36 @@ sumTypeToEncode (SumType _ cs _) case cs of [dc@(DataConstructor _ args)] -> hsep - ["E.encode $" - , if isJust (nootype [dc]) - then "unwrap" - else parens $ case_of [(constructorPattern dc, constructor args)] - , hang 2 $ ">$<" <+> nest 2 (argsToEncode args) - ] + [ "E.encode $", + if isJust (nootype [dc]) + then "unwrap" + else parens $ case_of [(constructorPattern dc, constructor args)], + hang 2 $ ">$<" <+> nest 2 (argsToEncode args) + ] _ -> case_of (constructorToEncode <$> cs) where constructorToEncode c@(DataConstructor name args) = - ( constructorPattern c - , case args of + ( constructorPattern c, + case args of Nullary -> "encodeJson { tag:" <+> dquotes (textStrict name) <> ", contents: jsonNull }" - Normal as -> "E.encodeTagged" + Normal as -> + "E.encodeTagged" <+> dquotes (textStrict name) <+> normalExpr as <+> argsToEncode args Record rs - | any ((== "tag") . _recLabel) rs -> "E.encodeTagged" - <+> dquotes (textStrict name) - <+> hrecord (fields rs) - <+> argsToEncode args - | otherwise -> hsep - [ "encodeJson" - , vrecord - $ ("tag:" <+> dquotes (textStrict name)) - : (recordFieldToJson <$> NE.toList rs) - ] + | any ((== "tag") . _recLabel) rs -> + "E.encodeTagged" + <+> dquotes (textStrict name) + <+> hrecord (fields rs) + <+> argsToEncode args + | otherwise -> + hsep + [ "encodeJson", + vrecord $ + ("tag:" <+> dquotes (textStrict name)) : + (recordFieldToJson <$> NE.toList rs) + ] ) recordFieldToJson (RecordEntry name t) = textStrict name @@ -409,11 +471,11 @@ sumTypeToEncode (SumType _ cs _) parens $ "E.tuple" <+> encloseHsep lparen rparen " >/\\<" (typeToEncode <$> NE.toList ts) argsToEncode (Record rs) = parens $ "E.record" <> softline <> vrecord (fieldSignatures $ fieldEncoder <$> rs) - where - fieldEncoder r = - r - & recValue %~ mkType "_" . pure - & recLabel <>~ renderText (":" <+> typeToEncode (_recValue r)) + where + fieldEncoder r = + r + & recValue %~ mkType "_" . pure + & recLabel <>~ renderText (":" <+> typeToEncode (_recValue r)) flattenTuple :: [PSType] -> [PSType] flattenTuple [] = [] @@ -423,37 +485,42 @@ flattenTuple (h : t) = h : flattenTuple t typeToEncode :: PSType -> Doc typeToEncode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = "E.unit" -typeToEncode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = parens $ - "E.maybe" <+> typeToEncode t -typeToEncode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = parens $ - "E.either" <+> typeToEncode l <+> typeToEncode r -typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ - "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) -typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ - "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) -typeToEncode (TypeInfo "purescript-ordered-collections" "Data.Map" "Map" [k, v]) = parens $ - "E.dictionary" <+> typeToEncode k <+> typeToEncode v +typeToEncode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = + parens $ + "E.maybe" <+> typeToEncode t +typeToEncode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = + parens $ + "E.either" <+> typeToEncode l <+> typeToEncode r +typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = + parens $ + "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) +typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = + parens $ + "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) +typeToEncode (TypeInfo "purescript-ordered-collections" "Data.Map" "Map" [k, v]) = + parens $ + "E.dictionary" <+> typeToEncode k <+> typeToEncode v typeToEncode _ = "E.value" - sumTypeToDecode :: SumType 'PureScript -> Doc sumTypeToDecode (SumType _ cs _) | isEnum cs = "D.enum" sumTypeToDecode (SumType _ [c] _) = "$" <+> constructorToDecode False c -sumTypeToDecode (SumType t cs _) = line <> - hsep - [ "$ D.sumType" - , t ^. typeName . to textStrict . to dquotes - , "$ Map.fromFoldable" - , encloseVsep lbracket rbracket comma (constructorToTagged <$> cs) - ] - where - constructorToTagged dc = hsep - [ dc ^. sigConstructor . to textStrict . to dquotes - , "/\\" - , constructorToDecode True dc +sumTypeToDecode (SumType t cs _) = + line + <> hsep + [ "$ D.sumType", + t ^. typeName . to textStrict . to dquotes, + "$ Map.fromFoldable", + encloseVsep lbracket rbracket comma (constructorToTagged <$> cs) ] - + where + constructorToTagged dc = + hsep + [ dc ^. sigConstructor . to textStrict . to dquotes, + "/\\", + constructorToDecode True dc + ] constructorToDecode :: Bool -> DataConstructor 'PureScript -> Doc constructorToDecode True (DataConstructor name Nullary) = @@ -465,46 +532,53 @@ constructorToDecode True dc@(DataConstructor _ (Normal _)) = constructorToDecode False (DataConstructor name (Normal (a :| []))) = parens $ textStrict name <+> "<$>" <+> typeToDecode a constructorToDecode False (DataConstructor name (Normal as)) = - parens $ "D.tuple" - <+> "$" - <+> textStrict name - <+> encloseHsep "" mempty " " (typeToDecode <$> NE.toList as) + parens $ + "D.tuple" + <+> "$" + <+> textStrict name + <+> encloseHsep "" mempty " " (typeToDecode <$> NE.toList as) constructorToDecode True dc@(DataConstructor name (Record rs)) | any ((== "tag") . _recLabel) rs = "D.content" <+> constructorToDecode False dc - | otherwise = parens $ textStrict name - <+> "<$> D.object" - <+> dquotes (textStrict name) - <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) - where - fieldDecoder r = - r - & recValue %~ mkType "_" . pure - & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) + | otherwise = + parens $ + textStrict name + <+> "<$> D.object" + <+> dquotes (textStrict name) + <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) + where + fieldDecoder r = + r + & recValue %~ mkType "_" . pure + & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) constructorToDecode False (DataConstructor name (Record rs)) = - parens $ textStrict name - <+> "<$> D.record" - <+> dquotes (textStrict name) - <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) - where - fieldDecoder r = - r - & recValue %~ mkType "_" . pure - & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) + parens $ + textStrict name + <+> "<$> D.record" + <+> dquotes (textStrict name) + <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) + where + fieldDecoder r = + r + & recValue %~ mkType "_" . pure + & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) typeToDecode :: PSType -> Doc typeToDecode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = "D.unit" -typeToDecode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = parens $ - "D.maybe" <+> typeToDecode t -typeToDecode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = parens $ - "D.either" <+> typeToDecode l <+> typeToDecode r -typeToDecode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = parens $ - "D.tuple" <+> encloseHsep lparen rparen " " (typeToDecode <$> flattenTuple ts) -typeToDecode (TypeInfo "purescript-ordered-collections" "Data.Map" "Map" [k, v]) = parens $ - "D.dictionary" <+> typeToDecode k <+> typeToDecode v +typeToDecode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = + parens $ + "D.maybe" <+> typeToDecode t +typeToDecode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = + parens $ + "D.either" <+> typeToDecode l <+> typeToDecode r +typeToDecode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = + parens $ + "D.tuple" <+> encloseHsep lparen rparen " " (typeToDecode <$> flattenTuple ts) +typeToDecode (TypeInfo "purescript-ordered-collections" "Data.Map" "Map" [k, v]) = + parens $ + "D.dictionary" <+> typeToDecode k <+> typeToDecode v typeToDecode _ = "D.value" - sumTypeToOptics :: SumType 'PureScript -> Doc sumTypeToOptics st = vsep $ punctuate line $ constructorOptics st <> recordOptics st @@ -521,7 +595,7 @@ hasUnderscore :: RecordEntry lang -> Bool hasUnderscore (RecordEntry name _) = "_" `T.isPrefixOf` name constructorToOptic :: - Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Doc + Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Doc constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = case (args, hasOtherConstructors) of (Nullary, False) -> iso pName typeInfo psUnit "(const unit)" $ parens ("const" <+> cName) @@ -541,16 +615,16 @@ constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = (Record rs, False) -> newtypeIso pName typeInfo $ recordType rs (Record rs, True) -> prism pName typeInfo (recordType rs) fromExpr toExpr cName - where - fromExpr = parens $ pattern n toExpr - toExpr = "a" + where + fromExpr = parens $ pattern n toExpr + toExpr = "a" where cName = textStrict n pName = "_" <> textStrict n recordType = (`mkType` []) . renderText . hrecord . fieldSignatures typesToRecord :: NonEmpty PSType -> NonEmpty (RecordEntry 'PureScript) -typesToRecord = fmap (uncurry RecordEntry) . NE.zip (T.singleton <$> ['a'..]) +typesToRecord = fmap (uncurry RecordEntry) . NE.zip (T.singleton <$> ['a' ..]) iso :: Doc -> PSType -> PSType -> Doc -> Doc -> Doc iso name fromType toType fromMorph toMorph = @@ -568,10 +642,11 @@ prism name fromType toType previewPattern previewExpr inject = [] [] (mkType "Prism'" [fromType, toType]) - ( "prism'" <+> inject <+> case_of - [ (previewPattern, "Just" <+> previewExpr) - , ("_", "Nothing") - ] + ( "prism'" <+> inject + <+> case_of + [ (previewPattern, "Just" <+> previewExpr), + ("_", "Nothing") + ] ) newtypeIso :: Doc -> PSType -> PSType -> Doc @@ -586,10 +661,11 @@ newtypeIso name fromType toType = recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Doc recordEntryToLens (SumType t _ _) e = if hasUnderscore e - then vsep - [ signature True lensName [] [] $ mkType "Lens'" [t, e ^. recValue] - , lensName <+> "= _Newtype <<< prop" <+> parens ("Proxy :: _" <> dquotes recName) - ] + then + vsep + [ signature True lensName [] [] $ mkType "Lens'" [t, e ^. recValue], + lensName <+> "= _Newtype <<< prop" <+> parens ("Proxy :: _" <> dquotes recName) + ] else mempty where recName = e ^. recLabel . to textStrict @@ -622,7 +698,7 @@ normalExpr (_ :| []) = "a" normalExpr ts = parens . hsep . punctuate " /\\" $ normalLabels ts normalLabels :: NonEmpty PSType -> [Doc] -normalLabels = fmap char . zipWith const ['a'..] . NE.toList +normalLabels = fmap char . zipWith const ['a' ..] . NE.toList recordPattern :: Text -> NonEmpty (RecordEntry 'PureScript) -> Doc recordPattern name = pattern name . hrecord . fields @@ -663,30 +739,31 @@ branch p body = hsep [p, "->", body] lambda :: Doc -> Doc -> Doc lambda variables body = backslash <> branch variables body -signature' :: Doc -> PSType-> Doc +signature' :: Doc -> PSType -> Doc signature' name = signature False name [] [] -signature :: Bool -> Doc -> [PSType] -> [PSType] -> PSType-> Doc +signature :: Bool -> Doc -> [PSType] -> [PSType] -> PSType -> Doc signature topLevel name constraints params ret = hsep $ catMaybes [Just name, Just "::", forAll, constraintsDoc, paramsDoc, Just $ typeInfoToDecl ret] - where - forAll = case (topLevel, allTypes >>= typeParams) of - (False, _) -> Nothing - (_, []) -> Nothing - (_, ps) -> Just $ "forall" <+> hsep (typeInfoToDoc <$> nubBy (on (==) _typeName) ps) <> "." - allTypes = ret : constraints <> params - constraintsDoc = case constraints of - [] -> Nothing - cs -> Just $ hsep ((<+> "=>") . typeInfoToDecl <$> cs) - paramsDoc = case params of - [] -> Nothing - ps -> Just $ hsep ((<+> "->") . typeInfoToDecl <$> ps) + where + forAll = case (topLevel, allTypes >>= typeParams) of + (False, _) -> Nothing + (_, []) -> Nothing + (_, ps) -> Just $ "forall" <+> hsep (typeInfoToDoc <$> nubBy (on (==) _typeName) ps) <> "." + allTypes = ret : constraints <> params + constraintsDoc = case constraints of + [] -> Nothing + cs -> Just $ hsep ((<+> "=>") . typeInfoToDecl <$> cs) + paramsDoc = case params of + [] -> Nothing + ps -> Just $ hsep ((<+> "->") . typeInfoToDecl <$> ps) def :: Doc -> [PSType] -> [(Doc, PSType)] -> PSType -> Doc -> Doc -def name constraints params ret body = vsep - [ signature True name constraints (snd <$> params) ret - , hsep $ name : (fst <$> params) <> ["=", body] - ] +def name constraints params ret body = + vsep + [ signature True name constraints (snd <$> params) ret, + hsep $ name : (fst <$> params) <> ["=", body] + ] mkType :: Text -> [PSType] -> PSType mkType = TypeInfo "" "" @@ -697,13 +774,12 @@ typeParams = filter (isLower . T.head . _typeName) . flattenTypeInfo encloseHsep :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseHsep left right sp ds = case ds of - [] -> left <> right - _ -> left <> hsep (punctuate sp ds) <> right + [] -> left <> right + _ -> left <> hsep (punctuate sp ds) <> right encloseVsep :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseVsep left right sp ds = case ds of - [] -> left <> right + [] -> left <> right [d] -> left <+> d <+> right - _ -> nest 2 $ linebreak <> vsep (zipWith (<+>) (left : repeat (hang 2 sp)) ds <> [right]) - + _ -> nest 2 $ linebreak <> vsep (zipWith (<+>) (left : repeat (hang 2 sp)) ds <> [right]) diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 89d40679..feda0562 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -1,85 +1,63 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} -module Language.PureScript.Bridge.SumType - ( SumType(..) - , argonaut - , mkSumType - , genericShow - , functor - , equal - , equal1 - , order - , DataConstructor(..) - , DataConstructorArgs(..) - , RecordEntry(..) - , Instance(..) - , nootype - , getUsedTypes - , constructorToTypes - , sigConstructor - , sigValues - , sumTypeInfo - , sumTypeConstructors - , recLabel - , recValue - ) where - -import Control.Lens hiding (from, to) -import Data.List (nub) -import Data.Maybe (maybeToList) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable -import Generics.Deriving - -import Language.PureScript.Bridge.TypeInfo +module Language.PureScript.Bridge.SumType where + +import Control.Lens hiding (from, to) +import Data.List (nub) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE +import Data.Maybe (maybeToList) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import Generics.Deriving +import Language.PureScript.Bridge.TypeInfo -- | Generic representation of your Haskell types. -data SumType (lang :: Language) = - SumType (TypeInfo lang) [DataConstructor lang] [Instance] +data SumType (lang :: Language) + = SumType (TypeInfo lang) [DataConstructor lang] [Instance lang] deriving (Show, Eq) --- | TypInfo lens for 'SumType'. +-- | TypeInfo lens for 'SumType'. sumTypeInfo :: - Functor f - => (TypeInfo lang -> f (TypeInfo lang)) - -> SumType lang - -> f (SumType lang) + Functor f => + (TypeInfo lang -> f (TypeInfo lang)) -> + SumType lang -> + f (SumType lang) sumTypeInfo inj (SumType info constrs is) = (\ti -> SumType ti constrs is) <$> inj info -- | DataConstructor lens for 'SumType'. sumTypeConstructors :: - Functor f - => ([DataConstructor lang] -> f [DataConstructor lang]) - -> SumType lang - -> f (SumType lang) + Functor f => + ([DataConstructor lang] -> f [DataConstructor lang]) -> + SumType lang -> + f (SumType lang) sumTypeConstructors inj (SumType info constrs is) = (\cs -> SumType info cs is) <$> inj constrs -- | Create a representation of your sum (and product) types, -- for doing type translations and writing it out to your PureScript modules. mkSumType :: - forall t. (Generic t, Typeable t, GDataConstructor (Rep t)) - => SumType 'Haskell + forall t. + (Generic t, Typeable t, GDataConstructor (Rep t)) => + SumType 'Haskell mkSumType = SumType (mkTypeInfo @t) @@ -89,7 +67,7 @@ mkSumType = constructors = gToConstructors (from (undefined :: t)) -- | Purescript typeclass instances that can be generated for your Haskell types. -data Instance +data Instance (lang :: Language) = Generic | GenericShow | Json @@ -100,11 +78,35 @@ data Instance | Ord | Enum | Bounded + | Custom (CustomInstance lang) deriving (Eq, Show) +type PSInstance = Instance 'PureScript + +data InstanceMember (lang :: Language) = InstanceMember + { _memberName :: Text, + _memberBindings :: [Text], + _memberBody :: Text, + _memberDependencies :: [TypeInfo lang] + } + deriving (Eq, Ord, Show) + +data InstanceImplementation (lang :: Language) + = Derive + | DeriveNewtype + | Explicit [InstanceMember lang] + deriving (Eq, Ord, Show) + +data CustomInstance (lang :: Language) = CustomInstance + { _customConstraints :: [TypeInfo lang], + _customHead :: TypeInfo lang, + _customImplementation :: InstanceImplementation lang + } + deriving (Eq, Ord, Show) + -- | The Purescript typeclass `Newtype` might be derivable if the original -- Haskell type was a simple type wrapper. -nootype :: [DataConstructor lang] -> Maybe Instance +nootype :: [DataConstructor lang] -> Maybe (Instance lang) nootype [DataConstructor _ (Record _)] = Just Newtype nootype [DataConstructor _ (Normal [_])] = Just Newtype nootype _ = Nothing @@ -134,11 +136,11 @@ equal1 (SumType ti dc is) = SumType ti dc . nub $ Eq1 : is order :: SumType t -> SumType t order (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is -data DataConstructor (lang :: Language) = - DataConstructor - { _sigConstructor :: !Text -- ^ e.g. `Left`/`Right` for `Either` - , _sigValues :: !(DataConstructorArgs lang) - } +data DataConstructor (lang :: Language) = DataConstructor + { -- | e.g. `Left`/`Right` for `Either` + _sigConstructor :: !Text, + _sigValues :: !(DataConstructorArgs lang) + } deriving (Show, Eq) data DataConstructorArgs (lang :: Language) @@ -158,11 +160,11 @@ instance Semigroup (DataConstructorArgs lang) where instance Monoid (DataConstructorArgs lang) where mempty = Nullary -data RecordEntry (lang :: Language) = - RecordEntry - { _recLabel :: !Text -- ^ e.g. `runState` for `State` - , _recValue :: !(TypeInfo lang) - } +data RecordEntry (lang :: Language) = RecordEntry + { -- | e.g. `runState` for `State` + _recLabel :: !Text, + _recValue :: !(TypeInfo lang) + } deriving (Show, Eq) class GDataConstructor f where @@ -205,7 +207,7 @@ getUsedTypes :: SumType lang -> Set (TypeInfo lang) getUsedTypes (SumType _ cs is) = foldMap constructorToTypes cs <> foldMap instanceToTypes is constructorToTypes :: - DataConstructor lang -> Set (TypeInfo lang) + DataConstructor lang -> Set (TypeInfo lang) constructorToTypes (DataConstructor _ Nullary) = Set.empty constructorToTypes (DataConstructor _ (Normal [ts])) = Set.fromList $ flattenTypeInfo ts @@ -216,15 +218,15 @@ constructorToTypes (DataConstructor _ (Normal ts)) = constructorToTypes (DataConstructor _ (Record rs)) = Set.fromList . concatMap (flattenTypeInfo . _recValue) $ NE.toList rs -instanceToTypes :: Instance -> Set (TypeInfo lang) +instanceToTypes :: Instance lang -> Set (TypeInfo lang) instanceToTypes Generic = Set.singleton $ TypeInfo "purescript-prelude" "Data.Generic.Rep" "class Generic" [] instanceToTypes GenericShow = Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Show" [] instanceToTypes Json = Set.fromList - [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "class DecodeJson" [] - , TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "class EncodeJson" [] + [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "class DecodeJson" [], + TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "class EncodeJson" [] ] instanceToTypes Newtype = Set.singleton $ TypeInfo "purescript-newtype" "Data.Newtype" "class Newtype" [] @@ -240,8 +242,22 @@ instanceToTypes Enum = Set.singleton $ TypeInfo "purescript-enums" "Data.Enum" "class Enum" [] instanceToTypes Bounded = Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Bounded" [] +instanceToTypes (Custom CustomInstance {..}) = + Set.fromList $ + concatMap flattenTypeInfo $ + _customHead : (_customConstraints <> implementationToTypes _customImplementation) + +implementationToTypes :: InstanceImplementation lang -> [TypeInfo lang] +implementationToTypes (Explicit members) = concatMap _memberDependencies members +implementationToTypes _ = [] -- Lenses: makeLenses ''DataConstructor makeLenses ''RecordEntry + +makeLenses ''CustomInstance + +makeLenses ''InstanceImplementation + +makeLenses ''InstanceMember diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 5fda6a40..d8242be5 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -33,26 +33,26 @@ data TestData = Maybe (Maybe TestSum) | Either (Either (Maybe Int) (Maybe Boolean)) -derive instance eqTestData :: Eq TestData +derive instance Eq TestData -instance showTestData :: Show TestData where +instance Show TestData where show a = genericShow a -derive instance ordTestData :: Ord TestData +derive instance Ord TestData -instance encodeJsonTestData :: EncodeJson TestData where +instance EncodeJson TestData where encodeJson = defer \_ -> case _ of Maybe a -> E.encodeTagged "Maybe" a (E.maybe E.value) Either a -> E.encodeTagged "Either" a (E.either (E.maybe E.value) (E.maybe E.value)) -instance decodeJsonTestData :: DecodeJson TestData where +instance DecodeJson TestData where decodeJson = defer \_ -> D.decode $ D.sumType "TestData" $ Map.fromFoldable [ "Maybe" /\ D.content (Maybe <$> (D.maybe D.value)) , "Either" /\ D.content (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) ] -derive instance genericTestData :: Generic TestData _ +derive instance Generic TestData _ -------------------------------------------------------------------------------- @@ -96,14 +96,14 @@ data TestSum | Recursive TestRecursiveA | Enum TestEnum -derive instance eqTestSum :: Eq TestSum +derive instance Eq TestSum -instance showTestSum :: Show TestSum where +instance Show TestSum where show a = genericShow a -derive instance ordTestSum :: Ord TestSum +derive instance Ord TestSum -instance encodeJsonTestSum :: EncodeJson TestSum where +instance EncodeJson TestSum where encodeJson = defer \_ -> case _ of Nullary -> encodeJson { tag: "Nullary", contents: jsonNull } Bool a -> E.encodeTagged "Bool" a E.value @@ -133,7 +133,7 @@ instance encodeJsonTestSum :: EncodeJson TestSum where Recursive a -> E.encodeTagged "Recursive" a E.value Enum a -> E.encodeTagged "Enum" a E.value -instance decodeJsonTestSum :: DecodeJson TestSum where +instance DecodeJson TestSum where decodeJson = defer \_ -> D.decode $ D.sumType "TestSum" $ Map.fromFoldable [ "Nullary" /\ pure Nullary @@ -164,7 +164,7 @@ instance decodeJsonTestSum :: DecodeJson TestSum where , "Enum" /\ D.content (Enum <$> D.value) ] -derive instance genericTestSum :: Generic TestSum _ +derive instance Generic TestSum _ -------------------------------------------------------------------------------- @@ -289,26 +289,26 @@ data TestRecursiveA = Nil | Recurse TestRecursiveB -derive instance eqTestRecursiveA :: Eq TestRecursiveA +derive instance Eq TestRecursiveA -instance showTestRecursiveA :: Show TestRecursiveA where +instance Show TestRecursiveA where show a = genericShow a -derive instance ordTestRecursiveA :: Ord TestRecursiveA +derive instance Ord TestRecursiveA -instance encodeJsonTestRecursiveA :: EncodeJson TestRecursiveA where +instance EncodeJson TestRecursiveA where encodeJson = defer \_ -> case _ of Nil -> encodeJson { tag: "Nil", contents: jsonNull } Recurse a -> E.encodeTagged "Recurse" a E.value -instance decodeJsonTestRecursiveA :: DecodeJson TestRecursiveA where +instance DecodeJson TestRecursiveA where decodeJson = defer \_ -> D.decode $ D.sumType "TestRecursiveA" $ Map.fromFoldable [ "Nil" /\ pure Nil , "Recurse" /\ D.content (Recurse <$> D.value) ] -derive instance genericTestRecursiveA :: Generic TestRecursiveA _ +derive instance Generic TestRecursiveA _ -------------------------------------------------------------------------------- @@ -326,22 +326,22 @@ _Recurse = prism' Recurse case _ of newtype TestRecursiveB = RecurseB TestRecursiveB -derive instance eqTestRecursiveB :: Eq TestRecursiveB +derive instance Eq TestRecursiveB -instance showTestRecursiveB :: Show TestRecursiveB where +instance Show TestRecursiveB where show a = genericShow a -derive instance ordTestRecursiveB :: Ord TestRecursiveB +derive instance Ord TestRecursiveB -instance encodeJsonTestRecursiveB :: EncodeJson TestRecursiveB where +instance EncodeJson TestRecursiveB where encodeJson = defer \_ -> E.encode $ unwrap >$< E.value -instance decodeJsonTestRecursiveB :: DecodeJson TestRecursiveB where +instance DecodeJson TestRecursiveB where decodeJson = defer \_ -> D.decode $ (RecurseB <$> D.value) -derive instance genericTestRecursiveB :: Generic TestRecursiveB _ +derive instance Generic TestRecursiveB _ -derive instance newtypeTestRecursiveB :: Newtype TestRecursiveB _ +derive instance Newtype TestRecursiveB _ -------------------------------------------------------------------------------- @@ -355,30 +355,30 @@ newtype TestRecord a = TestRecord , _field2 :: a } -derive instance functorTestRecord :: Functor TestRecord +derive instance Functor TestRecord -derive instance eqTestRecord :: (Eq a) => Eq (TestRecord a) +derive instance (Eq a) => Eq (TestRecord a) -instance showTestRecord :: (Show a) => Show (TestRecord a) where +instance (Show a) => Show (TestRecord a) where show a = genericShow a -derive instance ordTestRecord :: (Ord a) => Ord (TestRecord a) +derive instance (Ord a) => Ord (TestRecord a) -instance encodeJsonTestRecord :: (EncodeJson a) => EncodeJson (TestRecord a) where +instance (EncodeJson a) => EncodeJson (TestRecord a) where encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record { _field1: (E.maybe E.value) :: _ (Maybe Int) , _field2: E.value :: _ a }) -instance decodeJsonTestRecord :: (DecodeJson a) => DecodeJson (TestRecord a) where +instance (DecodeJson a) => DecodeJson (TestRecord a) where decodeJson = defer \_ -> D.decode $ (TestRecord <$> D.record "TestRecord" { _field1: (D.maybe D.value) :: _ (Maybe Int) , _field2: D.value :: _ a }) -derive instance genericTestRecord :: Generic (TestRecord a) _ +derive instance Generic (TestRecord a) _ -derive instance newtypeTestRecord :: Newtype (TestRecord a) _ +derive instance Newtype (TestRecord a) _ -------------------------------------------------------------------------------- @@ -395,22 +395,22 @@ field2 = _Newtype <<< prop (Proxy :: _"_field2") newtype TestNewtype = TestNewtype (TestRecord Boolean) -derive instance eqTestNewtype :: Eq TestNewtype +derive instance Eq TestNewtype -instance showTestNewtype :: Show TestNewtype where +instance Show TestNewtype where show a = genericShow a -derive instance ordTestNewtype :: Ord TestNewtype +derive instance Ord TestNewtype -instance encodeJsonTestNewtype :: EncodeJson TestNewtype where +instance EncodeJson TestNewtype where encodeJson = defer \_ -> E.encode $ unwrap >$< E.value -instance decodeJsonTestNewtype :: DecodeJson TestNewtype where +instance DecodeJson TestNewtype where decodeJson = defer \_ -> D.decode $ (TestNewtype <$> D.value) -derive instance genericTestNewtype :: Generic TestNewtype _ +derive instance Generic TestNewtype _ -derive instance newtypeTestNewtype :: Newtype TestNewtype _ +derive instance Newtype TestNewtype _ -------------------------------------------------------------------------------- @@ -421,23 +421,23 @@ _TestNewtype = _Newtype newtype TestNewtypeRecord = TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } -derive instance eqTestNewtypeRecord :: Eq TestNewtypeRecord +derive instance Eq TestNewtypeRecord -instance showTestNewtypeRecord :: Show TestNewtypeRecord where +instance Show TestNewtypeRecord where show a = genericShow a -derive instance ordTestNewtypeRecord :: Ord TestNewtypeRecord +derive instance Ord TestNewtypeRecord -instance encodeJsonTestNewtypeRecord :: EncodeJson TestNewtypeRecord where +instance EncodeJson TestNewtypeRecord where encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record { unTestNewtypeRecord: E.value :: _ TestNewtype }) -instance decodeJsonTestNewtypeRecord :: DecodeJson TestNewtypeRecord where +instance DecodeJson TestNewtypeRecord where decodeJson = defer \_ -> D.decode $ (TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: _ TestNewtype }) -derive instance genericTestNewtypeRecord :: Generic TestNewtypeRecord _ +derive instance Generic TestNewtypeRecord _ -derive instance newtypeTestNewtypeRecord :: Newtype TestNewtypeRecord _ +derive instance Newtype TestNewtypeRecord _ -------------------------------------------------------------------------------- @@ -507,20 +507,20 @@ _Bar = prism' Bar case _ of data TestTwoFields = TestTwoFields Boolean Int -derive instance eqTestTwoFields :: Eq TestTwoFields +derive instance Eq TestTwoFields -instance showTestTwoFields :: Show TestTwoFields where +instance Show TestTwoFields where show a = genericShow a -derive instance ordTestTwoFields :: Ord TestTwoFields +derive instance Ord TestTwoFields -instance encodeJsonTestTwoFields :: EncodeJson TestTwoFields where +instance EncodeJson TestTwoFields where encodeJson = defer \_ -> E.encode $ (case _ of TestTwoFields a b -> (a /\ b)) >$< (E.tuple (E.value >/\< E.value)) -instance decodeJsonTestTwoFields :: DecodeJson TestTwoFields where +instance DecodeJson TestTwoFields where decodeJson = defer \_ -> D.decode $ (D.tuple $ TestTwoFields D.value D.value) -derive instance genericTestTwoFields :: Generic TestTwoFields _ +derive instance Generic TestTwoFields _ -------------------------------------------------------------------------------- @@ -538,26 +538,26 @@ data TestEnum | Sat | Sun -derive instance eqTestEnum :: Eq TestEnum +derive instance Eq TestEnum -instance showTestEnum :: Show TestEnum where +instance Show TestEnum where show a = genericShow a -derive instance ordTestEnum :: Ord TestEnum +derive instance Ord TestEnum -instance encodeJsonTestEnum :: EncodeJson TestEnum where +instance EncodeJson TestEnum where encodeJson = defer \_ -> E.encode E.enum -instance decodeJsonTestEnum :: DecodeJson TestEnum where +instance DecodeJson TestEnum where decodeJson = defer \_ -> D.decode D.enum -derive instance genericTestEnum :: Generic TestEnum _ +derive instance Generic TestEnum _ -instance enumTestEnum :: Enum TestEnum where +instance Enum TestEnum where succ = genericSucc pred = genericPred -instance boundedTestEnum :: Bounded TestEnum where +instance Bounded TestEnum where bottom = genericBottom top = genericTop @@ -602,26 +602,26 @@ _Sun = prism' (const Sun) case _ of data MyUnit = U -derive instance eqMyUnit :: Eq MyUnit +derive instance Eq MyUnit -instance showMyUnit :: Show MyUnit where +instance Show MyUnit where show a = genericShow a -derive instance ordMyUnit :: Ord MyUnit +derive instance Ord MyUnit -instance encodeJsonMyUnit :: EncodeJson MyUnit where +instance EncodeJson MyUnit where encodeJson = defer \_ -> E.encode E.enum -instance decodeJsonMyUnit :: DecodeJson MyUnit where +instance DecodeJson MyUnit where decodeJson = defer \_ -> D.decode D.enum -derive instance genericMyUnit :: Generic MyUnit _ +derive instance Generic MyUnit _ -instance enumMyUnit :: Enum MyUnit where +instance Enum MyUnit where succ = genericSucc pred = genericPred -instance boundedMyUnit :: Bounded MyUnit where +instance Bounded MyUnit where bottom = genericBottom top = genericTop diff --git a/test/Spec.hs b/test/Spec.hs index 2672538c..5df46ee2 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,36 +1,102 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} module Main where -import qualified Data.Map as Map -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Language.PureScript.Bridge -import Language.PureScript.Bridge.CodeGenSwitches -import Language.PureScript.Bridge.TypeParameters -import Test.Hspec (Spec, describe, - hspec, it) -import Test.Hspec.Expectations.Pretty -import TestData -import Text.PrettyPrint.Leijen.Text (Doc, cat, - linebreak, - punctuate, vsep) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Language.PureScript.Bridge +import Language.PureScript.Bridge.CodeGenSwitches +import Language.PureScript.Bridge.TypeParameters import RoundTrip.Spec (roundtripSpec) +import Test.Hspec + ( Spec, + describe, + hspec, + it, + ) +import Test.Hspec.Expectations.Pretty +import TestData +import Text.PrettyPrint.Leijen.Text + ( Doc, + cat, + linebreak, + punctuate, + vsep, + ) main :: IO () main = hspec $ allTests *> roundtripSpec +custom :: SumType 'Haskell -> SumType 'Haskell +custom (SumType t cs is) = SumType t cs $ customInstance : is + where + customInstance = + Custom $ + CustomInstance [] (TypeInfo "" "Data.MyClass" "MyClass" [TypeInfo "" "" "Foo" []]) $ + Explicit + [ InstanceMember "member1" ["foo", "bar"] "undefined" [], + InstanceMember "member2" [] "do\npure unit" [] + ] + +customNewtypeDerived :: SumType 'Haskell -> SumType 'Haskell +customNewtypeDerived (SumType t cs is) = SumType t cs $ customInstance : is + where + customInstance = + Custom $ + CustomInstance + [TypeInfo "" "" "Eq" [TypeInfo "" "" "Foo" []]] + (TypeInfo "" "Data.MyNTClass" "MyNTClass" [TypeInfo "" "" "Foo" []]) + DeriveNewtype + +customDerived :: SumType 'Haskell -> SumType 'Haskell +customDerived (SumType t cs is) = SumType t cs $ customInstance : is + where + customInstance = + Custom $ + CustomInstance + [ TypeInfo "" "" "Eq" [TypeInfo "" "" "Foo" []], + TypeInfo "" "" "Show" [TypeInfo "" "" "Foo" []] + ] + (TypeInfo "" "Data.MyDClass" "MyDClass" [TypeInfo "" "" "Foo" []]) + Derive + allTests :: Spec allTests = do describe "buildBridge without lens-code-gen" $ do let settings = getSettings noLenses + it "tests generation of custom typeclasses" $ + let sumType = + bridgeSumType + (buildBridge defaultBridge) + (customNewtypeDerived . customDerived . custom $ mkSumType @Foo) + doc = vsep $ sumTypeToDocs settings sumType + txt = + T.unlines + [ "data Foo", + " = Foo", + " | Bar Int", + " | FooBar Int String", + "", + "derive newtype instance (Eq Foo) => MyNTClass Foo", + "", + "derive instance (Eq Foo, Show Foo) => MyDClass Foo", + "", + "instance MyClass Foo where", + " member1 foo bar = undefined", + " member2 = do", + " pure unit", + "", + "derive instance Generic Foo _" + ] + in doc `shouldRender` txt it "tests generation of typeclasses for custom type Foo" $ let sumType = bridgeSumType @@ -39,19 +105,19 @@ allTests = do doc = vsep $ sumTypeToDocs settings sumType txt = T.unlines - [ "data Foo" - , " = Foo" - , " | Bar Int" - , " | FooBar Int String" - , "" - , "instance showFoo :: Show Foo where" - , " show a = genericShow a" - , "" - , "derive instance eqFoo :: Eq Foo" - , "" - , "derive instance ordFoo :: Ord Foo" - , "" - , "derive instance genericFoo :: Generic Foo _" + [ "data Foo", + " = Foo", + " | Bar Int", + " | FooBar Int String", + "", + "instance Show Foo where", + " show a = genericShow a", + "", + "derive instance Eq Foo", + "", + "derive instance Ord Foo", + "", + "derive instance Generic Foo _" ] in doc `shouldRender` txt it "tests generation of typeclasses for custom type Func" $ @@ -62,16 +128,16 @@ allTests = do doc = vsep $ sumTypeToDocs settings sumType txt = T.unlines - [ "data Func a = Func Int a" - , "" - , "derive instance eq1Func :: Eq1 Func" - , "" - , "derive instance functorFunc :: Functor Func" - , "" - , "instance showFunc :: (Show a) => Show (Func a) where" - , " show a = genericShow a" - , "" - , "derive instance genericFunc :: Generic (Func a) _" + [ "data Func a = Func Int a", + "", + "derive instance Eq1 Func", + "", + "derive instance Functor Func", + "", + "instance (Show a) => Show (Func a) where", + " show a = genericShow a", + "", + "derive instance Generic (Func a) _" ] in doc `shouldRender` txt it "tests the generation of a whole (dummy) module" $ @@ -84,22 +150,22 @@ allTests = do txt = T.dropWhileEnd (== '\n') $ T.unlines - [ "-- File auto generated by purescript-bridge! --" - , "module TestData where" - , "" - , "import Prelude" - , "" - , "import Data.Either (Either)" - , "import Data.Generic.Rep (class Generic)" - , "import Data.Maybe (Maybe(..))" - , "" - , "data Bar a b m c" - , " = Bar1 (Maybe a)" - , " | Bar2 (Either a b)" - , " | Bar3 a" - , " | Bar4 { myMonadicResult :: m b }" - , "" - , "derive instance genericBar :: Generic (Bar a b m c) _" + [ "-- File auto generated by purescript-bridge! --", + "module TestData where", + "", + "import Prelude", + "", + "import Data.Either (Either)", + "import Data.Generic.Rep (class Generic)", + "import Data.Maybe (Maybe(..))", + "", + "data Bar a b m c", + " = Bar1 (Maybe a)", + " | Bar2 (Either a b)", + " | Bar3 a", + " | Bar4 { myMonadicResult :: m b }", + "", + "derive instance Generic (Bar a b m c) _" ] in m `shouldBe` txt it "tests generation of newtypes for record data type" $ @@ -110,15 +176,15 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleRecord a b = SingleRecord" - , " { _a :: a" - , " , _b :: b" - , " , c :: String" - , " }" - , "" - , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" - , "" - , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + [ "newtype SingleRecord a b = SingleRecord", + " { _a :: a", + " , _b :: b", + " , c :: String", + " }", + "", + "derive instance Generic (SingleRecord a b) _", + "", + "derive instance Newtype (SingleRecord a b) _" ] in doc `shouldRender` txt it "tests generation of newtypes for haskell newtype" $ @@ -129,11 +195,11 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SomeNewtype = SomeNewtype Int" - , "" - , "derive instance genericSomeNewtype :: Generic SomeNewtype _" - , "" - , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" + [ "newtype SomeNewtype = SomeNewtype Int", + "", + "derive instance Generic SomeNewtype _", + "", + "derive instance Newtype SomeNewtype _" ] in doc `shouldRender` txt it "tests generation of newtypes for haskell data type with one argument" $ @@ -144,27 +210,27 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleValueConstr = SingleValueConstr Int" - , "" - , "derive instance genericSingleValueConstr :: Generic SingleValueConstr _" - , "" - , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" + [ "newtype SingleValueConstr = SingleValueConstr Int", + "", + "derive instance Generic SingleValueConstr _", + "", + "derive instance Newtype SingleValueConstr _" ] in doc `shouldRender` txt it - "tests generation for haskell data type with one constructor, two arguments" $ - let recType' = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType @SingleProduct) - doc = vsep $ sumTypeToDocs settings recType' - txt = - T.unlines - [ "data SingleProduct = SingleProduct String Int" - , "" - , "derive instance genericSingleProduct :: Generic SingleProduct _" - ] - in doc `shouldRender` txt + "tests generation for haskell data type with one constructor, two arguments" + $ let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType @SingleProduct) + doc = vsep $ sumTypeToDocs settings recType' + txt = + T.unlines + [ "data SingleProduct = SingleProduct String Int", + "", + "derive instance Generic SingleProduct _" + ] + in doc `shouldRender` txt it "tests generation Eq instances for polymorphic types" $ let recType' = bridgeSumType @@ -173,17 +239,17 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleRecord a b = SingleRecord" - , " { _a :: a" - , " , _b :: b" - , " , c :: String" - , " }" - , "" - , "derive instance eqSingleRecord :: (Eq a, Eq b) => Eq (SingleRecord a b)" - , "" - , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" - , "" - , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + [ "newtype SingleRecord a b = SingleRecord", + " { _a :: a", + " , _b :: b", + " , c :: String", + " }", + "", + "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)", + "", + "derive instance Generic (SingleRecord a b) _", + "", + "derive instance Newtype (SingleRecord a b) _" ] in doc `shouldRender` txt it "tests generation of Ord instances for polymorphic types" $ @@ -194,19 +260,19 @@ allTests = do doc = vsep $ sumTypeToDocs settings recType' txt = T.unlines - [ "newtype SingleRecord a b = SingleRecord" - , " { _a :: a" - , " , _b :: b" - , " , c :: String" - , " }" - , "" - , "derive instance eqSingleRecord :: (Eq a, Eq b) => Eq (SingleRecord a b)" - , "" - , "derive instance ordSingleRecord :: (Ord a, Ord b) => Ord (SingleRecord a b)" - , "" - , "derive instance genericSingleRecord :: Generic (SingleRecord a b) _" - , "" - , "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _" + [ "newtype SingleRecord a b = SingleRecord", + " { _a :: a", + " , _b :: b", + " , c :: String", + " }", + "", + "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)", + "", + "derive instance (Ord a, Ord b) => Ord (SingleRecord a b)", + "", + "derive instance Generic (SingleRecord a b) _", + "", + "derive instance Newtype (SingleRecord a b) _" ] in doc `shouldRender` txt From 9550caf5dead50d634d236b0d57c8ed028e24246 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Fri, 21 Jan 2022 08:55:44 -0500 Subject: [PATCH 052/111] Format everything with ormolu --- src/Language/PureScript/Bridge/Builder.hs | 90 ++++++++--------- .../PureScript/Bridge/CodeGenSwitches.hs | 29 +++--- src/Language/PureScript/Bridge/PSTypes.hs | 67 +++++++------ src/Language/PureScript/Bridge/Primitives.hs | 8 +- src/Language/PureScript/Bridge/Tuple.hs | 1 - src/Language/PureScript/Bridge/TypeInfo.hs | 56 +++++------ .../PureScript/Bridge/TypeParameters.hs | 1 + test/RoundTrip/Spec.hs | 4 +- test/TestData.hs | 96 ++++++++++--------- 9 files changed, 179 insertions(+), 173 deletions(-) diff --git a/src/Language/PureScript/Bridge/Builder.hs b/src/Language/PureScript/Bridge/Builder.hs index aba8706b..eb8bcd08 100644 --- a/src/Language/PureScript/Bridge/Builder.hs +++ b/src/Language/PureScript/Bridge/Builder.hs @@ -18,34 +18,35 @@ -- -- Find usage examples in "Language.PureScript.Bridge.Primitives" and "Language.PureScript.Bridge.PSTypes" module Language.PureScript.Bridge.Builder - ( BridgeBuilder - , BridgePart - , FixUpBuilder - , FixUpBridge - , BridgeData - , fullBridge - , (^==) - , doCheck - , (<|>) - , psTypeParameters - , FullBridge - , buildBridge - , clearPackageFixUp - , errorFixUp - , buildBridgeWithCustomFixUp - ) where + ( BridgeBuilder, + BridgePart, + FixUpBuilder, + FixUpBridge, + BridgeData, + fullBridge, + (^==), + doCheck, + (<|>), + psTypeParameters, + FullBridge, + buildBridge, + clearPackageFixUp, + errorFixUp, + buildBridgeWithCustomFixUp, + ) +where import Control.Applicative import Control.Lens import Control.Monad (MonadPlus, guard, mplus, mzero) import Control.Monad.Reader.Class -import Control.Monad.Trans.Reader (Reader, ReaderT(..), runReader) +import Control.Monad.Trans.Reader (Reader, ReaderT (..), runReader) import Data.Maybe (fromMaybe) import qualified Data.Text as T import Language.PureScript.Bridge.TypeInfo -newtype BridgeBuilder a = - BridgeBuilder (ReaderT BridgeData Maybe a) +newtype BridgeBuilder a + = BridgeBuilder (ReaderT BridgeData Maybe a) deriving (Functor, Applicative, Monad, MonadReader BridgeData) type BridgePart = BridgeBuilder PSType @@ -75,20 +76,20 @@ type BridgePart = BridgeBuilder PSType -- -- > psEither :: FixUpBridge -- > psEither = .... --- -newtype FixUpBuilder a = - FixUpBuilder (Reader BridgeData a) +newtype FixUpBuilder a + = FixUpBuilder (Reader BridgeData a) deriving (Functor, Applicative, Monad, MonadReader BridgeData) type FixUpBridge = FixUpBuilder PSType type FullBridge = HaskellType -> PSType -data BridgeData = - BridgeData - { _haskType :: HaskellType -- ^ The Haskell type to translate. - , _fullBridge :: FullBridge -- ^ Reference to the bridge itself, needed for translation of type constructors. - } +data BridgeData = BridgeData + { -- | The Haskell type to translate. + _haskType :: HaskellType, + -- | Reference to the bridge itself, needed for translation of type constructors. + _fullBridge :: FullBridge + } -- | By implementing the 'haskType' lens in the HasHaskType class, we are able -- to use it for both 'BridgeData' and a plain 'HaskellType', therefore @@ -133,10 +134,10 @@ clearPackageFixUp = do psArgs <- psTypeParameters return TypeInfo - { _typePackage = "" - , _typeModule = input ^. typeModule - , _typeName = input ^. typeName - , _typeParameters = psArgs + { _typePackage = "", + _typeModule = input ^. typeModule, + _typeName = input ^. typeName, + _typeParameters = psArgs } -- | A 'FixUpBridge' which calles 'error' when used. @@ -147,14 +148,14 @@ errorFixUp :: MonadReader BridgeData m => m PSType errorFixUp = do inType <- view haskType let message = - "No translation supplied for Haskell type: '" <> inType ^. typeName <> - "', from module: '" <> - inType ^. - typeModule <> - "', from package: '" <> - inType ^. - typePackage <> - "'!" + "No translation supplied for Haskell type: '" <> inType ^. typeName + <> "', from module: '" + <> inType + ^. typeModule + <> "', from package: '" + <> inType + ^. typePackage + <> "'!" return $ error $ T.unpack message -- | Build a bridge. @@ -187,11 +188,12 @@ buildBridgeWithCustomFixUp (FixUpBuilder fixUp) (BridgeBuilder bridgePart) = fixTypeParameters :: TypeInfo lang -> TypeInfo lang fixTypeParameters t = if "TypeParameters" `T.isSuffixOf` _typeModule t - then t - { _typePackage = "" -- Don't suggest any packages - , _typeModule = "" -- Don't import any modules - , _typeName = t ^. typeName . to (stripNum . T.toLower) - } + then + t + { _typePackage = "", -- Don't suggest any packages + _typeModule = "", -- Don't import any modules + _typeName = t ^. typeName . to (stripNum . T.toLower) + } else t where stripNum v = fromMaybe v (T.stripSuffix "1" v) diff --git a/src/Language/PureScript/Bridge/CodeGenSwitches.hs b/src/Language/PureScript/Bridge/CodeGenSwitches.hs index ee9130e3..edef1d1d 100644 --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ b/src/Language/PureScript/Bridge/CodeGenSwitches.hs @@ -1,21 +1,22 @@ -- | General switches for the code generation, such as generating profunctor-lenses or not module Language.PureScript.Bridge.CodeGenSwitches - ( Settings(..) - , defaultSettings - , Switch - , getSettings - , defaultSwitch - , noLenses - , genLenses - ) where - -import Data.Monoid (Endo(..)) + ( Settings (..), + defaultSettings, + Switch, + getSettings, + defaultSwitch, + noLenses, + genLenses, + ) +where + +import Data.Monoid (Endo (..)) -- | General settings for code generation -newtype Settings = - Settings - { generateLenses :: Bool -- ^use purescript-profunctor-lens for generated PS-types? - } +newtype Settings = Settings + { -- | use purescript-profunctor-lens for generated PS-types? + generateLenses :: Bool + } deriving (Eq, Show) -- | Settings to generate Lenses diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs index 07f8154a..97d3ae04 100644 --- a/src/Language/PureScript/Bridge/PSTypes.hs +++ b/src/Language/PureScript/Bridge/PSTypes.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} -- | PureScript types to be used for bridges, e.g. in "Language.PureScript.Bridge.Primitives". module Language.PureScript.Bridge.PSTypes where -import Control.Lens (view) -import Control.Monad.Reader.Class - -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.TypeInfo +import Control.Lens (view) +import Control.Monad.Reader.Class +import Language.PureScript.Bridge.Builder +import Language.PureScript.Bridge.TypeInfo -- | Uses type parameters from 'haskType' (bridged). psArray :: MonadReader BridgeData m => m PSType @@ -20,10 +19,10 @@ psArray = TypeInfo "" "Prim" "Array" <$> psTypeParameters psBool :: PSType psBool = TypeInfo - { _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Boolean" - , _typeParameters = [] + { _typePackage = "", + _typeModule = "Prim", + _typeName = "Boolean", + _typeParameters = [] } -- | Uses type parameters from 'haskType' (bridged). @@ -34,19 +33,19 @@ psEither = psInt :: PSType psInt = TypeInfo - { _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Int" - , _typeParameters = [] + { _typePackage = "", + _typeModule = "Prim", + _typeName = "Int", + _typeParameters = [] } psNumber :: PSType psNumber = TypeInfo - { _typePackage = "" - , _typeModule = "Prim" - , _typeName = "Number" - , _typeParameters = [] + { _typePackage = "", + _typeModule = "Prim", + _typeName = "Number", + _typeParameters = [] } -- | Uses type parameters from 'haskType' (bridged). @@ -56,10 +55,10 @@ psMaybe = TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" <$> psTypeParameters psString :: PSType psString = TypeInfo - { _typePackage = "" - , _typeModule = "Prim" - , _typeName = "String" - , _typeParameters = [] + { _typePackage = "", + _typeModule = "Prim", + _typeName = "String", + _typeParameters = [] } -- | Uses type parameters from 'haskType' (bridged). @@ -67,21 +66,19 @@ psTuple :: MonadReader BridgeData m => m PSType psTuple = do params <- view (haskType . typeParameters) bridge <- view fullBridge - let - computeTuple [] = psUnit - computeTuple [a] = bridge a - computeTuple [a, b] = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge a, bridge b] - computeTuple (h : t) = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge h, computeTuple t] + let computeTuple [] = psUnit + computeTuple [a] = bridge a + computeTuple [a, b] = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge a, bridge b] + computeTuple (h : t) = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge h, computeTuple t] pure $ computeTuple params - psUnit :: PSType psUnit = TypeInfo - { _typePackage = "purescript-prelude" - , _typeModule = "Prelude" - , _typeName = "Unit" - , _typeParameters = [] + { _typePackage = "purescript-prelude", + _typeModule = "Prelude", + _typeName = "Unit", + _typeParameters = [] } psMap :: MonadReader BridgeData m => m PSType diff --git a/src/Language/PureScript/Bridge/Primitives.hs b/src/Language/PureScript/Bridge/Primitives.hs index d6d5fd2c..1ab112ea 100644 --- a/src/Language/PureScript/Bridge/Primitives.hs +++ b/src/Language/PureScript/Bridge/Primitives.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Language.PureScript.Bridge.Primitives where @@ -51,8 +51,8 @@ stringBridge = textBridge :: BridgePart textBridge = do typeName ^== "Text" - typeModule ^== "Data.Text.Internal" <|> - typeModule ^== "Data.Text.Internal.Lazy" + typeModule ^== "Data.Text.Internal" + <|> typeModule ^== "Data.Text.Internal.Lazy" return psString unitBridge :: BridgePart diff --git a/src/Language/PureScript/Bridge/Tuple.hs b/src/Language/PureScript/Bridge/Tuple.hs index 332cafc3..efff3937 100644 --- a/src/Language/PureScript/Bridge/Tuple.hs +++ b/src/Language/PureScript/Bridge/Tuple.hs @@ -4,7 +4,6 @@ module Language.PureScript.Bridge.Tuple where import qualified Data.Text as T - import Language.PureScript.Bridge.Builder import Language.PureScript.Bridge.PSTypes (psTuple) import Language.PureScript.Bridge.TypeInfo diff --git a/src/Language/PureScript/Bridge/TypeInfo.hs b/src/Language/PureScript/Bridge/TypeInfo.hs index d568df98..c6d84652 100644 --- a/src/Language/PureScript/Bridge/TypeInfo.hs +++ b/src/Language/PureScript/Bridge/TypeInfo.hs @@ -4,26 +4,27 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} module Language.PureScript.Bridge.TypeInfo - ( TypeInfo(..) - , PSType - , HaskellType - , mkTypeInfo - , mkTypeInfo' - , Language(..) - , typePackage - , typeModule - , typeName - , typeParameters - , HasHaskType - , haskType - , flattenTypeInfo - ) where + ( TypeInfo (..), + PSType, + HaskellType, + mkTypeInfo, + mkTypeInfo', + Language (..), + typePackage, + typeModule, + typeName, + typeParameters, + HasHaskType, + haskType, + flattenTypeInfo, + ) +where import Control.Lens import Data.Proxy @@ -36,13 +37,14 @@ data Language | PureScript -- | Basic info about a data type: -data TypeInfo (lang :: Language) = - TypeInfo - { _typePackage :: !Text -- ^ Hackage package - , _typeModule :: !Text -- ^ Full Module path - , _typeName :: !Text - , _typeParameters :: ![TypeInfo lang] - } +data TypeInfo (lang :: Language) = TypeInfo + { -- | Hackage package + _typePackage :: !Text, + -- | Full Module path + _typeModule :: !Text, + _typeName :: !Text, + _typeParameters :: ![TypeInfo lang] + } deriving (Eq, Ord, Show) makeLenses ''TypeInfo @@ -68,10 +70,10 @@ mkTypeInfo' :: TypeRep -> HaskellType mkTypeInfo' rep = let con = typeRepTyCon rep in TypeInfo - { _typePackage = T.pack $ tyConPackage con - , _typeModule = T.pack $ tyConModule con - , _typeName = T.pack $ tyConName con - , _typeParameters = map mkTypeInfo' (typeRepArgs rep) + { _typePackage = T.pack $ tyConPackage con, + _typeModule = T.pack $ tyConModule con, + _typeName = T.pack $ tyConName con, + _typeParameters = map mkTypeInfo' (typeRepArgs rep) } -- | Put the TypeInfo in a list together with all its '_typeParameters' (recursively) diff --git a/src/Language/PureScript/Bridge/TypeParameters.hs b/src/Language/PureScript/Bridge/TypeParameters.hs index 6b59fea3..c9a4c8a0 100644 --- a/src/Language/PureScript/Bridge/TypeParameters.hs +++ b/src/Language/PureScript/Bridge/TypeParameters.hs @@ -1,4 +1,5 @@ {-# LANGUAGE EmptyDataDeriving #-} + -- | As we translate types and not type constructors, we have to pass dummy types -- to any type constructor. -- diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index b633a841..d0be4291 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -19,8 +19,8 @@ import Language.PureScript.Bridge.TypeParameters (A) import RoundTrip.Types import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) -import System.IO (BufferMode (..), hFlush, hGetLine, hPutStrLn, hSetBuffering, stderr, stdout) -import System.Process (CreateProcess (..), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess, waitForProcess) +import System.IO (BufferMode (..), hFlush, hPutStrLn, hSetBuffering, stderr, stdout) +import System.Process (CreateProcess (std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess, waitForProcess) import Test.HUnit (assertBool, assertEqual) import Test.Hspec (Spec, around, aroundAll_, around_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) diff --git a/test/TestData.hs b/test/TestData.hs index c18966f2..c4020a02 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -1,73 +1,77 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} - module TestData where -import Data.Functor.Classes (Eq1(liftEq)) -import Data.Proxy -import Data.Text (Text) -import Data.Typeable -import GHC.Generics (Generic) -import Language.PureScript.Bridge -import Language.PureScript.Bridge.PSTypes +import Data.Functor.Classes (Eq1 (liftEq)) +import Data.Proxy +import Data.Text (Text) +import Data.Typeable +import GHC.Generics (Generic) +import Language.PureScript.Bridge import Language.PureScript.Bridge.CodeGenSwitches (defaultSettings) - - +import Language.PureScript.Bridge.PSTypes -- Check that examples compile: textBridge :: BridgePart textBridge = do - typeName ^== "Text" - typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" - return psString + typeName ^== "Text" + typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" + return psString stringBridge :: BridgePart stringBridge = do - haskType ^== mkTypeInfo @String - return psString + haskType ^== mkTypeInfo @String + return psString -data Foo = Foo - | Bar Int - | FooBar Int Text - deriving (Eq, Ord, Generic, Typeable, Show) +data Foo + = Foo + | Bar Int + | FooBar Int Text + deriving (Eq, Ord, Generic, Typeable, Show) data Func a = Func Int a - deriving (Eq, Ord, Functor, Generic, Typeable, Show) + deriving (Eq, Ord, Functor, Generic, Typeable, Show) instance Eq1 Func where liftEq eq (Func n x) (Func m y) = n == m && x `eq` y -data Test = TestIntInt Int Int - | TestBool {bool :: Bool} - | TestVoid - deriving (Generic, Typeable, Show) +data Test + = TestIntInt Int Int + | TestBool {bool :: Bool} + | TestVoid + deriving (Generic, Typeable, Show) -data Bar a b m c = Bar1 (Maybe a) | Bar2 (Either a b) | Bar3 a - | Bar4 { myMonadicResult :: m b } - deriving (Generic, Typeable, Show) +data Bar a b m c + = Bar1 (Maybe a) + | Bar2 (Either a b) + | Bar3 a + | Bar4 {myMonadicResult :: m b} + deriving (Generic, Typeable, Show) -data SingleRecord a b = SingleRecord { - _a :: a - , _b :: b - , c :: String - } deriving(Generic, Eq, Ord, Typeable, Show) +data SingleRecord a b = SingleRecord + { _a :: a, + _b :: b, + c :: String + } + deriving (Generic, Eq, Ord, Typeable, Show) data TwoRecords - = FirstRecord { - _fra :: String - , _frb :: Int - } - | SecondRecord { - _src :: Int - , _srd :: [Int] - } deriving(Generic, Typeable, Show) + = FirstRecord + { _fra :: String, + _frb :: Int + } + | SecondRecord + { _src :: Int, + _srd :: [Int] + } + deriving (Generic, Typeable, Show) newtype SomeNewtype = SomeNewtype Int deriving (Generic, Typeable, Show) From 759012aa1664182249f65de853ca2b5906b78be2 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Fri, 21 Jan 2022 10:43:02 -0500 Subject: [PATCH 053/111] Add newlines at the end of module files --- src/Language/PureScript/Bridge/Printer.hs | 25 +++++++++++---------- test/RoundTrip/app/src/RoundTrip/Types.purs | 2 +- test/Spec.hs | 3 ++- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index a7aac7fa..b65c80f1 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -237,18 +237,19 @@ sumTypeToNeededPackages st = moduleToText :: Switches.Settings -> Module 'PureScript -> Text moduleToText settings m = - renderText $ - vsep $ - [ "-- File auto generated by purescript-bridge! --", - "module" <+> textStrict (psModuleName m) <+> "where" <> linebreak, - "import Prelude" <> linebreak, - vsep - ( (importLineToText <$> allImports) - <> (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) - ) - <> linebreak - ] - <> punctuate (line <> line <> dashes <> line) (sumTypeToDocs settings =<< psTypes m) + flip mappend "\n" $ + renderText $ + vsep $ + [ "-- File auto generated by purescript-bridge! --", + "module" <+> textStrict (psModuleName m) <+> "where" <> linebreak, + "import Prelude" <> linebreak, + vsep + ( (importLineToText <$> allImports) + <> (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) + ) + <> linebreak + ] + <> punctuate (line <> line <> dashes <> line) (sumTypeToDocs settings =<< psTypes m) where otherImports = importsFromList diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index d8242be5..bf7ff685 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -628,4 +628,4 @@ instance Bounded MyUnit where -------------------------------------------------------------------------------- _U :: Iso' MyUnit Unit -_U = iso (const unit) (const U) \ No newline at end of file +_U = iso (const unit) (const U) diff --git a/test/Spec.hs b/test/Spec.hs index 5df46ee2..26cb1739 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -165,7 +165,8 @@ allTests = do " | Bar3 a", " | Bar4 { myMonadicResult :: m b }", "", - "derive instance Generic (Bar a b m c) _" + "derive instance Generic (Bar a b m c) _", + "" ] in m `shouldBe` txt it "tests generation of newtypes for record data type" $ From a62b87c87c112419ca0b705e4923d59aa38d46e6 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Fri, 21 Jan 2022 11:40:17 -0500 Subject: [PATCH 054/111] Fix type extraction for custom instances --- src/Language/PureScript/Bridge/SumType.hs | 60 ++++++++++------------- test/Spec.hs | 38 +++++++------- 2 files changed, 45 insertions(+), 53 deletions(-) diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index feda0562..483e06ee 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -204,48 +204,42 @@ instance (Selector a, Typeable t) => GDataConstructorArgs (S1 a (K1 R t)) where -- This includes all types found at the right hand side of a sum type -- definition, not the type parameters of the sum type itself getUsedTypes :: SumType lang -> Set (TypeInfo lang) -getUsedTypes (SumType _ cs is) = foldMap constructorToTypes cs <> foldMap instanceToTypes is - -constructorToTypes :: - DataConstructor lang -> Set (TypeInfo lang) -constructorToTypes (DataConstructor _ Nullary) = Set.empty -constructorToTypes (DataConstructor _ (Normal [ts])) = - Set.fromList $ flattenTypeInfo ts -constructorToTypes (DataConstructor _ (Record [rs])) = - Set.fromList . flattenTypeInfo $ _recValue rs -constructorToTypes (DataConstructor _ (Normal ts)) = - Set.fromList . concatMap flattenTypeInfo $ NE.toList ts -constructorToTypes (DataConstructor _ (Record rs)) = - Set.fromList . concatMap (flattenTypeInfo . _recValue) $ NE.toList rs - -instanceToTypes :: Instance lang -> Set (TypeInfo lang) -instanceToTypes Generic = - Set.singleton $ TypeInfo "purescript-prelude" "Data.Generic.Rep" "class Generic" [] -instanceToTypes GenericShow = - Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Show" [] +getUsedTypes (SumType _ cs is) = + Set.fromList . concatMap flattenTypeInfo $ + concatMap constructorToTypes cs <> concatMap instanceToTypes is + +constructorToTypes :: DataConstructor lang -> [TypeInfo lang] +constructorToTypes (DataConstructor _ Nullary) = [] +constructorToTypes (DataConstructor _ (Normal ts)) = NE.toList ts +constructorToTypes (DataConstructor _ (Record rs)) = _recValue <$> NE.toList rs + +instanceToTypes :: Instance lang -> [TypeInfo lang] +instanceToTypes Generic = pure $ constraintToType $ TypeInfo "purescript-prelude" "Data.Generic.Rep" "Generic" [] +instanceToTypes GenericShow = pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Show" [] instanceToTypes Json = - Set.fromList - [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "class DecodeJson" [], - TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "class EncodeJson" [] - ] + constraintToType + <$> [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [], + TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] + ] instanceToTypes Newtype = - Set.singleton $ TypeInfo "purescript-newtype" "Data.Newtype" "class Newtype" [] + pure $ constraintToType $ TypeInfo "purescript-newtype" "Data.Newtype" "Newtype" [] instanceToTypes Functor = - Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Functor" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Functor" [] instanceToTypes Eq = - Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Eq" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Eq" [] instanceToTypes Eq1 = - Set.singleton $ TypeInfo "purescript-prelude" "Data.Eq" "class Eq1" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Data.Eq" "Eq1" [] instanceToTypes Ord = - Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Ord" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Ord" [] instanceToTypes Enum = - Set.singleton $ TypeInfo "purescript-enums" "Data.Enum" "class Enum" [] + pure $ constraintToType $ TypeInfo "purescript-enums" "Data.Enum" "Enum" [] instanceToTypes Bounded = - Set.singleton $ TypeInfo "purescript-prelude" "Prelude" "class Bounded" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Bounded" [] instanceToTypes (Custom CustomInstance {..}) = - Set.fromList $ - concatMap flattenTypeInfo $ - _customHead : (_customConstraints <> implementationToTypes _customImplementation) + constraintToType _customHead : (fmap constraintToType _customConstraints <> implementationToTypes _customImplementation) + +constraintToType :: TypeInfo lang -> TypeInfo lang +constraintToType = over typeName ("class " <>) implementationToTypes :: InstanceImplementation lang -> [TypeInfo lang] implementationToTypes (Explicit members) = concatMap _memberDependencies members diff --git a/test/Spec.hs b/test/Spec.hs index 26cb1739..e5749087 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -148,26 +148,24 @@ allTests = do modules = sumTypeToModule advanced' m = head . map (moduleToText settings) . Map.elems $ modules txt = - T.dropWhileEnd (== '\n') $ - T.unlines - [ "-- File auto generated by purescript-bridge! --", - "module TestData where", - "", - "import Prelude", - "", - "import Data.Either (Either)", - "import Data.Generic.Rep (class Generic)", - "import Data.Maybe (Maybe(..))", - "", - "data Bar a b m c", - " = Bar1 (Maybe a)", - " | Bar2 (Either a b)", - " | Bar3 a", - " | Bar4 { myMonadicResult :: m b }", - "", - "derive instance Generic (Bar a b m c) _", - "" - ] + T.unlines + [ "-- File auto generated by purescript-bridge! --", + "module TestData where", + "", + "import Prelude", + "", + "import Data.Either (Either)", + "import Data.Generic.Rep (class Generic)", + "import Data.Maybe (Maybe(..))", + "", + "data Bar a b m c", + " = Bar1 (Maybe a)", + " | Bar2 (Either a b)", + " | Bar3 a", + " | Bar4 { myMonadicResult :: m b }", + "", + "derive instance Generic (Bar a b m c) _" + ] in m `shouldBe` txt it "tests generation of newtypes for record data type" $ let recType' = From 47a1f11825a0f9445e0f98792f79172efef66c00 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Fri, 21 Jan 2022 12:14:09 -0500 Subject: [PATCH 055/111] Add import lines for custom instances --- src/Language/PureScript/Bridge/Printer.hs | 41 +++------------------ src/Language/PureScript/Bridge/SumType.hs | 44 ++++++++++++++++++++++- 2 files changed, 47 insertions(+), 38 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index b65c80f1..dc27e078 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -29,6 +29,8 @@ import Language.PureScript.Bridge.SumType ( CustomInstance (..), DataConstructor (..), DataConstructorArgs (..), + ImportLine (..), + ImportLines, Instance (..), InstanceImplementation (..), InstanceMember (..), @@ -36,6 +38,8 @@ import Language.PureScript.Bridge.SumType RecordEntry (..), SumType (SumType), getUsedTypes, + importsFromList, + instanceToImportLines, nootype, recLabel, recValue, @@ -104,16 +108,8 @@ data Module (lang :: Language) = PSModule type PSModule = Module 'PureScript -data ImportLine = ImportLine - { importModule :: !Text, - importTypes :: !(Set Text) - } - deriving (Show) - type Modules = Map Text PSModule -type ImportLines = Map Text ImportLine - sumTypesToModules :: [SumType 'PureScript] -> Modules sumTypesToModules = foldr (Map.unionWith unionModules) Map.empty . fmap sumTypeToModule @@ -174,28 +170,6 @@ instancesToImportLines :: [PSInstance] -> ImportLines instancesToImportLines = foldr unionImportLines Map.empty . fmap instanceToImportLines -instanceToImportLines :: PSInstance -> ImportLines -instanceToImportLines GenericShow = - importsFromList [ImportLine "Data.Show.Generic" $ Set.singleton "genericShow"] -instanceToImportLines Json = - importsFromList - [ ImportLine "Control.Lazy" $ Set.singleton "defer", - ImportLine "Data.Argonaut" $ Set.fromList ["encodeJson", "jsonNull"], - ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["()", "()", "()"], - ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["(>$<)", "(>/\\<)"], - ImportLine "Data.Newtype" $ Set.singleton "unwrap", - ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" - ] -instanceToImportLines Enum = - importsFromList - [ ImportLine "Data.Enum.Generic" $ Set.fromList ["genericPred", "genericSucc"] - ] -instanceToImportLines Bounded = - importsFromList - [ ImportLine "Data.Bounded.Generic" $ Set.fromList ["genericBottom", "genericTop"] - ] -instanceToImportLines _ = Map.empty - instanceToQualifiedImports :: PSInstance -> Map Text Text instanceToQualifiedImports Json = Map.fromList @@ -205,13 +179,6 @@ instanceToQualifiedImports Json = ] instanceToQualifiedImports _ = Map.empty -importsFromList :: [ImportLine] -> Map Text ImportLine -importsFromList ls = - let pairs = zip (importModule <$> ls) ls - merge a b = - ImportLine (importModule a) (importTypes a `Set.union` importTypes b) - in Map.fromListWith merge pairs - mergeImportLines :: ImportLines -> ImportLines -> ImportLines mergeImportLines = Map.unionWith mergeLines where diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 483e06ee..54dbdf51 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -20,6 +20,8 @@ import Control.Lens hiding (from, to) import Data.List (nub) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe (maybeToList) import Data.Set (Set) import qualified Data.Set as Set @@ -29,6 +31,14 @@ import Data.Typeable import Generics.Deriving import Language.PureScript.Bridge.TypeInfo +data ImportLine = ImportLine + { importModule :: !Text, + importTypes :: !(Set Text) + } + deriving (Eq, Ord, Show) + +type ImportLines = Map Text ImportLine + -- | Generic representation of your Haskell types. data SumType (lang :: Language) = SumType (TypeInfo lang) [DataConstructor lang] [Instance lang] @@ -87,7 +97,8 @@ data InstanceMember (lang :: Language) = InstanceMember { _memberName :: Text, _memberBindings :: [Text], _memberBody :: Text, - _memberDependencies :: [TypeInfo lang] + _memberDependencies :: [TypeInfo lang], + _memberImportLines :: ImportLines } deriving (Eq, Ord, Show) @@ -245,6 +256,37 @@ implementationToTypes :: InstanceImplementation lang -> [TypeInfo lang] implementationToTypes (Explicit members) = concatMap _memberDependencies members implementationToTypes _ = [] +instanceToImportLines :: PSInstance -> ImportLines +instanceToImportLines GenericShow = + importsFromList [ImportLine "Data.Show.Generic" $ Set.singleton "genericShow"] +instanceToImportLines Json = + importsFromList + [ ImportLine "Control.Lazy" $ Set.singleton "defer", + ImportLine "Data.Argonaut" $ Set.fromList ["encodeJson", "jsonNull"], + ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["()", "()", "()"], + ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["(>$<)", "(>/\\<)"], + ImportLine "Data.Newtype" $ Set.singleton "unwrap", + ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" + ] +instanceToImportLines Enum = + importsFromList + [ ImportLine "Data.Enum.Generic" $ Set.fromList ["genericPred", "genericSucc"] + ] +instanceToImportLines Bounded = + importsFromList + [ ImportLine "Data.Bounded.Generic" $ Set.fromList ["genericBottom", "genericTop"] + ] +instanceToImportLines (Custom CustomInstance {_customImplementation = Explicit members}) = + importsFromList $ concatMap (Map.elems . _memberImportLines) members +instanceToImportLines _ = Map.empty + +importsFromList :: [ImportLine] -> Map Text ImportLine +importsFromList ls = + let pairs = zip (importModule <$> ls) ls + merge a b = + ImportLine (importModule a) (importTypes a `Set.union` importTypes b) + in Map.fromListWith merge pairs + -- Lenses: makeLenses ''DataConstructor From 2b58aa62f4ae0a1bd3f272f7f974814ae4ab6364 Mon Sep 17 00:00:00 2001 From: Tomasz Rybarczyk Date: Wed, 22 Jun 2022 11:37:29 +0200 Subject: [PATCH 056/111] Add package namespacing support --- src/Language/PureScript/Bridge.hs | 8 +++---- src/Language/PureScript/Bridge/Printer.hs | 27 +++++++++++++++++------ 2 files changed, 24 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index 523c894f..51837b0e 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -80,7 +80,7 @@ import Language.PureScript.Bridge.TypeInfo as Bridge -- -- == /WARNING/: -- This function overwrites files - make backups or use version control! -writePSTypes :: FilePath -> FullBridge -> [SumType 'Haskell] -> IO () +writePSTypes :: Maybe PackageName -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypes = writePSTypesWith Switches.defaultSwitch -- | Works like `writePSTypes` but you can add additional switches to control the generation of your PureScript code @@ -92,8 +92,8 @@ writePSTypes = writePSTypesWith Switches.defaultSwitch -- == /WARNING/: -- This function overwrites files - make backups or use version control! writePSTypesWith :: - Switches.Switch -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () -writePSTypesWith switch root bridge sts = do + Switches.Switch -> Maybe PackageName -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () +writePSTypesWith switch packageName root bridge sts = do mapM_ (printModule settings root) modules T.putStrLn "The following purescript packages are needed by the generated code:\n" @@ -102,7 +102,7 @@ writePSTypesWith switch root bridge sts = do where settings = Switches.getSettings switch bridged = map (bridgeSumType bridge) sts - modules = M.elems $ sumTypesToModules bridged + modules = M.elems $ sumTypesToModules packageName bridged packages = sumTypesToNeededPackages bridged <> Set.filter diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index dc27e078..49bdddf7 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -94,6 +94,7 @@ import Text.PrettyPrint.Leijen.Text vsep, (<+>), ) +import qualified Data.Char as C renderText :: Doc -> Text renderText = T.replace " \n" "\n" . displayTStrict . renderPretty 0.4 200 @@ -110,8 +111,16 @@ type PSModule = Module 'PureScript type Modules = Map Text PSModule -sumTypesToModules :: [SumType 'PureScript] -> Modules -sumTypesToModules = foldr (Map.unionWith unionModules) Map.empty . fmap sumTypeToModule +newtype PackageName = PackageName Text + +mkPackageName :: String -> Maybe PackageName +mkPackageName s = if all C.isAlpha s + then Just $ PackageName (T.pack s) + else Nothing + +sumTypesToModules :: Maybe PackageName -> [SumType 'PureScript] -> Modules +sumTypesToModules packageName = + foldr (Map.unionWith unionModules) Map.empty . fmap (sumTypeToModule packageName) unionModules :: PSModule -> PSModule -> PSModule unionModules m1 m2 = @@ -120,12 +129,12 @@ unionModules m1 m2 = psTypes = psTypes m1 <> psTypes m2 } -sumTypeToModule :: SumType 'PureScript -> Modules -sumTypeToModule st@(SumType t _ is) = +sumTypeToModule :: Maybe PackageName -> SumType 'PureScript -> Modules +sumTypeToModule packageName st@(SumType t _ is) = Map.singleton - (_typeModule t) + typedModuleName $ PSModule - { psModuleName = _typeModule t, + { psModuleName = psModuleName, psImportLines = dropEmpty $ dropPrelude $ @@ -141,7 +150,11 @@ sumTypeToModule st@(SumType t _ is) = dropEmpty = Map.delete "" dropPrelude = Map.delete "Prelude" dropPrim = Map.delete "Prim" - dropSelf = Map.delete (_typeModule t) + typedModuleName = _typeModule t + dropSelf = Map.delete typedModuleName + psModuleName = fromMaybe typedModuleName do + PackageName pn <- packageName + pure $ pn <> "." <> typedModuleName unionQualifiedImports :: Map Text Text -> Map Text Text -> Map Text Text unionQualifiedImports = Map.unionWith const From 51e84044f877c27435040f57cca29634afe14dfb Mon Sep 17 00:00:00 2001 From: Tomasz Rybarczyk Date: Thu, 7 Jul 2022 15:29:57 +0200 Subject: [PATCH 057/111] Make package namespacing introduction backward compatible. --- src/Language/PureScript/Bridge.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index 51837b0e..2fd5c553 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -9,6 +9,7 @@ module Language.PureScript.Bridge module Bridge, writePSTypes, writePSTypesWith, + writePSTypesWithNamespace, defaultSwitch, noLenses, genLenses, @@ -80,7 +81,7 @@ import Language.PureScript.Bridge.TypeInfo as Bridge -- -- == /WARNING/: -- This function overwrites files - make backups or use version control! -writePSTypes :: Maybe PackageName -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () +writePSTypes :: FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypes = writePSTypesWith Switches.defaultSwitch -- | Works like `writePSTypes` but you can add additional switches to control the generation of your PureScript code @@ -91,9 +92,12 @@ writePSTypes = writePSTypesWith Switches.defaultSwitch -- -- == /WARNING/: -- This function overwrites files - make backups or use version control! -writePSTypesWith :: +writePSTypesWith :: Switches.Switch -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () +writePSTypesWith switch = writePSTypesWithNamespace switch Nothing + +writePSTypesWithNamespace :: Switches.Switch -> Maybe PackageName -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () -writePSTypesWith switch packageName root bridge sts = do +writePSTypesWithNamespace switch packageName root bridge sts = do mapM_ (printModule settings root) modules T.putStrLn "The following purescript packages are needed by the generated code:\n" From 53f4e98a1ab5ef9002d52ffbfd19ae82150eef65 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Mon, 18 Sep 2023 10:14:11 -0700 Subject: [PATCH 058/111] copy Stylish Haskell, Nix Flake config --- .envrc | 2 +- .gitignore | 5 + .stylish-haskell.yaml | 481 ++++++++++++++++++++++++++++++++++++++++++ flake.lock | 328 ++++++---------------------- flake.nix | 98 +++++---- 5 files changed, 613 insertions(+), 301 deletions(-) create mode 100644 .stylish-haskell.yaml diff --git a/.envrc b/.envrc index 051d09d2..3550a30f 100644 --- a/.envrc +++ b/.envrc @@ -1 +1 @@ -eval "$(lorri direnv)" +use flake diff --git a/.gitignore b/.gitignore index 652b5d68..ba1ec8cf 100644 --- a/.gitignore +++ b/.gitignore @@ -23,3 +23,8 @@ shell.nix stack.yaml .dir-locals.el .psc-ide-port + +example/**/*.js + +.direnv +result \ No newline at end of file diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 00000000..f040e2a0 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,481 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true + # + # # When to break the "where". + # # Possible values: + # # - exports: only break when there is an explicit export list. + # # - single: only break when the export list counts more than one export. + # # - inline: only break when the export list is too long. This is + # # determined by the `columns` setting. Not applicable when the export + # # list contains comments as newlines will be required. + # # - always: always break before the "where". + # break_where: exports + # + # # Where to put open bracket + # # Possible values: + # # - same_line: put open bracket on the same line as the module name, before the + # # comment of the module + # # - next_line: put open bracket on the next line, after module comment + # open_bracket: next_line + + # Format record definitions. This is disabled by default. + # + # You can control the layout of record fields. The only rules that can't be configured + # are these: + # + # - "|" is always aligned with "=" + # - "," in fields is always aligned with "{" + # - "}" is likewise always aligned with "{" + # + - records: + # How to format equals sign between type constructor and data constructor. + # Possible values: + # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. + # - "indent N" -- insert a new line and N spaces from the beginning of the next line. + equals: "indent 2" + + # How to format first field of each record constructor. + # Possible values: + # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + first_field: "indent 2" + + # How many spaces to insert between the column with "," and the beginning of the comment in the next line. + field_comment: 2 + + # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. + deriving: 2 + + # How many spaces to insert before "via" clause counted from indentation of deriving clause + # Possible values: + # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. + via: "indent 2" + + # Sort typeclass names in the "deriving" list alphabetically. + sort_deriving: true + + # Whether or not to break enums onto several lines + # + # Default: false + break_enums: false + + # Whether or not to break single constructor data types before `=` sign + # + # Default: true + break_single_constructors: false + + # Whether or not to curry constraints on function. + # + # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # + # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # + # Default: false + curried_context: false + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. + - simple_align: + cases: always + top_level_patterns: always + records: always + multi_way_if: always + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_module_name: Import list is aligned `list_padding` spaces after + # the module name. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length) + # + # This is mainly intended for use with `pad_module_names: false`. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length, scanl, scanr, take, drop, + # sort, nub) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: false + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: right_after + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + # + # Default: 4 + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Post qualify option moves any qualifies found in import declarations + # to the end of the declaration. This also adjust padding for any + # unqualified import declarations. + # + # - true: Qualified as is moved to the end of the + # declaration. + # + # > import Data.Bar + # > import Data.Foo qualified as F + # + # - false: Qualified remains in the default location and unqualified + # imports are padded to align with qualified imports. + # + # > import Data.Bar + # > import qualified Data.Foo as F + # + # Default: false + post_qualify: false + + # Automatically group imports based on their module names, with + # a blank line separating each group. Groups are ordered in + # alphabetical order. + # + # By default, this groups by the first part of each module's + # name (Control.* will be grouped together, Data.*... etc), but + # this can be configured with the group_patterns setting. + # + # When enabled, this rewrites existing blank lines and groups. + # + # - true: Group imports by the first part of the module name. + # + # > import Control.Applicative + # > import Control.Monad + # > import Control.Monad.MonadError + # > + # > import Data.Functor + # + # - false: Keep import groups as-is (still sorting and + # formatting the imports within each group) + # + # > import Control.Monad + # > import Data.Functor + # > + # > import Control.Applicative + # > import Control.Monad.MonadError + # + # Default: false + group_imports: false + + # A list of rules specifying how to group modules and how to + # order the groups. + # + # Each rule has a match field; the rule only applies to module + # names matched by this pattern. Patterns are POSIX extended + # regular expressions; see the documentation of Text.Regex.TDFA + # for details: + # https://hackage.haskell.org/package/regex-tdfa-1.3.1.2/docs/Text-Regex-TDFA.html + # + # Rules are processed in order, so only the *first* rule that + # matches a specific module will apply. Any module names that do + # not match a single rule will be put into a single group at the + # end of the import block. + # + # Example: group MyApp modules first, with everything else in + # one group at the end. + # + # group_rules: + # - match: "^MyApp\\>" + # + # > import MyApp + # > import MyApp.Foo + # > + # > import Control.Monad + # > import MyApps + # > import Test.MyApp + # + # A rule can also optionally have a sub_group pattern. Imports + # that match the rule will be broken up into further groups by + # the part of the module name matched by the sub_group pattern. + # + # Example: group MyApp modules first, then everything else + # sub-grouped by the first part of the module name. + # + # group_rules: + # - match: "^MyApp\\>" + # - match: "." + # sub_group: "^[^.]+" + # + # > import MyApp + # > import MyApp.Foo + # > + # > import Control.Applicative + # > import Control.Monad + # > + # > import Data.Map + # + # A pattern only needs to match part of the module name, which + # could be in the middle. You can use ^pattern to anchor to the + # beginning of the module name, pattern$ to anchor to the end + # and ^pattern$ to force a full match. Example: + # + # - "Test\\." would match "Test.Foo" and "Foo.Test.Lib" + # - "^Test\\." would match "Test.Foo" but not "Foo.Test.Lib" + # - "\\.Test$" would match "Foo.Test" but not "Foo.Test.Lib" + # - "^Test$" would *only* match "Test" + # + # You can use \\< and \\> to anchor against the beginning and + # end of words, respectively. For example: + # + # - "^Test\\." would match "Test.Foo" but not "Test" or "Tests" + # - "^Test\\>" would match "Test.Foo" and "Test", but not + # "Tests" + # + # The default is a single rule that matches everything and + # sub-groups based on the first component of the module name. + # + # Default: [{ "match" : ".*", "sub_group": "^[^.]+" }] + group_rules: + - match: ".*" + sub_group: "^[^.]+" + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-# LANGUAGE #-}'. + # + # - vertical_compact: Similar to vertical, but use only one language pragma. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Language prefix to be used for pragma declaration, this allows you to + # use other options non case-sensitive like "language" or "Language". + # If a non correct String is provided, it will default to: LANGUAGE. + language_prefix: LANGUAGE + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. +# +# Set this to null to disable all line wrapping. +# +# Default: 80. +columns: 80 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes + +# Attempt to find the cabal file in ancestors of the current directory, and +# parse options (currently only language extensions) from that. +# +# Default: true +cabal: true diff --git a/flake.lock b/flake.lock index 88ad8b1f..8f82c5e5 100644 --- a/flake.lock +++ b/flake.lock @@ -1,323 +1,135 @@ { "nodes": { - "HTTP": { - "flake": false, - "locked": { - "lastModified": 1451647621, - "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", - "owner": "phadej", - "repo": "HTTP", - "rev": "9bc0996d412fef1787449d841277ef663ad9a915", - "type": "github" - }, - "original": { - "owner": "phadej", - "repo": "HTTP", - "type": "github" - } - }, - "cabal-32": { - "flake": false, - "locked": { - "lastModified": 1603716527, - "narHash": "sha256-sDbrmur9Zfp4mPKohCD8IDZfXJ0Tjxpmr2R+kg5PpSY=", - "owner": "haskell", - "repo": "cabal", - "rev": "94aaa8e4720081f9c75497e2735b90f6a819b08e", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.2", - "repo": "cabal", - "type": "github" - } - }, - "cabal-34": { - "flake": false, - "locked": { - "lastModified": 1622475795, - "narHash": "sha256-chwTL304Cav+7p38d9mcb+egABWmxo2Aq+xgVBgEb/U=", - "owner": "haskell", - "repo": "cabal", - "rev": "b086c1995cdd616fc8d91f46a21e905cc50a1049", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.4", - "repo": "cabal", - "type": "github" - } - }, - "cardano-shell": { - "flake": false, - "locked": { - "lastModified": 1608537748, - "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", - "owner": "input-output-hk", - "repo": "cardano-shell", - "rev": "9392c75087cb9a3d453998f4230930dea3a95725", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "cardano-shell", - "type": "github" - } - }, - "easy-ps": { - "flake": false, - "locked": { - "lastModified": 1631961521, - "narHash": "sha256-1yPjUdOYzw1+UGFzBXbyZqEbsM6XZu/6+v8W35qFdLo=", - "owner": "justinwoo", - "repo": "easy-purescript-nix", - "rev": "d9a37c75ed361372e1545f6efbc08d819b3c28c8", - "type": "github" - }, - "original": { - "owner": "justinwoo", - "repo": "easy-purescript-nix", - "type": "github" - } - }, - "flake-utils": { - "locked": { - "lastModified": 1631561581, - "narHash": "sha256-3VQMV5zvxaVLvqqUrNz3iJelLw30mIVSfZmAaauM3dA=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "7e5bf3925f6fbdfaf50a2a7ca0be2879c4261d19", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_2": { - "locked": { - "lastModified": 1623875721, - "narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "f7e004a55b120c02ecb6219596820fcd32ca8772", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "ghc-8.6.5-iohk": { - "flake": false, - "locked": { - "lastModified": 1600920045, - "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", - "owner": "input-output-hk", - "repo": "ghc", - "rev": "95713a6ecce4551240da7c96b6176f980af75cae", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "release/8.6.5-iohk", - "repo": "ghc", - "type": "github" - } - }, - "hackage": { - "flake": false, - "locked": { - "lastModified": 1633396333, - "narHash": "sha256-mq7OoYa7ODDoKzUxR8xuEtQ0F0LO9I5uZG9DTZY+A/U=", - "owner": "input-output-hk", - "repo": "hackage.nix", - "rev": "0b33cf7ca5f152a6b3acda375433a6bc86f8d3e7", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "hackage.nix", - "type": "github" - } - }, - "haskellNix": { + "flake-parts": { "inputs": { - "HTTP": "HTTP", - "cabal-32": "cabal-32", - "cabal-34": "cabal-34", - "cardano-shell": "cardano-shell", - "flake-utils": "flake-utils_2", - "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "hackage": "hackage", - "hpc-coveralls": "hpc-coveralls", - "nix-tools": "nix-tools", - "nixpkgs": [ - "haskellNix", - "nixpkgs-2105" - ], - "nixpkgs-2003": "nixpkgs-2003", - "nixpkgs-2009": "nixpkgs-2009", - "nixpkgs-2105": "nixpkgs-2105", - "nixpkgs-unstable": "nixpkgs-unstable", - "old-ghc-nix": "old-ghc-nix", - "stackage": "stackage" + "nixpkgs-lib": "nixpkgs-lib" }, "locked": { - "lastModified": 1633435111, - "narHash": "sha256-0wYA9+2BZXFGj241f4W66nbvP2s+bbikOa39CZQP05A=", - "owner": "input-output-hk", - "repo": "haskell.nix", - "rev": "56f22053e647efcad0b5ee9c32334d5d4214bcde", + "lastModified": 1693611461, + "narHash": "sha256-aPODl8vAgGQ0ZYFIRisxYG5MOGSkIczvu2Cd8Gb9+1Y=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "7f53fdb7bdc5bb237da7fefef12d099e4fd611ca", "type": "github" }, "original": { - "owner": "input-output-hk", - "repo": "haskell.nix", + "owner": "hercules-ci", + "repo": "flake-parts", "type": "github" } }, - "hpc-coveralls": { - "flake": false, + "flake-root": { "locked": { - "lastModified": 1607498076, - "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", - "owner": "sevanspowell", - "repo": "hpc-coveralls", - "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "lastModified": 1692742795, + "narHash": "sha256-f+Y0YhVCIJ06LemO+3Xx00lIcqQxSKJHXT/yk1RTKxw=", + "owner": "srid", + "repo": "flake-root", + "rev": "d9a70d9c7a5fd7f3258ccf48da9335e9b47c3937", "type": "github" }, "original": { - "owner": "sevanspowell", - "repo": "hpc-coveralls", + "owner": "srid", + "repo": "flake-root", "type": "github" } }, - "nix-tools": { - "flake": false, + "haskell-flake": { "locked": { - "lastModified": 1627889534, - "narHash": "sha256-9eEbK2nrRp6rYGQoBv6LO9IA/ANZpofwAkxMuGBD45Y=", - "owner": "input-output-hk", - "repo": "nix-tools", - "rev": "15d2e4b61cb63ff351f3c490c12c4d89eafd31a1", + "lastModified": 1694478711, + "narHash": "sha256-zW/saV4diypxwP56b8l93Nw8fR7tXLbOFku2I+xYCxU=", + "owner": "srid", + "repo": "haskell-flake", + "rev": "ddc704f3f62d3d3569ced794b534e8fd065c379c", "type": "github" }, "original": { - "owner": "input-output-hk", - "repo": "nix-tools", + "owner": "srid", + "repo": "haskell-flake", "type": "github" } }, - "nixpkgs-2003": { + "nixpkgs": { "locked": { - "lastModified": 1620055814, - "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", - "owner": "NixOS", + "lastModified": 1694860878, + "narHash": "sha256-QlGC/nuBXKpajyt36nzEDuiNICSvm4hY9ESIFJVHU+k=", + "owner": "nixos", "repo": "nixpkgs", - "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", + "rev": "7386d0ab04f22db72aa99c9b43572a5aeddcf95c", "type": "github" }, "original": { - "owner": "NixOS", - "ref": "nixpkgs-20.03-darwin", + "owner": "nixos", + "ref": "haskell-updates", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-2009": { + "nixpkgs-lib": { "locked": { - "lastModified": 1624271064, - "narHash": "sha256-qns/uRW7MR2EfVf6VEeLgCsCp7pIOjDeR44JzTF09MA=", + "dir": "lib", + "lastModified": 1693471703, + "narHash": "sha256-0l03ZBL8P1P6z8MaSDS/MvuU8E75rVxe5eE1N6gxeTo=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "46d1c3f28ca991601a53e9a14fdd53fcd3dd8416", + "rev": "3e52e76b70d5508f3cec70b882a29199f4d1ee85", "type": "github" }, "original": { + "dir": "lib", "owner": "NixOS", - "ref": "nixpkgs-20.09-darwin", + "ref": "nixos-unstable", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs-2105": { - "locked": { - "lastModified": 1630481079, - "narHash": "sha256-leWXLchbAbqOlLT6tju631G40SzQWPqaAXQG3zH1Imw=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "110a2c9ebbf5d4a94486854f18a37a938cfacbbb", - "type": "github" + "purescript-overlay": { + "inputs": { + "nixpkgs": [ + "nixpkgs" + ], + "slimlock": "slimlock" }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-21.05-darwin", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-unstable": { "locked": { - "lastModified": 1628785280, - "narHash": "sha256-2B5eMrEr6O8ff2aQNeVxTB+9WrGE80OB4+oM6T7fOcc=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "6525bbc06a39f26750ad8ee0d40000ddfdc24acb", + "lastModified": 1694484110, + "narHash": "sha256-QXxECuZwRl+Mr+7OfhQSmTWaKsI6RjvBqjqMOxMBtPg=", + "owner": "thomashoneyman", + "repo": "purescript-overlay", + "rev": "7591ffe2adb930305e5e7c4be19c3a7cc8a4ee7b", "type": "github" }, "original": { - "owner": "NixOS", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", + "owner": "thomashoneyman", + "repo": "purescript-overlay", "type": "github" } }, - "old-ghc-nix": { - "flake": false, - "locked": { - "lastModified": 1631092763, - "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", - "owner": "angerman", - "repo": "old-ghc-nix", - "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", - "type": "github" - }, - "original": { - "owner": "angerman", - "ref": "master", - "repo": "old-ghc-nix", - "type": "github" + "root": { + "inputs": { + "flake-parts": "flake-parts", + "flake-root": "flake-root", + "haskell-flake": "haskell-flake", + "nixpkgs": "nixpkgs", + "purescript-overlay": "purescript-overlay" } }, - "root": { + "slimlock": { "inputs": { - "easy-ps": "easy-ps", - "flake-utils": "flake-utils", - "haskellNix": "haskellNix", "nixpkgs": [ - "haskellNix", - "nixpkgs-unstable" + "purescript-overlay", + "nixpkgs" ] - } - }, - "stackage": { - "flake": false, + }, "locked": { - "lastModified": 1633224172, - "narHash": "sha256-Hw2jWJiS6ky0D5BhSyaw5PItzmTpRni4BUcCJmbESWk=", - "owner": "input-output-hk", - "repo": "stackage.nix", - "rev": "948c9bde3d0b3aa452e0b19c34ae6385ac563160", + "lastModified": 1688610262, + "narHash": "sha256-Wg0ViDotFWGWqKIQzyYCgayeH8s4U1OZcTiWTQYdAp4=", + "owner": "thomashoneyman", + "repo": "slimlock", + "rev": "b5c6cdcaf636ebbebd0a1f32520929394493f1a6", "type": "github" }, "original": { - "owner": "input-output-hk", - "repo": "stackage.nix", + "owner": "thomashoneyman", + "repo": "slimlock", "type": "github" } } diff --git a/flake.nix b/flake.nix index 67527868..1260bdec 100644 --- a/flake.nix +++ b/flake.nix @@ -1,50 +1,64 @@ { - description = "Generate PureScript data types from Haskell data types"; - inputs.haskellNix.url = "github:input-output-hk/haskell.nix"; - inputs.nixpkgs.follows = "haskellNix/nixpkgs-unstable"; - inputs.flake-utils.url = "github:numtide/flake-utils"; - inputs.easy-ps = { - url = "github:justinwoo/easy-purescript-nix"; - flake = false; + inputs = { + nixpkgs.url = "github:nixos/nixpkgs/haskell-updates"; + flake-parts.url = "github:hercules-ci/flake-parts"; + haskell-flake.url = "github:srid/haskell-flake"; + flake-root.url = "github:srid/flake-root"; + purescript-overlay.url = "github:thomashoneyman/purescript-overlay"; + purescript-overlay.inputs.nixpkgs.follows = "nixpkgs"; }; - outputs = { self, nixpkgs, flake-utils, haskellNix, easy-ps }: - flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system: - let - overlays = [ - haskellNix.overlay - (final: prev: { - # This overlay adds our project to pkgs - purescript-bridge = - final.haskell-nix.project' { - src = ./.; - compiler-nix-name = "ghc8107"; - }; - }) - ]; - pkgs = import nixpkgs { inherit system overlays; inherit (haskellNix) config; }; - flake = pkgs.purescript-bridge.flake { }; - in - flake // { - # Built by `nix build .` - defaultPackage = flake.packages."purescript-bridge:test:purescript-bridge"; - devShell = pkgs.purescript-bridge.shellFor { - withHoogle = true; - tools = { - cabal = "latest"; - hlint = "latest"; - haskell-language-server = "latest"; + outputs = inputs@{ self, nixpkgs, haskell-flake, flake-root, flake-parts, purescript-overlay }: + flake-parts.lib.mkFlake { inherit inputs; } { + systems = nixpkgs.lib.systems.flakeExposed; + imports = [ + haskell-flake.flakeModule + flake-root.flakeModule + ]; + + perSystem = { self', pkgs, system, config,... }: { + + # https://flake.parts/overlays#consuming-an-overlay + _module.args.pkgs = import inputs.nixpkgs { + inherit system; + overlays = [ + purescript-overlay.overlays.default + ]; + }; + + haskellProjects.default = { + basePackages = pkgs.haskellPackages; + devShell = { + enable = true; + mkShellArgs = { + shellHook = '' + export LD_LIBRARY_PATH=${pkgs.zlib.out}/lib:LD_LIBRARY_PATH + ''; + }; + tools = haskellPackages: { + inherit (haskellPackages) + zlib; + }; + hlsCheck.enable = false; }; - exactDeps = true; + # exclude devShell, fixes duplicate definition + autoWire = [ "packages" "apps" "checks" ]; + }; - buildInputs = with pkgs; with import easy-ps { inherit pkgs; }; [ - ghcid - nixpkgs-fmt - purs - purescript-language-server - spago - haskellPackages.ormolu + devShells.default = pkgs.mkShell { + inputsFrom = [ + config.haskellProjects.default.outputs.devShell + ]; + buildInputs = [ + pkgs.hello + pkgs.purs + pkgs.spago + pkgs.purs-tidy-bin.purs-tidy-0_10_0 + pkgs.purs-backend-es ]; }; - }); + + packages.default = self'.packages.example; + }; + }; } From 94c66ef8eef8e8b0b3098841c08a6bca6e2f7166 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 23 Sep 2023 20:58:14 -0700 Subject: [PATCH 059/111] fix compilation --- test/RoundTrip/Spec.hs | 4 ++-- test/Spec.hs | 10 ++++++---- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index d0be4291..fea30a55 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -19,8 +19,8 @@ import Language.PureScript.Bridge.TypeParameters (A) import RoundTrip.Types import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) -import System.IO (BufferMode (..), hFlush, hPutStrLn, hSetBuffering, stderr, stdout) -import System.Process (CreateProcess (std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess, waitForProcess) +import System.IO (BufferMode (..), hFlush, hGetLine, hPutStrLn, hSetBuffering, stderr, stdout) +import System.Process (CreateProcess (std_err, std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess, waitForProcess) import Test.HUnit (assertBool, assertEqual) import Test.Hspec (Spec, around, aroundAll_, around_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) diff --git a/test/Spec.hs b/test/Spec.hs index e5749087..7cfdda56 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -42,8 +42,8 @@ custom (SumType t cs is) = SumType t cs $ customInstance : is Custom $ CustomInstance [] (TypeInfo "" "Data.MyClass" "MyClass" [TypeInfo "" "" "Foo" []]) $ Explicit - [ InstanceMember "member1" ["foo", "bar"] "undefined" [], - InstanceMember "member2" [] "do\npure unit" [] + [ InstanceMember "member1" ["foo", "bar"] "undefined" [] mempty, + InstanceMember "member2" [] "do\npure unit" [] mempty ] customNewtypeDerived :: SumType 'Haskell -> SumType 'Haskell @@ -141,11 +141,13 @@ allTests = do ] in doc `shouldRender` txt it "tests the generation of a whole (dummy) module" $ - let advanced' = + let advanced' :: SumType 'PureScript + advanced' = bridgeSumType (buildBridge defaultBridge) (mkSumType @(Bar A B M1 C)) - modules = sumTypeToModule advanced' + modules :: Modules + modules = sumTypeToModule Nothing advanced' m = head . map (moduleToText settings) . Map.elems $ modules txt = T.unlines From faf275c134f5edf1addbc8191b804a66233cd92e Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 3 Sep 2023 22:23:58 -0700 Subject: [PATCH 060/111] `nix flake update` latest `haskell-flake` also uses https://github.com/thomashoneyman/purescript-overlay --- cabal.project | 2 ++ flake.lock | 12 ++++++------ flake.nix | 3 ++- 3 files changed, 10 insertions(+), 7 deletions(-) create mode 100644 cabal.project diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..16714401 --- /dev/null +++ b/cabal.project @@ -0,0 +1,2 @@ +packages: + . diff --git a/flake.lock b/flake.lock index 8f82c5e5..9f62781d 100644 --- a/flake.lock +++ b/flake.lock @@ -50,11 +50,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1694860878, - "narHash": "sha256-QlGC/nuBXKpajyt36nzEDuiNICSvm4hY9ESIFJVHU+k=", + "lastModified": 1695514369, + "narHash": "sha256-TYDSsIKC8vVcb6zuYWRhBCYLsXhy6gf5bdfGCJXRj7w=", "owner": "nixos", "repo": "nixpkgs", - "rev": "7386d0ab04f22db72aa99c9b43572a5aeddcf95c", + "rev": "0da5b5291d61e99250200db9679fba55b53858b6", "type": "github" }, "original": { @@ -90,11 +90,11 @@ "slimlock": "slimlock" }, "locked": { - "lastModified": 1694484110, - "narHash": "sha256-QXxECuZwRl+Mr+7OfhQSmTWaKsI6RjvBqjqMOxMBtPg=", + "lastModified": 1695218028, + "narHash": "sha256-oAu9RmKS16rwBBAFxcnMcmoO4t6XQ31x95Ud1TR5fr4=", "owner": "thomashoneyman", "repo": "purescript-overlay", - "rev": "7591ffe2adb930305e5e7c4be19c3a7cc8a4ee7b", + "rev": "401552c582779260472f2111bc98f146790b19be", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 1260bdec..04781d83 100644 --- a/flake.nix +++ b/flake.nix @@ -55,10 +55,11 @@ pkgs.spago pkgs.purs-tidy-bin.purs-tidy-0_10_0 pkgs.purs-backend-es + pkgs.purescript-language-server ]; }; - packages.default = self'.packages.example; + packages.default = self'.packages.purescript-bridge; }; }; } From b5fbac0dbdfac82e230d46082a895c49bbb9aed7 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 23 Sep 2023 21:06:18 -0700 Subject: [PATCH 061/111] format with Fourmolu and then Stylish Haskell ``` fourmolu -i src --comma-style leading --import-export-style leading --function-arrows leading --indentation 4 --record-brace-space true fourmolu -i test --comma-style leading --import-export-style leading --function-arrows leading --indentation 4 --record-brace-space true find . -name '*.hs' | xargs stylish-haskell -i ``` to reduce diffs from parent repository --- Setup.hs | 2 +- src/Language/PureScript/Bridge.hs | 284 ++++--- src/Language/PureScript/Bridge/Builder.hs | 385 +++++---- .../PureScript/Bridge/CodeGenSwitches.hs | 24 +- src/Language/PureScript/Bridge/PSTypes.hs | 108 +-- src/Language/PureScript/Bridge/Primitives.hs | 38 +- src/Language/PureScript/Bridge/Printer.hs | 799 +++++++++--------- src/Language/PureScript/Bridge/SumType.hs | 280 +++--- src/Language/PureScript/Bridge/Tuple.hs | 29 +- src/Language/PureScript/Bridge/TypeInfo.hs | 90 +- .../PureScript/Bridge/TypeParameters.hs | 128 +-- test/RoundTrip/Spec.hs | 166 ++-- test/RoundTrip/Types.hs | 205 ++--- test/Spec.hs | 492 ++++++----- test/TestData.hs | 89 +- 15 files changed, 1569 insertions(+), 1550 deletions(-) diff --git a/Setup.hs b/Setup.hs index 9a994af6..44671092 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index 2fd5c553..7a2f9051 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -1,138 +1,141 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Bridge - ( bridgeSumType, - defaultBridge, - module Bridge, - writePSTypes, - writePSTypesWith, - writePSTypesWithNamespace, - defaultSwitch, - noLenses, - genLenses, - ) + ( bridgeSumType + , defaultBridge + , module Bridge + , writePSTypes + , writePSTypesWith + , writePSTypesWithNamespace + , defaultSwitch + , noLenses + , genLenses + ) where -import Control.Applicative -import Control.Lens (over, traversed) +import Control.Applicative +import Control.Lens (over, traversed) import qualified Data.Map as M import qualified Data.Set as Set import qualified Data.Text.IO as T -import Language.PureScript.Bridge.Builder as Bridge -import Language.PureScript.Bridge.CodeGenSwitches as Switches -import Language.PureScript.Bridge.Primitives as Bridge -import Language.PureScript.Bridge.Printer as Bridge -import Language.PureScript.Bridge.SumType as Bridge -import Language.PureScript.Bridge.Tuple as Bridge -import Language.PureScript.Bridge.TypeInfo as Bridge - --- | Your entry point to this library and quite likely all you will need. --- Make sure all your types derive `Generic` and `Typeable`. --- Typeable is not needed from ghc-7.10 on. --- --- Then list all your types you want to use in PureScript and call 'writePSTypes': --- --- > data Foo = Foo { ... } deriving (Eq, Generic) --- > data Bar = A | B | C deriving (Eq, Ord, Generic) --- > data Baz = ... deriving (Generic) --- > --- > -- | All types will have a `Generic` instance produced in Purescript. --- > myTypes :: [SumType 'Haskell] --- > myTypes = --- > [ equal (mkSumType @Foo) -- Also produce a `Eq` instance. --- > , order (mkSumType @Bar) -- Produce both `Eq` and `Ord`. --- > , mkSumType @Baz -- Just produce a `Generic` instance. --- > ] --- > --- > writePSTypes "path/to/your/purescript/project" (buildBridge defaultBridge) myTypes --- --- You can define your own type bridges based on 'defaultBridge': --- --- --- > myBridge = defaultBridge <|> mySpecialTypeBridge --- --- and use it with 'writePSTypes': --- --- > writePSTypes "path/to/your/purescript/project" (buildBridge myBridge) myTypes --- --- Find examples for implementing your own bridges in: "Language.PureScript.Bridge.Primitives". --- --- == Result: --- 'writePSTypes' will write out PureScript modules to the given path, mirroring the hierarchy of the Haskell modules --- the types came from. In addition a list of needed PS packages is printed to the console. --- --- The list of needed packages is retrieved from the bridged 'TypeInfo' data, so make sure you set '_typePackage' correctly --- in your own bridges, in order for this feature to be useful. --- --- == Real world usage example (at time of this writing outdated, at time of reading hopefully fixed): --- A real world use case of this library can be found . --- --- With custom bridges defined and --- custom PS types defined . --- --- Parts of the generated output can be found . --- --- Note how 'Secret' and 'Key' --- get translated according to our custom rules, with correct imports and everything. --- Also the formatting is quite nice, would you have guessed that this code was generated? --- --- == /WARNING/: --- This function overwrites files - make backups or use version control! +import Language.PureScript.Bridge.Builder as Bridge +import Language.PureScript.Bridge.CodeGenSwitches as Switches +import Language.PureScript.Bridge.Primitives as Bridge +import Language.PureScript.Bridge.Printer as Bridge +import Language.PureScript.Bridge.SumType as Bridge +import Language.PureScript.Bridge.Tuple as Bridge +import Language.PureScript.Bridge.TypeInfo as Bridge + +{- | Your entry point to this library and quite likely all you will need. + Make sure all your types derive `Generic` and `Typeable`. + Typeable is not needed from ghc-7.10 on. + + Then list all your types you want to use in PureScript and call 'writePSTypes': + + > data Foo = Foo { ... } deriving (Eq, Generic) + > data Bar = A | B | C deriving (Eq, Ord, Generic) + > data Baz = ... deriving (Generic) + > + > -- | All types will have a `Generic` instance produced in Purescript. + > myTypes :: [SumType 'Haskell] + > myTypes = + > [ equal (mkSumType @Foo) -- Also produce a `Eq` instance. + > , order (mkSumType @Bar) -- Produce both `Eq` and `Ord`. + > , mkSumType @Baz -- Just produce a `Generic` instance. + > ] + > + > writePSTypes "path/to/your/purescript/project" (buildBridge defaultBridge) myTypes + + You can define your own type bridges based on 'defaultBridge': + + + > myBridge = defaultBridge <|> mySpecialTypeBridge + + and use it with 'writePSTypes': + + > writePSTypes "path/to/your/purescript/project" (buildBridge myBridge) myTypes + + Find examples for implementing your own bridges in: "Language.PureScript.Bridge.Primitives". + + == Result: + 'writePSTypes' will write out PureScript modules to the given path, mirroring the hierarchy of the Haskell modules + the types came from. In addition a list of needed PS packages is printed to the console. + + The list of needed packages is retrieved from the bridged 'TypeInfo' data, so make sure you set '_typePackage' correctly + in your own bridges, in order for this feature to be useful. + + == Real world usage example (at time of this writing outdated, at time of reading hopefully fixed): + A real world use case of this library can be found . + + With custom bridges defined and + custom PS types defined . + + Parts of the generated output can be found . + + Note how 'Secret' and 'Key' + get translated according to our custom rules, with correct imports and everything. + Also the formatting is quite nice, would you have guessed that this code was generated? + + == /WARNING/: + This function overwrites files - make backups or use version control! +-} writePSTypes :: FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypes = writePSTypesWith Switches.defaultSwitch --- | Works like `writePSTypes` but you can add additional switches to control the generation of your PureScript code --- --- == Switches/Settings: --- --- - `noLenses` and `genLenses` to control if the `purescript-profunctor-lenses` are generated for your types --- --- == /WARNING/: --- This function overwrites files - make backups or use version control! +{- | Works like `writePSTypes` but you can add additional switches to control the generation of your PureScript code + + == Switches/Settings: + + - `noLenses` and `genLenses` to control if the `purescript-profunctor-lenses` are generated for your types + + == /WARNING/: + This function overwrites files - make backups or use version control! +-} writePSTypesWith :: Switches.Switch -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypesWith switch = writePSTypesWithNamespace switch Nothing -writePSTypesWithNamespace :: - Switches.Switch -> Maybe PackageName -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () +writePSTypesWithNamespace + :: Switches.Switch -> Maybe PackageName -> FilePath -> FullBridge -> [SumType 'Haskell] -> IO () writePSTypesWithNamespace switch packageName root bridge sts = do - mapM_ (printModule settings root) modules - T.putStrLn - "The following purescript packages are needed by the generated code:\n" - mapM_ (T.putStrLn . mappend " - ") packages - T.putStrLn "\nSuccessfully created your PureScript modules!" + mapM_ (printModule settings root) modules + T.putStrLn + "The following purescript packages are needed by the generated code:\n" + mapM_ (T.putStrLn . mappend " - ") packages + T.putStrLn "\nSuccessfully created your PureScript modules!" where settings = Switches.getSettings switch bridged = map (bridgeSumType bridge) sts modules = M.elems $ sumTypesToModules packageName bridged packages = - sumTypesToNeededPackages bridged - <> Set.filter - (const $ Switches.generateLenses settings) - (Set.singleton "purescript-profunctor-lenses") - --- | Translate all 'TypeInfo' values in a 'SumType' to PureScript types. --- --- Example usage, with defaultBridge: --- --- > data Foo = Foo | Bar Int | FooBar Int Text deriving (Generic, Typeable, Show) --- --- > bridgeSumType (buildBridge defaultBridge) (mkSumType @Foo) + sumTypesToNeededPackages bridged + <> Set.filter + (const $ Switches.generateLenses settings) + (Set.singleton "purescript-profunctor-lenses") + +{- | Translate all 'TypeInfo' values in a 'SumType' to PureScript types. + + Example usage, with defaultBridge: + +> data Foo = Foo | Bar Int | FooBar Int Text deriving (Generic, Typeable, Show) + +> bridgeSumType (buildBridge defaultBridge) (mkSumType @Foo) +-} bridgeSumType :: FullBridge -> SumType 'Haskell -> SumType 'PureScript bridgeSumType br (SumType t cs is) = - SumType (br t) (map (bridgeConstructor br) cs) $ bridgeInstance <$> (is <> extraInstances) + SumType (br t) (map (bridgeConstructor br) cs) $ bridgeInstance <$> (is <> extraInstances) where bridgeInstance (Custom CustomInstance {..}) = - Custom $ - CustomInstance - (br <$> _customConstraints) - (br _customHead) - case _customImplementation of - Derive -> Derive - DeriveNewtype -> DeriveNewtype - Explicit members -> Explicit $ bridgeMember <$> members + Custom $ + CustomInstance + (br <$> _customConstraints) + (br _customHead) + case _customImplementation of + Derive -> Derive + DeriveNewtype -> DeriveNewtype + Explicit members -> Explicit $ bridgeMember <$> members bridgeInstance Bounded = Bounded bridgeInstance Enum = Enum bridgeInstance Json = Json @@ -145,44 +148,45 @@ bridgeSumType br (SumType t cs is) = bridgeInstance Newtype = Newtype bridgeMember = over (memberDependencies . traversed) br extraInstances - | not (null cs) && all isNullary cs = [Enum, Bounded] - | otherwise = [] + | not (null cs) && all isNullary cs = [Enum, Bounded] + | otherwise = [] isNullary (DataConstructor _ args) = args == Nullary --- | Default bridge for mapping primitive/common types: --- You can append your own bridges like this: --- --- > defaultBridge <|> myBridge1 <|> myBridge2 --- --- Find examples for bridge definitions in "Language.PureScript.Bridge.Primitives" and --- "Language.PureScript.Bridge.Tuple". +{- | Default bridge for mapping primitive/common types: + You can append your own bridges like this: + +> defaultBridge <|> myBridge1 <|> myBridge2 + + Find examples for bridge definitions in "Language.PureScript.Bridge.Primitives" and + "Language.PureScript.Bridge.Tuple". +-} defaultBridge :: BridgePart defaultBridge = - textBridge - <|> stringBridge - <|> listBridge - <|> maybeBridge - <|> eitherBridge - <|> boolBridge - <|> intBridge - <|> doubleBridge - <|> tupleBridge - <|> unitBridge - <|> mapBridge - <|> setBridge - <|> noContentBridge + textBridge + <|> stringBridge + <|> listBridge + <|> maybeBridge + <|> eitherBridge + <|> boolBridge + <|> intBridge + <|> doubleBridge + <|> tupleBridge + <|> unitBridge + <|> mapBridge + <|> setBridge + <|> noContentBridge -- | Translate types in a constructor. -bridgeConstructor :: - FullBridge -> DataConstructor 'Haskell -> DataConstructor 'PureScript +bridgeConstructor + :: FullBridge -> DataConstructor 'Haskell -> DataConstructor 'PureScript bridgeConstructor _ (DataConstructor name Nullary) = - DataConstructor name Nullary + DataConstructor name Nullary bridgeConstructor br (DataConstructor name (Normal infos)) = - DataConstructor name . Normal $ fmap br infos + DataConstructor name . Normal $ fmap br infos bridgeConstructor br (DataConstructor name (Record record)) = - DataConstructor name . Record $ fmap (bridgeRecordEntry br) record + DataConstructor name . Record $ fmap (bridgeRecordEntry br) record -- | Translate types in a record entry. -bridgeRecordEntry :: - FullBridge -> RecordEntry 'Haskell -> RecordEntry 'PureScript +bridgeRecordEntry + :: FullBridge -> RecordEntry 'Haskell -> RecordEntry 'PureScript bridgeRecordEntry br (RecordEntry label value) = RecordEntry label $ br value diff --git a/src/Language/PureScript/Bridge/Builder.hs b/src/Language/PureScript/Bridge/Builder.hs index eb8bcd08..1d0c8b01 100644 --- a/src/Language/PureScript/Bridge/Builder.hs +++ b/src/Language/PureScript/Bridge/Builder.hs @@ -1,237 +1,250 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | A bridge builder DSL, powered by 'Monad', 'Alternative' and lens. --- --- Bridges can be built within the 'BridgeBuilder' monad. --- You can check properties of the to-be-bridged 'HaskellType' with '^==' or 'doCheck', --- you have choice ('<|>'), you can fail ('empty') and you can return a translated --- 'PSType' ('return'). The 'HaskellType' can be accessed with: --- --- > view haskType --- --- Find usage examples in "Language.PureScript.Bridge.Primitives" and "Language.PureScript.Bridge.PSTypes" +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{- | A bridge builder DSL, powered by 'Monad', 'Alternative' and lens. + + Bridges can be built within the 'BridgeBuilder' monad. + You can check properties of the to-be-bridged 'HaskellType' with '^==' or 'doCheck', + you have choice ('<|>'), you can fail ('empty') and you can return a translated + 'PSType' ('return'). The 'HaskellType' can be accessed with: + +> view haskType + + Find usage examples in "Language.PureScript.Bridge.Primitives" and "Language.PureScript.Bridge.PSTypes" +-} module Language.PureScript.Bridge.Builder - ( BridgeBuilder, - BridgePart, - FixUpBuilder, - FixUpBridge, - BridgeData, - fullBridge, - (^==), - doCheck, - (<|>), - psTypeParameters, - FullBridge, - buildBridge, - clearPackageFixUp, - errorFixUp, - buildBridgeWithCustomFixUp, - ) + ( BridgeBuilder + , BridgePart + , FixUpBuilder + , FixUpBridge + , BridgeData + , fullBridge + , (^==) + , doCheck + , (<|>) + , psTypeParameters + , FullBridge + , buildBridge + , clearPackageFixUp + , errorFixUp + , buildBridgeWithCustomFixUp + ) where -import Control.Applicative -import Control.Lens -import Control.Monad (MonadPlus, guard, mplus, mzero) -import Control.Monad.Reader.Class -import Control.Monad.Trans.Reader (Reader, ReaderT (..), runReader) -import Data.Maybe (fromMaybe) +import Control.Applicative +import Control.Lens +import Control.Monad (MonadPlus, guard, mplus, mzero) +import Control.Monad.Reader.Class +import Control.Monad.Trans.Reader (Reader, ReaderT (..), runReader) +import Data.Maybe (fromMaybe) import qualified Data.Text as T -import Language.PureScript.Bridge.TypeInfo +import Language.PureScript.Bridge.TypeInfo newtype BridgeBuilder a = BridgeBuilder (ReaderT BridgeData Maybe a) - deriving (Functor, Applicative, Monad, MonadReader BridgeData) + deriving (Applicative, Functor, Monad, MonadReader BridgeData) type BridgePart = BridgeBuilder PSType --- | Bridges to use when a 'BridgePart' returns 'Nothing' (See 'buildBridgeWithCustomFixUp'). --- --- It is similar to BridgeBuilder but does not offer choice or failure. It is used for constructing fallbacks --- if a 'BridgePart' evaluates to 'Nothing'. --- --- For type definitions you should use the more generic ('MonadReader' 'BridgeData' m) constraint. This way your code will work --- in both 'FixUpBuilder' and 'BridgeBuilder': --- --- > {-# LANGUAGE FlexibleContexts #-} --- > --- > import Control.Monad.Reader.Class --- > import Language.PureScript.Bridge.TypeInfo --- > --- > psEither :: MonadReader BridgeData m => m PSType --- > psEither = .... --- --- instead of: --- --- > psEither :: BridgePart --- > psEither = .... --- --- or --- --- > psEither :: FixUpBridge --- > psEither = .... +{- | Bridges to use when a 'BridgePart' returns 'Nothing' (See 'buildBridgeWithCustomFixUp'). + + It is similar to BridgeBuilder but does not offer choice or failure. It is used for constructing fallbacks + if a 'BridgePart' evaluates to 'Nothing'. + + For type definitions you should use the more generic ('MonadReader' 'BridgeData' m) constraint. This way your code will work + in both 'FixUpBuilder' and 'BridgeBuilder': + +> {\-# LANGUAGE FlexibleContexts #-\} +> +> import Control.Monad.Reader.Class +> import Language.PureScript.Bridge.TypeInfo +> +> psEither :: MonadReader BridgeData m => m PSType +> psEither = .... + + instead of: + +> psEither :: BridgePart +> psEither = .... + + or + +> psEither :: FixUpBridge +> psEither = .... +-} newtype FixUpBuilder a = FixUpBuilder (Reader BridgeData a) - deriving (Functor, Applicative, Monad, MonadReader BridgeData) + deriving (Applicative, Functor, Monad, MonadReader BridgeData) type FixUpBridge = FixUpBuilder PSType type FullBridge = HaskellType -> PSType data BridgeData = BridgeData - { -- | The Haskell type to translate. - _haskType :: HaskellType, - -- | Reference to the bridge itself, needed for translation of type constructors. - _fullBridge :: FullBridge + { _haskType :: HaskellType + -- ^ The Haskell type to translate. + , _fullBridge :: FullBridge + -- ^ Reference to the bridge itself, needed for translation of type constructors. } --- | By implementing the 'haskType' lens in the HasHaskType class, we are able --- to use it for both 'BridgeData' and a plain 'HaskellType', therefore --- you can use it with 'doCheck' and '^==' for checks on the complete 'HaskellType' --- value. --- --- Example: --- --- > stringBridge :: BridgePart --- > stringBridge = do --- > -- Note: we are using the HaskellType instance here: --- > haskType ^== mkTypeInfo @String --- > return psString +{- | By implementing the 'haskType' lens in the HasHaskType class, we are able + to use it for both 'BridgeData' and a plain 'HaskellType', therefore + you can use it with 'doCheck' and '^==' for checks on the complete 'HaskellType' + value. + + Example: + +> stringBridge :: BridgePart +> stringBridge = do +> -- Note: we are using the HaskellType instance here: +> haskType ^== mkTypeInfo @String +> return psString +-} instance HasHaskType BridgeData where - haskType inj (BridgeData iT fB) = flip BridgeData fB <$> inj iT + haskType inj (BridgeData iT fB) = flip BridgeData fB <$> inj iT + +{- | Lens for access to the complete bridge from within our Reader monad. --- | Lens for access to the complete bridge from within our Reader monad. --- --- This is used for example for implementing 'psTypeParameters'. + This is used for example for implementing 'psTypeParameters'. +-} fullBridge :: Lens' BridgeData FullBridge fullBridge inj (BridgeData iT fB) = BridgeData iT <$> inj fB --- | Bridge to PureScript by simply clearing out the '_typePackage' field. --- This bridge is used by default as 'FixUpBridge' by 'buildBridge': --- --- > buildBridge = buildBridgeWithCustomFixUp clearPackageFixUp --- --- Thus, if no bridge matches a type, it gets optimistically translated to a PureScript type --- which is idential to the Haskell type. Only the '_typePackage' field gets cleared, --- as it is very unlikely that the PureScript package is called the same as the Haskell package. --- --- Alternatively, if you are not that optimistic, you can use errorFixUp --- - which simply calls 'error' when used. --- --- > buildBridgeWithCustomFixUp errorFixUp yourBridge --- --- Of course you can also write your own 'FixUpBridge'. It works the same --- as for 'BridgePart', but you can not have choice ('<|>') or failure ('empty'). -clearPackageFixUp :: MonadReader BridgeData m => m PSType +{- | Bridge to PureScript by simply clearing out the '_typePackage' field. + This bridge is used by default as 'FixUpBridge' by 'buildBridge': + +> buildBridge = buildBridgeWithCustomFixUp clearPackageFixUp + + Thus, if no bridge matches a type, it gets optimistically translated to a PureScript type + which is idential to the Haskell type. Only the '_typePackage' field gets cleared, + as it is very unlikely that the PureScript package is called the same as the Haskell package. + + Alternatively, if you are not that optimistic, you can use errorFixUp + - which simply calls 'error' when used. + +> buildBridgeWithCustomFixUp errorFixUp yourBridge + + Of course you can also write your own 'FixUpBridge'. It works the same + as for 'BridgePart', but you can not have choice ('<|>') or failure ('empty'). +-} +clearPackageFixUp :: (MonadReader BridgeData m) => m PSType clearPackageFixUp = do - input <- view haskType - psArgs <- psTypeParameters - return - TypeInfo - { _typePackage = "", - _typeModule = input ^. typeModule, - _typeName = input ^. typeName, - _typeParameters = psArgs - } - --- | A 'FixUpBridge' which calles 'error' when used. --- Usage: --- --- > buildBridgeWithCustomFixUp errorFixUp yourBridge -errorFixUp :: MonadReader BridgeData m => m PSType + input <- view haskType + psArgs <- psTypeParameters + return + TypeInfo + { _typePackage = "" + , _typeModule = input ^. typeModule + , _typeName = input ^. typeName + , _typeParameters = psArgs + } + +{- | A 'FixUpBridge' which calles 'error' when used. + Usage: + +> buildBridgeWithCustomFixUp errorFixUp yourBridge +-} +errorFixUp :: (MonadReader BridgeData m) => m PSType errorFixUp = do - inType <- view haskType - let message = - "No translation supplied for Haskell type: '" <> inType ^. typeName - <> "', from module: '" - <> inType - ^. typeModule - <> "', from package: '" - <> inType - ^. typePackage - <> "'!" - return $ error $ T.unpack message - --- | Build a bridge. --- --- This is a convenience wrapper for 'buildBridgeWithCustomFixUp' and should normally be sufficient. --- --- Definition: --- --- > buildBridgeWithCustomFixUp clearPackageFixUp + inType <- view haskType + let message = + "No translation supplied for Haskell type: '" + <> inType ^. typeName + <> "', from module: '" + <> inType + ^. typeModule + <> "', from package: '" + <> inType + ^. typePackage + <> "'!" + return $ error $ T.unpack message + +{- | Build a bridge. + + This is a convenience wrapper for 'buildBridgeWithCustomFixUp' and should normally be sufficient. + + Definition: + +> buildBridgeWithCustomFixUp clearPackageFixUp +-} buildBridge :: BridgePart -> FullBridge buildBridge = buildBridgeWithCustomFixUp clearPackageFixUp --- | Takes a constructed BridgePart and makes it a total function ('FullBridge') --- by using the supplied 'FixUpBridge' when 'BridgePart' returns 'Nothing'. +{- | Takes a constructed BridgePart and makes it a total function ('FullBridge') + by using the supplied 'FixUpBridge' when 'BridgePart' returns 'Nothing'. +-} buildBridgeWithCustomFixUp :: FixUpBridge -> BridgePart -> FullBridge buildBridgeWithCustomFixUp (FixUpBuilder fixUp) (BridgeBuilder bridgePart) = - let mayBridge :: HaskellType -> Maybe PSType - mayBridge inType = runReaderT bridgePart $ BridgeData inType bridge - fixBridge inType = runReader fixUp $ BridgeData inType bridge - bridge inType = - fixTypeParameters $ fromMaybe (fixBridge inType) (mayBridge inType) - in bridge - --- | Translate types that come from any module named "Something.TypeParameters" to lower case: --- --- Also drop the 1 at the end if present. --- This method gets called by 'buildBridge' and buildBridgeWithCustomFixUp for you - you should not need to call it. --- --- It enables you to even bridge type constructor definitions, see "Language.PureScript.Bridge.TypeParameters" for more details. + let mayBridge :: HaskellType -> Maybe PSType + mayBridge inType = runReaderT bridgePart $ BridgeData inType bridge + fixBridge inType = runReader fixUp $ BridgeData inType bridge + bridge inType = + fixTypeParameters $ fromMaybe (fixBridge inType) (mayBridge inType) + in bridge + +{- | Translate types that come from any module named "Something.TypeParameters" to lower case: + + Also drop the 1 at the end if present. + This method gets called by 'buildBridge' and buildBridgeWithCustomFixUp for you - you should not need to call it. + + It enables you to even bridge type constructor definitions, see "Language.PureScript.Bridge.TypeParameters" for more details. +-} fixTypeParameters :: TypeInfo lang -> TypeInfo lang fixTypeParameters t = - if "TypeParameters" `T.isSuffixOf` _typeModule t - then - t - { _typePackage = "", -- Don't suggest any packages - _typeModule = "", -- Don't import any modules - _typeName = t ^. typeName . to (stripNum . T.toLower) - } - else t + if "TypeParameters" `T.isSuffixOf` _typeModule t + then + t + { _typePackage = "" -- Don't suggest any packages + , _typeModule = "" -- Don't import any modules + , _typeName = t ^. typeName . to (stripNum . T.toLower) + } + else t where stripNum v = fromMaybe v (T.stripSuffix "1" v) --- | Alternative instance for BridgeBuilder so you can construct bridges with '<|>', --- which behaves like a logical 'or' ('||'). If the left-hand side results in Nothing --- the right-hand side is used, otherwise the left-hand side. --- For usage examples see "Language.PureScript.Bridge.Primitives". +{- | Alternative instance for BridgeBuilder so you can construct bridges with '<|>', + which behaves like a logical 'or' ('||'). If the left-hand side results in Nothing + the right-hand side is used, otherwise the left-hand side. + For usage examples see "Language.PureScript.Bridge.Primitives". +-} instance Alternative BridgeBuilder where - empty = BridgeBuilder . ReaderT $ const Nothing - BridgeBuilder a <|> BridgeBuilder b = - BridgeBuilder . ReaderT $ \bridgeData -> - let ia = runReaderT a bridgeData - ib = runReaderT b bridgeData - in ia <|> ib + empty = BridgeBuilder . ReaderT $ const Nothing + BridgeBuilder a <|> BridgeBuilder b = + BridgeBuilder . ReaderT $ \bridgeData -> + let ia = runReaderT a bridgeData + ib = runReaderT b bridgeData + in ia <|> ib instance MonadPlus BridgeBuilder where - mzero = empty - mplus = (<|>) + mzero = empty + mplus = (<|>) -- | Do some check on properties of 'haskType'. doCheck :: Getter HaskellType a -> (a -> Bool) -> BridgeBuilder () doCheck l check = guard =<< views (haskType . l) check --- | Check parts of 'haskType' for equality: --- --- > textBridge :: BridgePart --- > textBridge = do --- > typeName ^== "Text" --- > typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" --- > return psString -(^==) :: Eq a => Getter HaskellType a -> a -> BridgeBuilder () +{- | Check parts of 'haskType' for equality: + +> textBridge :: BridgePart +> textBridge = do +> typeName ^== "Text" +> typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" +> return psString +-} +(^==) :: (Eq a) => Getter HaskellType a -> a -> BridgeBuilder () l ^== a = doCheck l (== a) infix 4 ^== --- | Bridge 'haskType' 'typeParameters' over to PureScript types. --- --- To be used for bridging type constructors. -psTypeParameters :: MonadReader BridgeData m => m [PSType] +{- | Bridge 'haskType' 'typeParameters' over to PureScript types. + + To be used for bridging type constructors. +-} +psTypeParameters :: (MonadReader BridgeData m) => m [PSType] psTypeParameters = map <$> view fullBridge <*> view (haskType . typeParameters) diff --git a/src/Language/PureScript/Bridge/CodeGenSwitches.hs b/src/Language/PureScript/Bridge/CodeGenSwitches.hs index edef1d1d..e7e61c14 100644 --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ b/src/Language/PureScript/Bridge/CodeGenSwitches.hs @@ -1,22 +1,20 @@ -- | General switches for the code generation, such as generating profunctor-lenses or not module Language.PureScript.Bridge.CodeGenSwitches - ( Settings (..), - defaultSettings, - Switch, - getSettings, - defaultSwitch, - noLenses, - genLenses, - ) + ( Settings (..) + , defaultSettings + , Switch + , getSettings + , defaultSwitch + , noLenses + , genLenses + ) where -import Data.Monoid (Endo (..)) +import Data.Monoid (Endo (..)) -- | General settings for code generation -newtype Settings = Settings - { -- | use purescript-profunctor-lens for generated PS-types? - generateLenses :: Bool - } +newtype Settings + = Settings { generateLenses :: Bool } deriving (Eq, Show) -- | Settings to generate Lenses diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs index 97d3ae04..1242a890 100644 --- a/src/Language/PureScript/Bridge/PSTypes.hs +++ b/src/Language/PureScript/Bridge/PSTypes.hs @@ -1,90 +1,90 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} -- | PureScript types to be used for bridges, e.g. in "Language.PureScript.Bridge.Primitives". module Language.PureScript.Bridge.PSTypes where -import Control.Lens (view) -import Control.Monad.Reader.Class -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.TypeInfo +import Control.Lens (view) +import Control.Monad.Reader.Class +import Language.PureScript.Bridge.Builder +import Language.PureScript.Bridge.TypeInfo -- | Uses type parameters from 'haskType' (bridged). -psArray :: MonadReader BridgeData m => m PSType +psArray :: (MonadReader BridgeData m) => m PSType psArray = TypeInfo "" "Prim" "Array" <$> psTypeParameters psBool :: PSType psBool = - TypeInfo - { _typePackage = "", - _typeModule = "Prim", - _typeName = "Boolean", - _typeParameters = [] - } + TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Boolean" + , _typeParameters = [] + } -- | Uses type parameters from 'haskType' (bridged). -psEither :: MonadReader BridgeData m => m PSType +psEither :: (MonadReader BridgeData m) => m PSType psEither = - TypeInfo "purescript-either" "Data.Either" "Either" <$> psTypeParameters + TypeInfo "purescript-either" "Data.Either" "Either" <$> psTypeParameters psInt :: PSType psInt = - TypeInfo - { _typePackage = "", - _typeModule = "Prim", - _typeName = "Int", - _typeParameters = [] - } + TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Int" + , _typeParameters = [] + } psNumber :: PSType psNumber = - TypeInfo - { _typePackage = "", - _typeModule = "Prim", - _typeName = "Number", - _typeParameters = [] - } + TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "Number" + , _typeParameters = [] + } -- | Uses type parameters from 'haskType' (bridged). -psMaybe :: MonadReader BridgeData m => m PSType +psMaybe :: (MonadReader BridgeData m) => m PSType psMaybe = TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" <$> psTypeParameters psString :: PSType psString = - TypeInfo - { _typePackage = "", - _typeModule = "Prim", - _typeName = "String", - _typeParameters = [] - } + TypeInfo + { _typePackage = "" + , _typeModule = "Prim" + , _typeName = "String" + , _typeParameters = [] + } -- | Uses type parameters from 'haskType' (bridged). -psTuple :: MonadReader BridgeData m => m PSType +psTuple :: (MonadReader BridgeData m) => m PSType psTuple = do - params <- view (haskType . typeParameters) - bridge <- view fullBridge - let computeTuple [] = psUnit - computeTuple [a] = bridge a - computeTuple [a, b] = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge a, bridge b] - computeTuple (h : t) = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge h, computeTuple t] - pure $ computeTuple params + params <- view (haskType . typeParameters) + bridge <- view fullBridge + let computeTuple [] = psUnit + computeTuple [a] = bridge a + computeTuple [a, b] = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge a, bridge b] + computeTuple (h : t) = TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" [bridge h, computeTuple t] + pure $ computeTuple params psUnit :: PSType psUnit = - TypeInfo - { _typePackage = "purescript-prelude", - _typeModule = "Prelude", - _typeName = "Unit", - _typeParameters = [] - } + TypeInfo + { _typePackage = "purescript-prelude" + , _typeModule = "Prelude" + , _typeName = "Unit" + , _typeParameters = [] + } -psMap :: MonadReader BridgeData m => m PSType +psMap :: (MonadReader BridgeData m) => m PSType psMap = - TypeInfo "purescript-ordered-collections" "Data.Map" "Map" <$> psTypeParameters + TypeInfo "purescript-ordered-collections" "Data.Map" "Map" <$> psTypeParameters -psSet :: MonadReader BridgeData m => m PSType +psSet :: (MonadReader BridgeData m) => m PSType psSet = - TypeInfo "purescript-ordered-collections" "Data.Set" "Set" <$> psTypeParameters + TypeInfo "purescript-ordered-collections" "Data.Set" "Set" <$> psTypeParameters diff --git a/src/Language/PureScript/Bridge/Primitives.hs b/src/Language/PureScript/Bridge/Primitives.hs index 1ab112ea..dc592804 100644 --- a/src/Language/PureScript/Bridge/Primitives.hs +++ b/src/Language/PureScript/Bridge/Primitives.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Language.PureScript.Bridge.Primitives where -import Control.Monad.Reader.Class -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.PSTypes -import Language.PureScript.Bridge.TypeInfo +import Control.Monad.Reader.Class +import Language.PureScript.Bridge.Builder +import Language.PureScript.Bridge.PSTypes +import Language.PureScript.Bridge.TypeInfo boolBridge :: BridgePart boolBridge = typeName ^== "Bool" >> return psBool @@ -18,18 +18,18 @@ eitherBridge = typeName ^== "Either" >> psEither setBridge :: BridgePart setBridge = do - typeName ^== "Set" - typeModule ^== "Data.Set" <|> typeModule ^== "Data.Set.Internal" - psSet + typeName ^== "Set" + typeModule ^== "Data.Set" <|> typeModule ^== "Data.Set.Internal" + psSet mapBridge :: BridgePart mapBridge = do - typeName ^== "Map" - typeModule ^== "Data.Map" <|> typeModule ^== "Data.Map.Internal" - psMap + typeName ^== "Map" + typeModule ^== "Data.Map" <|> typeModule ^== "Data.Map.Internal" + psMap -- | Dummy bridge, translates every type with 'clearPackageFixUp' -dummyBridge :: MonadReader BridgeData m => m PSType +dummyBridge :: (MonadReader BridgeData m) => m PSType dummyBridge = clearPackageFixUp intBridge :: BridgePart @@ -46,14 +46,14 @@ maybeBridge = typeName ^== "Maybe" >> psMaybe stringBridge :: BridgePart stringBridge = - haskType ^== mkTypeInfo @String >> return psString + haskType ^== mkTypeInfo @String >> return psString textBridge :: BridgePart textBridge = do - typeName ^== "Text" - typeModule ^== "Data.Text.Internal" - <|> typeModule ^== "Data.Text.Internal.Lazy" - return psString + typeName ^== "Text" + typeModule ^== "Data.Text.Internal" + <|> typeModule ^== "Data.Text.Internal.Lazy" + return psString unitBridge :: BridgePart unitBridge = typeName ^== "()" >> return psUnit diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 49bdddf7..5cc515cb 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -1,109 +1,72 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Bridge.Printer where -import Control.Arrow ((&&&)) -import Control.Lens (to, (%~), (<>~), (^.)) -import Control.Monad (unless) -import Data.Char (isLower) -import Data.Function (on, (&)) -import Data.List (groupBy, nubBy, sortBy) -import Data.List.NonEmpty (NonEmpty ((:|))) +import Control.Arrow ((&&&)) +import Control.Lens (to, (%~), (<>~), (^.)) +import Control.Monad (unless) +import Data.Char (isLower) +import qualified Data.Char as C +import Data.Function (on, (&)) +import Data.List (groupBy, nubBy, sortBy) +import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, isJust) -import Data.Set (Set) +import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches -import Language.PureScript.Bridge.PSTypes (psUnit) -import Language.PureScript.Bridge.SumType - ( CustomInstance (..), - DataConstructor (..), - DataConstructorArgs (..), - ImportLine (..), - ImportLines, - Instance (..), - InstanceImplementation (..), - InstanceMember (..), - PSInstance, - RecordEntry (..), - SumType (SumType), - getUsedTypes, - importsFromList, - instanceToImportLines, - nootype, - recLabel, - recValue, - sigConstructor, - _recLabel, - ) -import Language.PureScript.Bridge.TypeInfo - ( Language (PureScript), - PSType, - TypeInfo (TypeInfo), - flattenTypeInfo, - typeName, - _typeModule, - _typeName, - _typePackage, - _typeParameters, - ) -import System.Directory - ( createDirectoryIfMissing, - doesDirectoryExist, - ) -import System.FilePath - ( joinPath, - takeDirectory, - (), - ) -import Text.PrettyPrint.Leijen.Text - ( Doc, - backslash, - char, - colon, - comma, - displayTStrict, - dquotes, - hang, - hsep, - indent, - lbrace, - lbracket, - line, - linebreak, - lparen, - nest, - parens, - punctuate, - rbrace, - rbracket, - renderPretty, - rparen, - softline, - textStrict, - vsep, - (<+>), - ) -import qualified Data.Char as C +import Language.PureScript.Bridge.PSTypes (psUnit) +import Language.PureScript.Bridge.SumType (CustomInstance (..), + DataConstructor (..), + DataConstructorArgs (..), + ImportLine (..), + ImportLines, Instance (..), + InstanceImplementation (..), + InstanceMember (..), + PSInstance, + RecordEntry (..), + SumType (SumType), + _recLabel, getUsedTypes, + importsFromList, + instanceToImportLines, + nootype, recLabel, + recValue, sigConstructor) +import Language.PureScript.Bridge.TypeInfo (Language (PureScript), + PSType, + TypeInfo (TypeInfo), + _typeModule, _typeName, + _typePackage, + _typeParameters, + flattenTypeInfo, typeName) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import System.FilePath (joinPath, takeDirectory, ()) +import Text.PrettyPrint.Leijen.Text (Doc, backslash, char, colon, + comma, displayTStrict, dquotes, + hang, hsep, indent, lbrace, + lbracket, line, linebreak, + lparen, nest, parens, punctuate, + rbrace, rbracket, renderPretty, + rparen, softline, textStrict, + vsep, (<+>)) renderText :: Doc -> Text renderText = T.replace " \n" "\n" . displayTStrict . renderPretty 0.4 200 data Module (lang :: Language) = PSModule - { psModuleName :: !Text, - psImportLines :: !ImportLines, - psQualifiedImports :: !(Map Text Text), - psTypes :: ![SumType lang] + { psModuleName :: !Text + , psImportLines :: !ImportLines + , psQualifiedImports :: !(Map Text Text) + , psTypes :: ![SumType lang] } deriving (Show) @@ -111,41 +74,43 @@ type PSModule = Module 'PureScript type Modules = Map Text PSModule -newtype PackageName = PackageName Text +newtype PackageName + = PackageName Text mkPackageName :: String -> Maybe PackageName -mkPackageName s = if all C.isAlpha s - then Just $ PackageName (T.pack s) - else Nothing +mkPackageName s = + if all C.isAlpha s + then Just $ PackageName (T.pack s) + else Nothing sumTypesToModules :: Maybe PackageName -> [SumType 'PureScript] -> Modules sumTypesToModules packageName = - foldr (Map.unionWith unionModules) Map.empty . fmap (sumTypeToModule packageName) + foldr (Map.unionWith unionModules) Map.empty . fmap (sumTypeToModule packageName) unionModules :: PSModule -> PSModule -> PSModule unionModules m1 m2 = - m1 - { psImportLines = unionImportLines (psImportLines m1) (psImportLines m2), - psTypes = psTypes m1 <> psTypes m2 - } + m1 + { psImportLines = unionImportLines (psImportLines m1) (psImportLines m2) + , psTypes = psTypes m1 <> psTypes m2 + } sumTypeToModule :: Maybe PackageName -> SumType 'PureScript -> Modules sumTypeToModule packageName st@(SumType t _ is) = - Map.singleton - typedModuleName - $ PSModule - { psModuleName = psModuleName, - psImportLines = - dropEmpty $ - dropPrelude $ - dropPrim $ - dropSelf $ - unionImportLines - (typesToImportLines (getUsedTypes st)) - (instancesToImportLines is), - psQualifiedImports = instancesToQualifiedImports is, - psTypes = [st] - } + Map.singleton + typedModuleName + $ PSModule + { psModuleName = psModuleName + , psImportLines = + dropEmpty $ + dropPrelude $ + dropPrim $ + dropSelf $ + unionImportLines + (typesToImportLines (getUsedTypes st)) + (instancesToImportLines is) + , psQualifiedImports = instancesToQualifiedImports is + , psTypes = [st] + } where dropEmpty = Map.delete "" dropPrelude = Map.delete "Prelude" @@ -153,8 +118,8 @@ sumTypeToModule packageName st@(SumType t _ is) = typedModuleName = _typeModule t dropSelf = Map.delete typedModuleName psModuleName = fromMaybe typedModuleName do - PackageName pn <- packageName - pure $ pn <> "." <> typedModuleName + PackageName pn <- packageName + pure $ pn <> "." <> typedModuleName unionQualifiedImports :: Map Text Text -> Map Text Text -> Map Text Text unionQualifiedImports = Map.unionWith const @@ -164,47 +129,47 @@ unionImportLines = Map.unionWith unionImportLine unionImportLine :: ImportLine -> ImportLine -> ImportLine unionImportLine l1 l2 = - l1 {importTypes = Set.union (importTypes l1) (importTypes l2)} + l1 {importTypes = Set.union (importTypes l1) (importTypes l2)} typesToImportLines :: Set PSType -> ImportLines typesToImportLines = - foldr unionImportLines Map.empty . fmap typeToImportLines . Set.toList + foldr unionImportLines Map.empty . fmap typeToImportLines . Set.toList typeToImportLines :: PSType -> ImportLines typeToImportLines t = - unionImportLines (typesToImportLines $ Set.fromList (_typeParameters t)) $ - importsFromList [ImportLine (_typeModule t) (Set.singleton (_typeName t))] + unionImportLines (typesToImportLines $ Set.fromList (_typeParameters t)) $ + importsFromList [ImportLine (_typeModule t) (Set.singleton (_typeName t))] instancesToQualifiedImports :: [PSInstance] -> Map Text Text instancesToQualifiedImports = - foldr unionQualifiedImports Map.empty . fmap instanceToQualifiedImports + foldr unionQualifiedImports Map.empty . fmap instanceToQualifiedImports instancesToImportLines :: [PSInstance] -> ImportLines instancesToImportLines = - foldr unionImportLines Map.empty . fmap instanceToImportLines + foldr unionImportLines Map.empty . fmap instanceToImportLines instanceToQualifiedImports :: PSInstance -> Map Text Text instanceToQualifiedImports Json = - Map.fromList - [ ("Data.Argonaut.Decode.Aeson", "D"), - ("Data.Argonaut.Encode.Aeson", "E"), - ("Data.Map", "Map") - ] + Map.fromList + [ ("Data.Argonaut.Decode.Aeson", "D") + , ("Data.Argonaut.Encode.Aeson", "E") + , ("Data.Map", "Map") + ] instanceToQualifiedImports _ = Map.empty mergeImportLines :: ImportLines -> ImportLines -> ImportLines mergeImportLines = Map.unionWith mergeLines where mergeLines a b = - ImportLine (importModule a) (importTypes a `Set.union` importTypes b) + ImportLine (importModule a) (importTypes a `Set.union` importTypes b) printModule :: Switches.Settings -> FilePath -> PSModule -> IO () printModule settings root m = do - unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir - T.writeFile mPath . moduleToText settings $ m + unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir + T.writeFile mPath . moduleToText settings $ m where mFile = - (joinPath . map T.unpack . T.splitOn "." $ psModuleName m) <> ".purs" + (joinPath . map T.unpack . T.splitOn "." $ psModuleName m) <> ".purs" mPath = root mFile mDir = takeDirectory mPath @@ -213,158 +178,159 @@ sumTypesToNeededPackages = Set.unions . map sumTypeToNeededPackages sumTypeToNeededPackages :: SumType lang -> Set Text sumTypeToNeededPackages st = - Set.filter (not . T.null) . Set.map _typePackage $ getUsedTypes st + Set.filter (not . T.null) . Set.map _typePackage $ getUsedTypes st moduleToText :: Switches.Settings -> Module 'PureScript -> Text moduleToText settings m = - flip mappend "\n" $ - renderText $ - vsep $ - [ "-- File auto generated by purescript-bridge! --", - "module" <+> textStrict (psModuleName m) <+> "where" <> linebreak, - "import Prelude" <> linebreak, - vsep - ( (importLineToText <$> allImports) - <> (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) - ) - <> linebreak - ] - <> punctuate (line <> line <> dashes <> line) (sumTypeToDocs settings =<< psTypes m) + flip mappend "\n" $ + renderText $ + vsep $ + [ "-- File auto generated by purescript-bridge! --" + , "module" <+> textStrict (psModuleName m) <+> "where" <> linebreak + , "import Prelude" <> linebreak + , vsep + ( (importLineToText <$> allImports) + <> (uncurry qualifiedImportToText <$> Map.toList (psQualifiedImports m)) + ) + <> linebreak + ] + <> punctuate (line <> line <> dashes <> line) (sumTypeToDocs settings =<< psTypes m) where otherImports = - importsFromList - (lensImports settings <> genericsImports) + importsFromList + (lensImports settings <> genericsImports) allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) dashes = textStrict (T.replicate 80 "-") genericsImports :: [ImportLine] genericsImports = - [ImportLine "Data.Generic.Rep" $ Set.singleton "class Generic"] + [ImportLine "Data.Generic.Rep" $ Set.singleton "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'", "iso", "prism'"], - ImportLine "Data.Lens.Record" $ Set.fromList ["prop"], - ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"], - ImportLine "Type.Proxy" $ Set.fromList ["Proxy(Proxy)"] - ] - | otherwise = - [ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"]] + | Switches.generateLenses settings = + [ ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"] + , ImportLine "Data.Lens" $ + Set.fromList ["Iso'", "Prism'", "Lens'", "iso", "prism'"] + , ImportLine "Data.Lens.Record" $ Set.fromList ["prop"] + , ImportLine "Data.Lens.Iso.Newtype" $ Set.fromList ["_Newtype"] + , ImportLine "Type.Proxy" $ Set.fromList ["Proxy(Proxy)"] + ] + | otherwise = + [ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"]] qualifiedImportToText :: Text -> Text -> Doc qualifiedImportToText m q = hsep ["import", textStrict m, "as", textStrict q] importLineToText :: ImportLine -> Doc importLineToText l = - hsep ["import", textStrict $ importModule l, encloseHsep lparen rparen comma typeList] + hsep ["import", textStrict $ importModule l, encloseHsep lparen rparen comma typeList] where typeList = - map (textStrict . last) - . groupBy ((==) `on` importedType) - . sortBy importOrder - . Set.toList - $ importTypes l + map (textStrict . last) + . groupBy ((==) `on` importedType) + . sortBy importOrder + . Set.toList + $ importTypes l importOrder imp1 imp2 - | T.isPrefixOf "class" imp1 = if T.isPrefixOf "class" imp2 then compare imp1 imp2 else LT - | otherwise = compare imp1 imp2 + | T.isPrefixOf "class" imp1 = if T.isPrefixOf "class" imp2 then compare imp1 imp2 else LT + | otherwise = compare imp1 imp2 importedType imp = fromMaybe imp $ T.stripSuffix "(..)" imp sumTypeToDocs :: Switches.Settings -> SumType 'PureScript -> [Doc] sumTypeToDocs settings st - | Switches.generateLenses settings = [sumTypeToTypeDecls st, sumTypeToOptics st] - | otherwise = [sumTypeToTypeDecls st] + | Switches.generateLenses settings = [sumTypeToTypeDecls st, sumTypeToOptics st] + | otherwise = [sumTypeToTypeDecls st] sumTypeToTypeDecls :: SumType 'PureScript -> Doc sumTypeToTypeDecls st@(SumType t cs _) = - vsep $ punctuate line $ typeDecl : instances st + vsep $ punctuate line $ typeDecl : instances st where typeDecl - | isJust (nootype cs) = mkTypeDecl "newtype" - | otherwise = mkTypeDecl "data" + | isJust (nootype cs) = mkTypeDecl "newtype" + | otherwise = mkTypeDecl "data" mkTypeDecl keyword = - keyword <+> typeInfoToDecl t <+> encloseVsep "=" mempty "|" (constructorToDoc <$> cs) + keyword <+> typeInfoToDecl t <+> encloseVsep "=" mempty "|" (constructorToDoc <$> cs) typeInfoToDecl :: PSType -> Doc typeInfoToDecl (TypeInfo _ _ name params) = - hsep $ textStrict name : (typeInfoToDoc <$> params) + hsep $ textStrict name : (typeInfoToDoc <$> params) typeInfoToDoc :: PSType -> Doc typeInfoToDoc t@(TypeInfo _ _ _ params) = - (if null params then id else parens) $ typeInfoToDecl t + (if null params then id else parens) $ typeInfoToDecl t constructorToDoc :: DataConstructor 'PureScript -> Doc constructorToDoc (DataConstructor n args) = - hsep $ - textStrict n : case args of - Nullary -> [] - Normal ts -> NE.toList $ typeInfoToDoc <$> ts - Record rs -> [vrecord $ fieldSignatures rs] - --- | Given a Purescript type, generate instances for typeclass --- instances it claims to have. + hsep $ + textStrict n : case args of + Nullary -> [] + Normal ts -> NE.toList $ typeInfoToDoc <$> ts + Record rs -> [vrecord $ fieldSignatures rs] + +{- | Given a Purescript type, generate instances for typeclass +instances it claims to have. +-} instances :: SumType 'PureScript -> [Doc] instances st@(SumType t _ is) = go <$> is where mkConstraints :: (PSType -> [PSType]) -> [Doc] mkConstraints getConstraints = case getConstraints t of - [] -> [] - constraints -> [encloseHsep lparen rparen comma (typeInfoToDecl <$> constraints), "=>"] + [] -> [] + constraints -> [encloseHsep lparen rparen comma (typeInfoToDecl <$> constraints), "=>"] mkInstance instanceHead getConstraints methods = - vsep - [ hsep - [ "instance", - hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead], - "where" - ], - indent 2 $ vsep methods - ] + vsep + [ hsep + [ "instance" + , hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] + , "where" + ] + , indent 2 $ vsep methods + ] mkDerivedInstance instanceHead getConstraints = - hsep - [ "derive instance", - hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] - ] + hsep + [ "derive instance" + , hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] + ] mkDerivedNewtypeInstance instanceHead getConstraints = - hsep - [ "derive newtype instance", - hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] - ] + hsep + [ "derive newtype instance" + , hsep $ mkConstraints getConstraints <> [typeInfoToDecl instanceHead] + ] toKind1 (TypeInfo p m n []) = TypeInfo p m n [] toKind1 (TypeInfo p m n ps) = TypeInfo p m n $ init ps go :: PSInstance -> Doc go (Custom CustomInstance {..}) = case _customImplementation of - Derive -> mkDerivedInstance _customHead (const _customConstraints) - DeriveNewtype -> mkDerivedNewtypeInstance _customHead (const _customConstraints) - Explicit members -> mkInstance _customHead (const _customConstraints) $ memberToMethod <$> members + Derive -> mkDerivedInstance _customHead (const _customConstraints) + DeriveNewtype -> mkDerivedNewtypeInstance _customHead (const _customConstraints) + Explicit members -> mkInstance _customHead (const _customConstraints) $ memberToMethod <$> members go Bounded = - mkInstance - (mkType "Bounded" [t]) - (const []) - [ "bottom = genericBottom", - "top = genericTop" - ] + mkInstance + (mkType "Bounded" [t]) + (const []) + [ "bottom = genericBottom" + , "top = genericTop" + ] go Enum = - mkInstance - (mkType "Enum" [t]) - (const []) - [ "succ = genericSucc", - "pred = genericPred" - ] + mkInstance + (mkType "Enum" [t]) + (const []) + [ "succ = genericSucc" + , "pred = genericPred" + ] go Json = - vsep $ - punctuate - line - [ mkInstance - (mkType "EncodeJson" [t]) - encodeJsonConstraints - ["encodeJson = defer \\_ ->" <+> sumTypeToEncode st], - mkInstance - (mkType "DecodeJson" [t]) - decodeJsonConstraints - [hang 2 $ "decodeJson = defer \\_ -> D.decode" <+> sumTypeToDecode st] - ] + vsep $ + punctuate + line + [ mkInstance + (mkType "EncodeJson" [t]) + encodeJsonConstraints + ["encodeJson = defer \\_ ->" <+> sumTypeToEncode st] + , mkInstance + (mkType "DecodeJson" [t]) + decodeJsonConstraints + [hang 2 $ "decodeJson = defer \\_ -> D.decode" <+> sumTypeToDecode st] + ] go GenericShow = mkInstance (mkType "Show" [t]) showConstraints ["show a = genericShow a"] go Functor = mkDerivedInstance (mkType "Functor" [toKind1 t]) (const []) go Eq = mkDerivedInstance (mkType "Eq" [t]) eqConstraints @@ -375,11 +341,11 @@ instances st@(SumType t _ is) = go <$> is memberToMethod :: InstanceMember 'PureScript -> Doc memberToMethod InstanceMember {..} = - hang 2 $ - hsep - [ hsep $ textStrict <$> _memberName : _memberBindings <> ["="], - vsep $ textStrict <$> T.lines _memberBody - ] + hang 2 $ + hsep + [ hsep $ textStrict <$> _memberName : _memberBindings <> ["="] + , vsep $ textStrict <$> T.lines _memberBody + ] constrainWith :: Text -> PSType -> [PSType] constrainWith name = map (mkType name . pure) . typeParams @@ -404,59 +370,59 @@ isEnum = all $ (== Nullary) . _sigValues sumTypeToEncode :: SumType 'PureScript -> Doc sumTypeToEncode (SumType _ cs _) - | isEnum cs = "E.encode E.enum" - | otherwise = - case cs of - [dc@(DataConstructor _ args)] -> - hsep - [ "E.encode $", - if isJust (nootype [dc]) - then "unwrap" - else parens $ case_of [(constructorPattern dc, constructor args)], - hang 2 $ ">$<" <+> nest 2 (argsToEncode args) - ] - _ -> case_of (constructorToEncode <$> cs) + | isEnum cs = "E.encode E.enum" + | otherwise = + case cs of + [dc@(DataConstructor _ args)] -> + hsep + [ "E.encode $" + , if isJust (nootype [dc]) + then "unwrap" + else parens $ case_of [(constructorPattern dc, constructor args)] + , hang 2 $ ">$<" <+> nest 2 (argsToEncode args) + ] + _ -> case_of (constructorToEncode <$> cs) where constructorToEncode c@(DataConstructor name args) = - ( constructorPattern c, - case args of - Nullary -> "encodeJson { tag:" <+> dquotes (textStrict name) <> ", contents: jsonNull }" - Normal as -> - "E.encodeTagged" - <+> dquotes (textStrict name) - <+> normalExpr as - <+> argsToEncode args - Record rs - | any ((== "tag") . _recLabel) rs -> - "E.encodeTagged" - <+> dquotes (textStrict name) - <+> hrecord (fields rs) - <+> argsToEncode args - | otherwise -> - hsep - [ "encodeJson", - vrecord $ - ("tag:" <+> dquotes (textStrict name)) : - (recordFieldToJson <$> NE.toList rs) - ] - ) + ( constructorPattern c + , case args of + Nullary -> "encodeJson { tag:" <+> dquotes (textStrict name) <> ", contents: jsonNull }" + Normal as -> + "E.encodeTagged" + <+> dquotes (textStrict name) + <+> normalExpr as + <+> argsToEncode args + Record rs + | any ((== "tag") . _recLabel) rs -> + "E.encodeTagged" + <+> dquotes (textStrict name) + <+> hrecord (fields rs) + <+> argsToEncode args + | otherwise -> + hsep + [ "encodeJson" + , vrecord $ + ("tag:" <+> dquotes (textStrict name)) + : (recordFieldToJson <$> NE.toList rs) + ] + ) recordFieldToJson (RecordEntry name t) = - textStrict name - <> colon - <+> "flip E.encode" - <+> textStrict name - <+> typeToEncode t + textStrict name + <> colon + <+> "flip E.encode" + <+> textStrict name + <+> typeToEncode t argsToEncode Nullary = "E.null" argsToEncode (Normal (t :| [])) = typeToEncode t argsToEncode (Normal ts) = - parens $ "E.tuple" <+> encloseHsep lparen rparen " >/\\<" (typeToEncode <$> NE.toList ts) + parens $ "E.tuple" <+> encloseHsep lparen rparen " >/\\<" (typeToEncode <$> NE.toList ts) argsToEncode (Record rs) = - parens $ "E.record" <> softline <> vrecord (fieldSignatures $ fieldEncoder <$> rs) + parens $ "E.record" <> softline <> vrecord (fieldSignatures $ fieldEncoder <$> rs) where fieldEncoder r = - r - & recValue %~ mkType "_" . pure - & recLabel <>~ renderText (":" <+> typeToEncode (_recValue r)) + r + & recValue %~ mkType "_" . pure + & recLabel <>~ renderText (":" <+> typeToEncode (_recValue r)) flattenTuple :: [PSType] -> [PSType] flattenTuple [] = [] @@ -467,138 +433,138 @@ flattenTuple (h : t) = h : flattenTuple t typeToEncode :: PSType -> Doc typeToEncode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = "E.unit" typeToEncode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = - parens $ - "E.maybe" <+> typeToEncode t + parens $ + "E.maybe" <+> typeToEncode t typeToEncode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = - parens $ - "E.either" <+> typeToEncode l <+> typeToEncode r + parens $ + "E.either" <+> typeToEncode l <+> typeToEncode r typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = - parens $ - "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) + parens $ + "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) typeToEncode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = - parens $ - "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) + parens $ + "E.tuple" <+> parens (hsep $ punctuate " >/\\<" $ typeToEncode <$> flattenTuple ts) typeToEncode (TypeInfo "purescript-ordered-collections" "Data.Map" "Map" [k, v]) = - parens $ - "E.dictionary" <+> typeToEncode k <+> typeToEncode v + parens $ + "E.dictionary" <+> typeToEncode k <+> typeToEncode v typeToEncode _ = "E.value" sumTypeToDecode :: SumType 'PureScript -> Doc sumTypeToDecode (SumType _ cs _) - | isEnum cs = "D.enum" + | isEnum cs = "D.enum" sumTypeToDecode (SumType _ [c] _) = "$" <+> constructorToDecode False c sumTypeToDecode (SumType t cs _) = - line - <> hsep - [ "$ D.sumType", - t ^. typeName . to textStrict . to dquotes, - "$ Map.fromFoldable", - encloseVsep lbracket rbracket comma (constructorToTagged <$> cs) - ] + line + <> hsep + [ "$ D.sumType" + , t ^. typeName . to textStrict . to dquotes + , "$ Map.fromFoldable" + , encloseVsep lbracket rbracket comma (constructorToTagged <$> cs) + ] where constructorToTagged dc = - hsep - [ dc ^. sigConstructor . to textStrict . to dquotes, - "/\\", - constructorToDecode True dc - ] + hsep + [ dc ^. sigConstructor . to textStrict . to dquotes + , "/\\" + , constructorToDecode True dc + ] constructorToDecode :: Bool -> DataConstructor 'PureScript -> Doc constructorToDecode True (DataConstructor name Nullary) = - "pure" <+> textStrict name + "pure" <+> textStrict name constructorToDecode False (DataConstructor name Nullary) = - parens $ textStrict name <+> "<$" <+> "D.null" + parens $ textStrict name <+> "<$" <+> "D.null" constructorToDecode True dc@(DataConstructor _ (Normal _)) = - "D.content" <+> constructorToDecode False dc + "D.content" <+> constructorToDecode False dc constructorToDecode False (DataConstructor name (Normal (a :| []))) = - parens $ textStrict name <+> "<$>" <+> typeToDecode a + parens $ textStrict name <+> "<$>" <+> typeToDecode a constructorToDecode False (DataConstructor name (Normal as)) = - parens $ - "D.tuple" - <+> "$" - <+> textStrict name - <+> encloseHsep "" mempty " " (typeToDecode <$> NE.toList as) -constructorToDecode True dc@(DataConstructor name (Record rs)) - | any ((== "tag") . _recLabel) rs = - "D.content" <+> constructorToDecode False dc - | otherwise = parens $ - textStrict name - <+> "<$> D.object" - <+> dquotes (textStrict name) - <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) + "D.tuple" + <+> "$" + <+> textStrict name + <+> encloseHsep "" mempty " " (typeToDecode <$> NE.toList as) +constructorToDecode True dc@(DataConstructor name (Record rs)) + | any ((== "tag") . _recLabel) rs = + "D.content" <+> constructorToDecode False dc + | otherwise = + parens $ + textStrict name + <+> "<$> D.object" + <+> dquotes (textStrict name) + <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) where fieldDecoder r = - r - & recValue %~ mkType "_" . pure - & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) + r + & recValue %~ mkType "_" . pure + & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) constructorToDecode False (DataConstructor name (Record rs)) = - parens $ - textStrict name - <+> "<$> D.record" - <+> dquotes (textStrict name) - <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) + parens $ + textStrict name + <+> "<$> D.record" + <+> dquotes (textStrict name) + <+> vrecord (fieldSignatures $ fieldDecoder <$> rs) where fieldDecoder r = - r - & recValue %~ mkType "_" . pure - & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) + r + & recValue %~ mkType "_" . pure + & recLabel <>~ renderText (":" <+> typeToDecode (_recValue r)) typeToDecode :: PSType -> Doc typeToDecode (TypeInfo "purescript-prelude" "Prelude" "Unit" []) = "D.unit" typeToDecode (TypeInfo "purescript-maybe" "Data.Maybe" "Maybe" [t]) = - parens $ - "D.maybe" <+> typeToDecode t + parens $ + "D.maybe" <+> typeToDecode t typeToDecode (TypeInfo "purescript-either" "Data.Either" "Either" [l, r]) = - parens $ - "D.either" <+> typeToDecode l <+> typeToDecode r + parens $ + "D.either" <+> typeToDecode l <+> typeToDecode r typeToDecode (TypeInfo "purescript-tuples" "Data.Tuple" "Tuple" ts) = - parens $ - "D.tuple" <+> encloseHsep lparen rparen " " (typeToDecode <$> flattenTuple ts) + parens $ + "D.tuple" <+> encloseHsep lparen rparen " " (typeToDecode <$> flattenTuple ts) typeToDecode (TypeInfo "purescript-ordered-collections" "Data.Map" "Map" [k, v]) = - parens $ - "D.dictionary" <+> typeToDecode k <+> typeToDecode v + parens $ + "D.dictionary" <+> typeToDecode k <+> typeToDecode v typeToDecode _ = "D.value" sumTypeToOptics :: SumType 'PureScript -> Doc sumTypeToOptics st = - vsep $ punctuate line $ constructorOptics st <> recordOptics st + vsep $ punctuate line $ constructorOptics st <> recordOptics st constructorOptics :: SumType 'PureScript -> [Doc] constructorOptics (SumType t cs _) = constructorToOptic (length cs > 1) t <$> cs recordOptics :: SumType 'PureScript -> [Doc] recordOptics st@(SumType _ [DataConstructor _ (Record rs)] _) = - recordEntryToLens st <$> filter hasUnderscore (NE.toList rs) + recordEntryToLens st <$> filter hasUnderscore (NE.toList rs) recordOptics _ = mempty hasUnderscore :: RecordEntry lang -> Bool hasUnderscore (RecordEntry name _) = "_" `T.isPrefixOf` name -constructorToOptic :: - Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Doc +constructorToOptic + :: Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Doc constructorToOptic hasOtherConstructors typeInfo (DataConstructor n args) = - case (args, hasOtherConstructors) of - (Nullary, False) -> iso pName typeInfo psUnit "(const unit)" $ parens ("const" <+> cName) - (Nullary, True) -> prism pName typeInfo psUnit cName "unit" $ parens ("const" <+> cName) - (Normal (t :| []), False) -> newtypeIso pName typeInfo t - (Normal (t :| []), True) -> prism pName typeInfo t (parens $ normalPattern n [t]) "a" cName - (Normal ts, _) - | hasOtherConstructors -> prism pName typeInfo toType fromExpr toExpr toMorph - | otherwise -> iso pName typeInfo toType fromMorph toMorph - where - fields' = fields $ typesToRecord ts - toType = recordType $ typesToRecord ts - fromExpr = parens $ normalPattern n ts - toExpr = hrecord fields' - fromMorph = parens $ lambda fromExpr toExpr - toMorph = parens $ lambda toExpr fromExpr - (Record rs, False) -> newtypeIso pName typeInfo $ recordType rs - (Record rs, True) -> - prism pName typeInfo (recordType rs) fromExpr toExpr cName - where - fromExpr = parens $ pattern n toExpr - toExpr = "a" + case (args, hasOtherConstructors) of + (Nullary, False) -> iso pName typeInfo psUnit "(const unit)" $ parens ("const" <+> cName) + (Nullary, True) -> prism pName typeInfo psUnit cName "unit" $ parens ("const" <+> cName) + (Normal (t :| []), False) -> newtypeIso pName typeInfo t + (Normal (t :| []), True) -> prism pName typeInfo t (parens $ normalPattern n [t]) "a" cName + (Normal ts, _) + | hasOtherConstructors -> prism pName typeInfo toType fromExpr toExpr toMorph + | otherwise -> iso pName typeInfo toType fromMorph toMorph + where + fields' = fields $ typesToRecord ts + toType = recordType $ typesToRecord ts + fromExpr = parens $ normalPattern n ts + toExpr = hrecord fields' + fromMorph = parens $ lambda fromExpr toExpr + toMorph = parens $ lambda toExpr fromExpr + (Record rs, False) -> newtypeIso pName typeInfo $ recordType rs + (Record rs, True) -> + prism pName typeInfo (recordType rs) fromExpr toExpr cName + where + fromExpr = parens $ pattern n toExpr + toExpr = "a" where cName = textStrict n pName = "_" <> textStrict n @@ -609,59 +575,60 @@ typesToRecord = fmap (uncurry RecordEntry) . NE.zip (T.singleton <$> ['a' ..]) iso :: Doc -> PSType -> PSType -> Doc -> Doc -> Doc iso name fromType toType fromMorph toMorph = - def - name - [] - [] - (mkType "Iso'" [fromType, toType]) - ("iso" <+> fromMorph <+> toMorph) + def + name + [] + [] + (mkType "Iso'" [fromType, toType]) + ("iso" <+> fromMorph <+> toMorph) prism :: Doc -> PSType -> PSType -> Doc -> Doc -> Doc -> Doc prism name fromType toType previewPattern previewExpr inject = - def - name - [] - [] - (mkType "Prism'" [fromType, toType]) - ( "prism'" <+> inject - <+> case_of - [ (previewPattern, "Just" <+> previewExpr), - ("_", "Nothing") - ] - ) + def + name + [] + [] + (mkType "Prism'" [fromType, toType]) + ( "prism'" + <+> inject + <+> case_of + [ (previewPattern, "Just" <+> previewExpr) + , ("_", "Nothing") + ] + ) newtypeIso :: Doc -> PSType -> PSType -> Doc newtypeIso name fromType toType = - def - name - [] - [] - (mkType "Iso'" [fromType, toType]) - "_Newtype" + def + name + [] + [] + (mkType "Iso'" [fromType, toType]) + "_Newtype" recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Doc recordEntryToLens (SumType t _ _) e = - if hasUnderscore e - then - vsep - [ signature True lensName [] [] $ mkType "Lens'" [t, e ^. recValue], - lensName <+> "= _Newtype <<< prop" <+> parens ("Proxy :: _" <> dquotes recName) - ] - else mempty + if hasUnderscore e + then + vsep + [ signature True lensName [] [] $ mkType "Lens'" [t, e ^. recValue] + , lensName <+> "= _Newtype <<< prop" <+> parens ("Proxy :: _" <> dquotes recName) + ] + else mempty where recName = e ^. recLabel . to textStrict lensName = e ^. recLabel . to (T.drop 1) . to textStrict -unlessM :: Monad m => m Bool -> m () -> m () +unlessM :: (Monad m) => m Bool -> m () -> m () unlessM mbool action = mbool >>= flip unless action constructorPattern :: DataConstructor 'PureScript -> Doc -constructorPattern (DataConstructor name Nullary) = nullaryPattern name +constructorPattern (DataConstructor name Nullary) = nullaryPattern name constructorPattern (DataConstructor name (Normal ts)) = normalPattern name ts constructorPattern (DataConstructor name (Record rs)) = recordPattern name rs constructor :: DataConstructorArgs 'PureScript -> Doc -constructor Nullary = nullaryExpr +constructor Nullary = nullaryExpr constructor (Normal ts) = normalExpr ts constructor (Record rs) = hrecord $ fields rs @@ -676,7 +643,7 @@ normalPattern name = pattern name . hsep . normalLabels normalExpr :: NonEmpty PSType -> Doc normalExpr (_ :| []) = "a" -normalExpr ts = parens . hsep . punctuate " /\\" $ normalLabels ts +normalExpr ts = parens . hsep . punctuate " /\\" $ normalLabels ts normalLabels :: NonEmpty PSType -> [Doc] normalLabels = fmap char . zipWith const ['a' ..] . NE.toList @@ -710,9 +677,9 @@ case_of = caseOf "_" caseOf :: Doc -> [(Doc, Doc)] -> Doc caseOf scrutinee [(p, b)] = - hsep ["case", scrutinee, "of", branch p b] + hsep ["case", scrutinee, "of", branch p b] caseOf scrutinee branches = - vsep $ hsep ["case", scrutinee, "of"] : (indent 2 . uncurry branch <$> branches) + vsep $ hsep ["case", scrutinee, "of"] : (indent 2 . uncurry branch <$> branches) branch :: Doc -> Doc -> Doc branch p body = hsep [p, "->", body] @@ -725,26 +692,26 @@ signature' name = signature False name [] [] signature :: Bool -> Doc -> [PSType] -> [PSType] -> PSType -> Doc signature topLevel name constraints params ret = - hsep $ catMaybes [Just name, Just "::", forAll, constraintsDoc, paramsDoc, Just $ typeInfoToDecl ret] + hsep $ catMaybes [Just name, Just "::", forAll, constraintsDoc, paramsDoc, Just $ typeInfoToDecl ret] where forAll = case (topLevel, allTypes >>= typeParams) of - (False, _) -> Nothing - (_, []) -> Nothing - (_, ps) -> Just $ "forall" <+> hsep (typeInfoToDoc <$> nubBy (on (==) _typeName) ps) <> "." + (False, _) -> Nothing + (_, []) -> Nothing + (_, ps) -> Just $ "forall" <+> hsep (typeInfoToDoc <$> nubBy (on (==) _typeName) ps) <> "." allTypes = ret : constraints <> params constraintsDoc = case constraints of - [] -> Nothing - cs -> Just $ hsep ((<+> "=>") . typeInfoToDecl <$> cs) + [] -> Nothing + cs -> Just $ hsep ((<+> "=>") . typeInfoToDecl <$> cs) paramsDoc = case params of - [] -> Nothing - ps -> Just $ hsep ((<+> "->") . typeInfoToDecl <$> ps) + [] -> Nothing + ps -> Just $ hsep ((<+> "->") . typeInfoToDecl <$> ps) def :: Doc -> [PSType] -> [(Doc, PSType)] -> PSType -> Doc -> Doc def name constraints params ret body = - vsep - [ signature True name constraints (snd <$> params) ret, - hsep $ name : (fst <$> params) <> ["=", body] - ] + vsep + [ signature True name constraints (snd <$> params) ret + , hsep $ name : (fst <$> params) <> ["=", body] + ] mkType :: Text -> [PSType] -> PSType mkType = TypeInfo "" "" @@ -754,13 +721,13 @@ typeParams = filter (isLower . T.head . _typeName) . flattenTypeInfo encloseHsep :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseHsep left right sp ds = - case ds of - [] -> left <> right - _ -> left <> hsep (punctuate sp ds) <> right + case ds of + [] -> left <> right + _ -> left <> hsep (punctuate sp ds) <> right encloseVsep :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseVsep left right sp ds = - case ds of - [] -> left <> right - [d] -> left <+> d <+> right - _ -> nest 2 $ linebreak <> vsep (zipWith (<+>) (left : repeat (hang 2 sp)) ds <> [right]) + case ds of + [] -> left <> right + [d] -> left <+> d <+> right + _ -> nest 2 $ linebreak <> vsep (zipWith (<+>) (left : repeat (hang 2 sp)) ds <> [right]) diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 54dbdf51..75e13eeb 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -1,78 +1,77 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} module Language.PureScript.Bridge.SumType where -import Control.Lens hiding (from, to) -import Data.List (nub) -import Data.List.NonEmpty (NonEmpty) +import Control.Lens hiding (from, to) +import Data.List (nub) +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Map (Map) +import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (maybeToList) -import Data.Set (Set) +import Data.Maybe (maybeToList) +import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) +import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable -import Generics.Deriving -import Language.PureScript.Bridge.TypeInfo +import Data.Typeable +import Generics.Deriving +import Language.PureScript.Bridge.TypeInfo data ImportLine = ImportLine - { importModule :: !Text, - importTypes :: !(Set Text) + { importModule :: !Text + , importTypes :: !(Set Text) } deriving (Eq, Ord, Show) type ImportLines = Map Text ImportLine -- | Generic representation of your Haskell types. -data SumType (lang :: Language) - = SumType (TypeInfo lang) [DataConstructor lang] [Instance lang] - deriving (Show, Eq) +data SumType (lang :: Language) = SumType (TypeInfo lang) [DataConstructor lang] [Instance lang] + deriving (Eq, Show) -- | TypeInfo lens for 'SumType'. -sumTypeInfo :: - Functor f => - (TypeInfo lang -> f (TypeInfo lang)) -> - SumType lang -> - f (SumType lang) +sumTypeInfo + :: (Functor f) + => (TypeInfo lang -> f (TypeInfo lang)) + -> SumType lang + -> f (SumType lang) sumTypeInfo inj (SumType info constrs is) = - (\ti -> SumType ti constrs is) <$> inj info + (\ti -> SumType ti constrs is) <$> inj info -- | DataConstructor lens for 'SumType'. -sumTypeConstructors :: - Functor f => - ([DataConstructor lang] -> f [DataConstructor lang]) -> - SumType lang -> - f (SumType lang) +sumTypeConstructors + :: (Functor f) + => ([DataConstructor lang] -> f [DataConstructor lang]) + -> SumType lang + -> f (SumType lang) sumTypeConstructors inj (SumType info constrs is) = - (\cs -> SumType info cs is) <$> inj constrs - --- | Create a representation of your sum (and product) types, --- for doing type translations and writing it out to your PureScript modules. -mkSumType :: - forall t. - (Generic t, Typeable t, GDataConstructor (Rep t)) => - SumType 'Haskell + (\cs -> SumType info cs is) <$> inj constrs + +{- | Create a representation of your sum (and product) types, + for doing type translations and writing it out to your PureScript modules. +-} +mkSumType + :: forall t + . (Generic t, Typeable t, GDataConstructor (Rep t)) + => SumType 'Haskell mkSumType = - SumType - (mkTypeInfo @t) - constructors - (Generic : maybeToList (nootype constructors)) + SumType + (mkTypeInfo @t) + constructors + (Generic : maybeToList (nootype constructors)) where constructors = gToConstructors (from (undefined :: t)) @@ -94,11 +93,11 @@ data Instance (lang :: Language) type PSInstance = Instance 'PureScript data InstanceMember (lang :: Language) = InstanceMember - { _memberName :: Text, - _memberBindings :: [Text], - _memberBody :: Text, - _memberDependencies :: [TypeInfo lang], - _memberImportLines :: ImportLines + { _memberName :: Text + , _memberBindings :: [Text] + , _memberBody :: Text + , _memberDependencies :: [TypeInfo lang] + , _memberImportLines :: ImportLines } deriving (Eq, Ord, Show) @@ -109,18 +108,19 @@ data InstanceImplementation (lang :: Language) deriving (Eq, Ord, Show) data CustomInstance (lang :: Language) = CustomInstance - { _customConstraints :: [TypeInfo lang], - _customHead :: TypeInfo lang, - _customImplementation :: InstanceImplementation lang + { _customConstraints :: [TypeInfo lang] + , _customHead :: TypeInfo lang + , _customImplementation :: InstanceImplementation lang } deriving (Eq, Ord, Show) --- | The Purescript typeclass `Newtype` might be derivable if the original --- Haskell type was a simple type wrapper. +{- | The Purescript typeclass `Newtype` might be derivable if the original +Haskell type was a simple type wrapper. +-} nootype :: [DataConstructor lang] -> Maybe (Instance lang) -nootype [DataConstructor _ (Record _)] = Just Newtype +nootype [DataConstructor _ (Record _)] = Just Newtype nootype [DataConstructor _ (Normal [_])] = Just Newtype -nootype _ = Nothing +nootype _ = Nothing -- | Ensure that aeson-compatible `EncodeJson` and `DecodeJson` instances are generated for your type. argonaut :: SumType t -> SumType t @@ -130,8 +130,9 @@ argonaut (SumType ti dc is) = SumType ti dc . nub $ Json : is genericShow :: SumType t -> SumType t genericShow (SumType ti dc is) = SumType ti dc . nub $ GenericShow : is --- | Ensure that a functor instance is generated for your type. It it --- your responsibility to ensure your type is a functor. +{- | Ensure that a functor instance is generated for your type. It it +your responsibility to ensure your type is a functor. +-} functor :: SumType t -> SumType t functor (SumType ti dc is) = SumType ti dc . nub $ Functor : is @@ -148,79 +149,80 @@ order :: SumType t -> SumType t order (SumType ti dc is) = SumType ti dc . nub $ Eq : Ord : is data DataConstructor (lang :: Language) = DataConstructor - { -- | e.g. `Left`/`Right` for `Either` - _sigConstructor :: !Text, - _sigValues :: !(DataConstructorArgs lang) + { _sigConstructor :: !Text + -- ^ e.g. `Left`/`Right` for `Either` + , _sigValues :: !(DataConstructorArgs lang) } - deriving (Show, Eq) + deriving (Eq, Show) data DataConstructorArgs (lang :: Language) = Nullary | Normal (NonEmpty (TypeInfo lang)) | Record (NonEmpty (RecordEntry lang)) - deriving (Show, Eq) + deriving (Eq, Show) instance Semigroup (DataConstructorArgs lang) where - Nullary <> b = b - a <> Nullary = a - Normal as <> Normal bs = Normal $ as <> bs - Record as <> Record bs = Record $ as <> bs - Normal as <> Record bs = Normal as <> Normal (_recValue <$> bs) - Record as <> Normal bs = Normal (_recValue <$> as) <> Normal bs + Nullary <> b = b + a <> Nullary = a + Normal as <> Normal bs = Normal $ as <> bs + Record as <> Record bs = Record $ as <> bs + Normal as <> Record bs = Normal as <> Normal (_recValue <$> bs) + Record as <> Normal bs = Normal (_recValue <$> as) <> Normal bs instance Monoid (DataConstructorArgs lang) where - mempty = Nullary + mempty = Nullary data RecordEntry (lang :: Language) = RecordEntry - { -- | e.g. `runState` for `State` - _recLabel :: !Text, - _recValue :: !(TypeInfo lang) + { _recLabel :: !Text + -- ^ e.g. `runState` for `State` + , _recValue :: !(TypeInfo lang) } - deriving (Show, Eq) + deriving (Eq, Show) class GDataConstructor f where - gToConstructors :: f a -> [DataConstructor 'Haskell] + gToConstructors :: f a -> [DataConstructor 'Haskell] class GDataConstructorArgs f where - gToDataConstructorArgs :: f a -> DataConstructorArgs 'Haskell + gToDataConstructorArgs :: f a -> DataConstructorArgs 'Haskell instance (Datatype a, GDataConstructor c) => GDataConstructor (D1 a c) where - gToConstructors (M1 c) = gToConstructors c + gToConstructors (M1 c) = gToConstructors c instance (GDataConstructor a, GDataConstructor b) => GDataConstructor (a :+: b) where - gToConstructors _ = - gToConstructors (undefined :: a f) ++ gToConstructors (undefined :: b f) + gToConstructors _ = + gToConstructors (undefined :: a f) ++ gToConstructors (undefined :: b f) instance (Constructor a, GDataConstructorArgs b) => GDataConstructor (C1 a b) where - gToConstructors c@(M1 r) = - [DataConstructor {_sigConstructor = constructor, _sigValues = values}] - where - constructor = T.pack $ conName c - values = gToDataConstructorArgs r + gToConstructors c@(M1 r) = + [DataConstructor {_sigConstructor = constructor, _sigValues = values}] + where + constructor = T.pack $ conName c + values = gToDataConstructorArgs r instance (GDataConstructorArgs a, GDataConstructorArgs b) => GDataConstructorArgs (a :*: b) where - gToDataConstructorArgs _ = - gToDataConstructorArgs (undefined :: a f) <> gToDataConstructorArgs (undefined :: b f) + gToDataConstructorArgs _ = + gToDataConstructorArgs (undefined :: a f) <> gToDataConstructorArgs (undefined :: b f) instance GDataConstructorArgs U1 where - gToDataConstructorArgs _ = mempty + gToDataConstructorArgs _ = mempty instance (Selector a, Typeable t) => GDataConstructorArgs (S1 a (K1 R t)) where - gToDataConstructorArgs e = case selName e of - "" -> Normal [mkTypeInfo @t] - name -> Record [RecordEntry (T.pack name) (mkTypeInfo @t)] - --- | Get all used types in a sum type. --- --- This includes all types found at the right hand side of a sum type --- definition, not the type parameters of the sum type itself + gToDataConstructorArgs e = case selName e of + "" -> Normal [mkTypeInfo @t] + name -> Record [RecordEntry (T.pack name) (mkTypeInfo @t)] + +{- | Get all used types in a sum type. + + This includes all types found at the right hand side of a sum type + definition, not the type parameters of the sum type itself +-} getUsedTypes :: SumType lang -> Set (TypeInfo lang) getUsedTypes (SumType _ cs is) = - Set.fromList . concatMap flattenTypeInfo $ - concatMap constructorToTypes cs <> concatMap instanceToTypes is + Set.fromList . concatMap flattenTypeInfo $ + concatMap constructorToTypes cs <> concatMap instanceToTypes is constructorToTypes :: DataConstructor lang -> [TypeInfo lang] -constructorToTypes (DataConstructor _ Nullary) = [] +constructorToTypes (DataConstructor _ Nullary) = [] constructorToTypes (DataConstructor _ (Normal ts)) = NE.toList ts constructorToTypes (DataConstructor _ (Record rs)) = _recValue <$> NE.toList rs @@ -228,64 +230,64 @@ instanceToTypes :: Instance lang -> [TypeInfo lang] instanceToTypes Generic = pure $ constraintToType $ TypeInfo "purescript-prelude" "Data.Generic.Rep" "Generic" [] instanceToTypes GenericShow = pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Show" [] instanceToTypes Json = - constraintToType - <$> [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [], - TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] - ] + constraintToType + <$> [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [] + , TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] + ] instanceToTypes Newtype = - pure $ constraintToType $ TypeInfo "purescript-newtype" "Data.Newtype" "Newtype" [] + pure $ constraintToType $ TypeInfo "purescript-newtype" "Data.Newtype" "Newtype" [] instanceToTypes Functor = - pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Functor" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Functor" [] instanceToTypes Eq = - pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Eq" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Eq" [] instanceToTypes Eq1 = - pure $ constraintToType $ TypeInfo "purescript-prelude" "Data.Eq" "Eq1" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Data.Eq" "Eq1" [] instanceToTypes Ord = - pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Ord" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Ord" [] instanceToTypes Enum = - pure $ constraintToType $ TypeInfo "purescript-enums" "Data.Enum" "Enum" [] + pure $ constraintToType $ TypeInfo "purescript-enums" "Data.Enum" "Enum" [] instanceToTypes Bounded = - pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Bounded" [] + pure $ constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Bounded" [] instanceToTypes (Custom CustomInstance {..}) = - constraintToType _customHead : (fmap constraintToType _customConstraints <> implementationToTypes _customImplementation) + constraintToType _customHead : (fmap constraintToType _customConstraints <> implementationToTypes _customImplementation) constraintToType :: TypeInfo lang -> TypeInfo lang constraintToType = over typeName ("class " <>) implementationToTypes :: InstanceImplementation lang -> [TypeInfo lang] implementationToTypes (Explicit members) = concatMap _memberDependencies members -implementationToTypes _ = [] +implementationToTypes _ = [] instanceToImportLines :: PSInstance -> ImportLines instanceToImportLines GenericShow = - importsFromList [ImportLine "Data.Show.Generic" $ Set.singleton "genericShow"] + importsFromList [ImportLine "Data.Show.Generic" $ Set.singleton "genericShow"] instanceToImportLines Json = - importsFromList - [ ImportLine "Control.Lazy" $ Set.singleton "defer", - ImportLine "Data.Argonaut" $ Set.fromList ["encodeJson", "jsonNull"], - ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["()", "()", "()"], - ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["(>$<)", "(>/\\<)"], - ImportLine "Data.Newtype" $ Set.singleton "unwrap", - ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" - ] + importsFromList + [ ImportLine "Control.Lazy" $ Set.singleton "defer" + , ImportLine "Data.Argonaut" $ Set.fromList ["encodeJson", "jsonNull"] + , ImportLine "Data.Argonaut.Decode.Aeson" $ Set.fromList ["()", "()", "()"] + , ImportLine "Data.Argonaut.Encode.Aeson" $ Set.fromList ["(>$<)", "(>/\\<)"] + , ImportLine "Data.Newtype" $ Set.singleton "unwrap" + , ImportLine "Data.Tuple.Nested" $ Set.singleton "(/\\)" + ] instanceToImportLines Enum = - importsFromList - [ ImportLine "Data.Enum.Generic" $ Set.fromList ["genericPred", "genericSucc"] - ] + importsFromList + [ ImportLine "Data.Enum.Generic" $ Set.fromList ["genericPred", "genericSucc"] + ] instanceToImportLines Bounded = - importsFromList - [ ImportLine "Data.Bounded.Generic" $ Set.fromList ["genericBottom", "genericTop"] - ] + importsFromList + [ ImportLine "Data.Bounded.Generic" $ Set.fromList ["genericBottom", "genericTop"] + ] instanceToImportLines (Custom CustomInstance {_customImplementation = Explicit members}) = - importsFromList $ concatMap (Map.elems . _memberImportLines) members + importsFromList $ concatMap (Map.elems . _memberImportLines) members instanceToImportLines _ = Map.empty importsFromList :: [ImportLine] -> Map Text ImportLine importsFromList ls = - let pairs = zip (importModule <$> ls) ls - merge a b = - ImportLine (importModule a) (importTypes a `Set.union` importTypes b) - in Map.fromListWith merge pairs + let pairs = zip (importModule <$> ls) ls + merge a b = + ImportLine (importModule a) (importTypes a `Set.union` importTypes b) + in Map.fromListWith merge pairs -- Lenses: makeLenses ''DataConstructor diff --git a/src/Language/PureScript/Bridge/Tuple.hs b/src/Language/PureScript/Bridge/Tuple.hs index efff3937..bbe3bbeb 100644 --- a/src/Language/PureScript/Bridge/Tuple.hs +++ b/src/Language/PureScript/Bridge/Tuple.hs @@ -1,34 +1,29 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Bridge.Tuple where import qualified Data.Text as T -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.PSTypes (psTuple) -import Language.PureScript.Bridge.TypeInfo +import Language.PureScript.Bridge.Builder +import Language.PureScript.Bridge.PSTypes (psTuple) +import Language.PureScript.Bridge.TypeInfo tupleBridge :: BridgePart tupleBridge = doCheck haskType isTuple >> psTuple -data TupleParserState - = Start - | OpenFound - | ColonFound - | Tuple - | NoTuple +data TupleParserState = Start | OpenFound | ColonFound | Tuple | NoTuple deriving (Eq, Show) step :: TupleParserState -> Char -> TupleParserState -step Start '(' = OpenFound -step Start _ = NoTuple -step OpenFound ',' = ColonFound -step OpenFound _ = NoTuple +step Start '(' = OpenFound +step Start _ = NoTuple +step OpenFound ',' = ColonFound +step OpenFound _ = NoTuple step ColonFound ',' = ColonFound step ColonFound ')' = Tuple -step ColonFound _ = NoTuple -step Tuple _ = NoTuple -step NoTuple _ = NoTuple +step ColonFound _ = NoTuple +step Tuple _ = NoTuple +step NoTuple _ = NoTuple isTuple :: HaskellType -> Bool isTuple = (== Tuple) . T.foldl' step Start . _typeName diff --git a/src/Language/PureScript/Bridge/TypeInfo.hs b/src/Language/PureScript/Bridge/TypeInfo.hs index c6d84652..f1afe5ca 100644 --- a/src/Language/PureScript/Bridge/TypeInfo.hs +++ b/src/Language/PureScript/Bridge/TypeInfo.hs @@ -1,49 +1,47 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} module Language.PureScript.Bridge.TypeInfo - ( TypeInfo (..), - PSType, - HaskellType, - mkTypeInfo, - mkTypeInfo', - Language (..), - typePackage, - typeModule, - typeName, - typeParameters, - HasHaskType, - haskType, - flattenTypeInfo, - ) + ( TypeInfo (..) + , PSType + , HaskellType + , mkTypeInfo + , mkTypeInfo' + , Language (..) + , typePackage + , typeModule + , typeName + , typeParameters + , HasHaskType + , haskType + , flattenTypeInfo + ) where -import Control.Lens -import Data.Proxy -import Data.Text (Text) +import Control.Lens +import Data.Proxy +import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable +import Data.Typeable -data Language - = Haskell - | PureScript +data Language = Haskell | PureScript -- | Basic info about a data type: data TypeInfo (lang :: Language) = TypeInfo - { -- | Hackage package - _typePackage :: !Text, - -- | Full Module path - _typeModule :: !Text, - _typeName :: !Text, - _typeParameters :: ![TypeInfo lang] + { _typePackage :: !Text + -- ^ Hackage package + , _typeModule :: !Text + -- ^ Full Module path + , _typeName :: !Text + , _typeParameters :: ![TypeInfo lang] } deriving (Eq, Ord, Show) @@ -57,24 +55,24 @@ type HaskellType = TypeInfo 'Haskell -- | Types that have a lens for accessing a 'TypeInfo Haskell'. class HasHaskType t where - haskType :: Lens' t HaskellType + haskType :: Lens' t HaskellType -- | Simple 'id' instance: Get the 'TypeInfo' itself. instance HasHaskType HaskellType where - haskType inj = inj + haskType inj = inj -mkTypeInfo :: forall t. Typeable t => HaskellType +mkTypeInfo :: forall t. (Typeable t) => HaskellType mkTypeInfo = mkTypeInfo' . typeRep $ Proxy @t mkTypeInfo' :: TypeRep -> HaskellType mkTypeInfo' rep = - let con = typeRepTyCon rep - in TypeInfo - { _typePackage = T.pack $ tyConPackage con, - _typeModule = T.pack $ tyConModule con, - _typeName = T.pack $ tyConName con, - _typeParameters = map mkTypeInfo' (typeRepArgs rep) - } + let con = typeRepTyCon rep + in TypeInfo + { _typePackage = T.pack $ tyConPackage con + , _typeModule = T.pack $ tyConModule con + , _typeName = T.pack $ tyConName con + , _typeParameters = map mkTypeInfo' (typeRepArgs rep) + } -- | Put the TypeInfo in a list together with all its '_typeParameters' (recursively) flattenTypeInfo :: TypeInfo lang -> [TypeInfo lang] diff --git a/src/Language/PureScript/Bridge/TypeParameters.hs b/src/Language/PureScript/Bridge/TypeParameters.hs index c9a4c8a0..9c4d57ad 100644 --- a/src/Language/PureScript/Bridge/TypeParameters.hs +++ b/src/Language/PureScript/Bridge/TypeParameters.hs @@ -1,83 +1,111 @@ {-# LANGUAGE EmptyDataDeriving #-} --- | As we translate types and not type constructors, we have to pass dummy types --- to any type constructor. --- --- 'buildBridge' will translate all parameter types which --- come from a module TypeParameters (e.g. this one) to lower case. --- --- For translating something like Maybe: --- --- @ --- data Maybe' a = Nothing' | Just' a --- @ --- --- you would use: --- --- @ --- import "Language.PureScript.Bridge" --- import "Language.PureScript.Bridge.TypeParameters" --- --- st = mkSumType @(Maybe' A) -- Note that we use "Maybe' A" instead of just Maybe - which would not work. --- @ +{- | As we translate types and not type constructors, we have to pass dummy types + to any type constructor. + + 'buildBridge' will translate all parameter types which + come from a module TypeParameters (e.g. this one) to lower case. + + For translating something like Maybe: + + @ + data Maybe' a = Nothing' | Just' a + @ + + you would use: + + @ + import "Language.PureScript.Bridge" + import "Language.PureScript.Bridge.TypeParameters" + + st = mkSumType @(Maybe' A) -- Note that we use "Maybe' A" instead of just Maybe - which would not work. + @ +-} module Language.PureScript.Bridge.TypeParameters where -data A deriving (Eq, Ord) +data A + deriving (Eq, Ord) -data B deriving (Eq, Ord) +data B + deriving (Eq, Ord) -data C deriving (Eq, Ord) +data C + deriving (Eq, Ord) -data D deriving (Eq, Ord) +data D + deriving (Eq, Ord) -data E deriving (Eq, Ord) +data E + deriving (Eq, Ord) -data F deriving (Eq, Ord) +data F + deriving (Eq, Ord) -data G deriving (Eq, Ord) +data G + deriving (Eq, Ord) -data H deriving (Eq, Ord) +data H + deriving (Eq, Ord) -data I deriving (Eq, Ord) +data I + deriving (Eq, Ord) -data J deriving (Eq, Ord) +data J + deriving (Eq, Ord) -data K deriving (Eq, Ord) +data K + deriving (Eq, Ord) -data L deriving (Eq, Ord) +data L + deriving (Eq, Ord) -data M deriving (Eq, Ord) +data M + deriving (Eq, Ord) -data N deriving (Eq, Ord) +data N + deriving (Eq, Ord) -data O deriving (Eq, Ord) +data O + deriving (Eq, Ord) -data P deriving (Eq, Ord) +data P + deriving (Eq, Ord) -data Q deriving (Eq, Ord) +data Q + deriving (Eq, Ord) -data R deriving (Eq, Ord) +data R + deriving (Eq, Ord) -data S deriving (Eq, Ord) +data S + deriving (Eq, Ord) -data T deriving (Eq, Ord) +data T + deriving (Eq, Ord) -data U deriving (Eq, Ord) +data U + deriving (Eq, Ord) -data V deriving (Eq, Ord) +data V + deriving (Eq, Ord) -data W deriving (Eq, Ord) +data W + deriving (Eq, Ord) -data X deriving (Eq, Ord) +data X + deriving (Eq, Ord) -data Y deriving (Eq, Ord) +data Y + deriving (Eq, Ord) -data Z deriving (Eq, Ord) +data Z + deriving (Eq, Ord) --- | You can use those if your type parameters are actually type constructors as well: --- @ --- st = mkSumType @('ReaderT' R M1 A) --- @ +{- | You can use those if your type parameters are actually type constructors as well: + @ + st = mkSumType @('ReaderT' R M1 A) + @ +-} data A1 a data B1 a diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index fea30a55..94f945f6 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -1,99 +1,111 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module RoundTrip.Spec where -import Control.Exception (bracket) -import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, encode, fromJSON) -import Data.ByteString.Lazy (hGetContents, stripSuffix) -import Data.ByteString.Lazy.UTF8 (fromString, toString) -import Data.List (isInfixOf) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (..)) -import GHC.Generics (Generic) -import Language.PureScript.Bridge (BridgePart, Language (..), SumType, argonaut, buildBridge, defaultBridge, defaultSwitch, equal, functor, genericShow, mkSumType, order, writePSTypes, writePSTypesWith) -import Language.PureScript.Bridge.TypeParameters (A) -import RoundTrip.Types -import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) -import System.Exit (ExitCode (ExitSuccess)) -import System.IO (BufferMode (..), hFlush, hGetLine, hPutStrLn, hSetBuffering, stderr, stdout) -import System.Process (CreateProcess (std_err, std_in, std_out), StdStream (CreatePipe), createProcess, getProcessExitCode, proc, readProcessWithExitCode, terminateProcess, waitForProcess) -import Test.HUnit (assertBool, assertEqual) -import Test.Hspec (Spec, around, aroundAll_, around_, describe, it) -import Test.Hspec.Expectations.Pretty (shouldBe) -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (noShrinking, once, verbose, withMaxSuccess) -import Test.QuickCheck.Property (Testable (property)) +import Control.Exception (bracket) +import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, encode, + fromJSON) +import Data.ByteString.Lazy (hGetContents, stripSuffix) +import Data.ByteString.Lazy.UTF8 (fromString, toString) +import Data.List (isInfixOf) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, + argonaut, buildBridge, + defaultBridge, defaultSwitch, + equal, functor, genericShow, + mkSumType, order, writePSTypes, + writePSTypesWith) +import Language.PureScript.Bridge.TypeParameters (A) +import RoundTrip.Types +import System.Directory (removeDirectoryRecursive, removeFile, + withCurrentDirectory) +import System.Exit (ExitCode (ExitSuccess)) +import System.IO (BufferMode (..), hFlush, hGetLine, hPutStrLn, + hSetBuffering, stderr, stdout) +import System.Process (CreateProcess (std_err, std_in, std_out), + StdStream (CreatePipe), createProcess, + getProcessExitCode, proc, + readProcessWithExitCode, terminateProcess, + waitForProcess) +import Test.Hspec (Spec, around, aroundAll_, around_, describe, it) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.HUnit (assertBool, assertEqual) +import Test.QuickCheck (noShrinking, once, verbose, withMaxSuccess) +import Test.QuickCheck.Property (Testable (property)) myBridge :: BridgePart myBridge = defaultBridge myTypes :: [SumType 'Haskell] myTypes = - [ equal . genericShow . order . argonaut $ mkSumType @TestData, - equal . genericShow . order . argonaut $ mkSumType @TestSum, - equal . genericShow . order . argonaut $ mkSumType @TestRecursiveA, - equal . genericShow . order . argonaut $ mkSumType @TestRecursiveB, - functor . equal . genericShow . order . argonaut $ mkSumType @(TestRecord A), - equal . genericShow . order . argonaut $ mkSumType @TestNewtype, - equal . genericShow . order . argonaut $ mkSumType @TestNewtypeRecord, - equal . genericShow . order . argonaut $ mkSumType @TestMultiInlineRecords, - equal . genericShow . order . argonaut $ mkSumType @TestTwoFields, - equal . genericShow . order . argonaut $ mkSumType @TestEnum, - equal . genericShow . order . argonaut $ mkSumType @MyUnit - ] + [ equal . genericShow . order . argonaut $ mkSumType @TestData + , equal . genericShow . order . argonaut $ mkSumType @TestSum + , equal . genericShow . order . argonaut $ mkSumType @TestRecursiveA + , equal . genericShow . order . argonaut $ mkSumType @TestRecursiveB + , functor . equal . genericShow . order . argonaut $ mkSumType @(TestRecord A) + , equal . genericShow . order . argonaut $ mkSumType @TestNewtype + , equal . genericShow . order . argonaut $ mkSumType @TestNewtypeRecord + , equal . genericShow . order . argonaut $ mkSumType @TestMultiInlineRecords + , equal . genericShow . order . argonaut $ mkSumType @TestTwoFields + , equal . genericShow . order . argonaut $ mkSumType @TestEnum + , equal . genericShow . order . argonaut $ mkSumType @MyUnit + ] roundtripSpec :: Spec roundtripSpec = do - aroundAll_ withProject $ - describe "writePSTypesWith" do - it "should be buildable" do - (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" - assertEqual (stdout <> stderr) exitCode ExitSuccess - it "should not warn of unused packages buildable" do - (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" - assertBool stderr $ not $ "[warn]" `isInfixOf` stderr - around withApp $ - it "should produce aeson-compatible argonaut instances" $ - \(hin, hout, herr, hproc) -> - property $ - \testData -> do - let input = toString $ encode @TestData testData - hPutStrLn hin input - err <- hGetLine herr - output <- hGetLine hout - assertEqual input "" err - assertEqual output (Right testData) $ eitherDecode @TestData $ fromString output + aroundAll_ withProject $ + describe "writePSTypesWith" do + it "should be buildable" do + (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" + assertEqual (stdout <> stderr) exitCode ExitSuccess + it "should not warn of unused packages buildable" do + (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" + assertBool stderr $ not $ "[warn]" `isInfixOf` stderr + around withApp $ + it "should produce aeson-compatible argonaut instances" $ + \(hin, hout, herr, hproc) -> + property $ + \testData -> do + let input = toString $ encode @TestData testData + hPutStrLn hin input + err <- hGetLine herr + output <- hGetLine hout + assertEqual input "" err + assertEqual output (Right testData) $ eitherDecode @TestData $ fromString output where withApp = bracket runApp killApp runApp = do - (Just hin, Just hout, Just herr, hproc) <- - createProcess - (proc "spago" ["run"]) - { std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe - } - hSetBuffering hin LineBuffering - hSetBuffering hout LineBuffering - hSetBuffering herr LineBuffering - -- flush stderr output from build - _ <- hGetLine herr - -- wait for initial log message - _ <- hGetLine hout - pure (hin, hout, herr, hproc) + (Just hin, Just hout, Just herr, hproc) <- + createProcess + (proc "spago" ["run"]) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + hSetBuffering hin LineBuffering + hSetBuffering hout LineBuffering + hSetBuffering herr LineBuffering + -- flush stderr output from build + _ <- hGetLine herr + -- wait for initial log message + _ <- hGetLine hout + pure (hin, hout, herr, hproc) killApp (_, _, _, hproc) = terminateProcess hproc withProject runSpec = - withCurrentDirectory "test/RoundTrip/app" $ generate *> runSpec + withCurrentDirectory "test/RoundTrip/app" $ generate *> runSpec generate = do - writePSTypesWith - defaultSwitch - "src" - (buildBridge myBridge) - myTypes + writePSTypesWith + defaultSwitch + "src" + (buildBridge myBridge) + myTypes diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index 31f15b99..24c99efa 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -1,43 +1,48 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module RoundTrip.Types where -import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON, ToJSON) -import Data.Map (Map) -import Data.Proxy (Proxy (..)) -import Data.Set (Set) -import Data.Text (Text) -import GHC.Generics (Generic) -import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, defaultSwitch, mkSumType, writePSTypes, writePSTypesWith) -import Language.PureScript.Bridge.TypeParameters (A) -import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) -import System.Exit (ExitCode (ExitSuccess)) -import System.Process (readProcessWithExitCode) -import Test.HUnit (assertEqual) -import Test.Hspec (Spec, aroundAll_, describe, it) -import Test.Hspec.Expectations.Pretty (shouldBe) -import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, sized) +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import Data.Text (Text) +import GHC.Generics (Generic) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, + buildBridge, defaultBridge, + defaultSwitch, mkSumType, + writePSTypes, writePSTypesWith) +import Language.PureScript.Bridge.TypeParameters (A) +import System.Directory (removeDirectoryRecursive, removeFile, + withCurrentDirectory) +import System.Exit (ExitCode (ExitSuccess)) +import System.Process (readProcessWithExitCode) +import Test.Hspec (Spec, aroundAll_, describe, it) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.HUnit (assertEqual) +import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, + sized) data TestData = Maybe (Maybe TestSum) | Either (Either (Maybe Int) (Maybe Bool)) - deriving (Show, Eq, Ord, Generic) + deriving (Eq, Generic, Ord, Show) instance FromJSON TestData instance ToJSON TestData instance Arbitrary TestData where - arbitrary = - oneof - [ Maybe <$> arbitrary, - Either <$> arbitrary - ] + arbitrary = + oneof + [ Maybe <$> arbitrary + , Either <$> arbitrary + ] data TestSum = Nullary @@ -46,7 +51,10 @@ data TestSum | Number Double | String String | Array [Int] - | InlineRecord {why :: String, wouldYouDoThis :: Int} + | InlineRecord + { why :: String + , wouldYouDoThis :: Int + } | MultiInlineRecords TestMultiInlineRecords | Record (TestRecord Int) | NestedRecord (TestRecord (TestRecord Int)) @@ -63,54 +71,57 @@ data TestSum | QuadSimple Int Double Bool Double | Recursive TestRecursiveA | Enum TestEnum - deriving (Show, Eq, Ord, Generic) + deriving (Eq, Generic, Ord, Show) instance FromJSON TestSum instance ToJSON TestSum instance Arbitrary TestSum where - arbitrary = - oneof - [ pure Nullary, - Bool <$> arbitrary, - Int <$> arbitrary, - Number <$> arbitrary, - String <$> arbitrary, - Array <$> arbitrary, - InlineRecord <$> arbitrary <*> arbitrary, - MultiInlineRecords <$> arbitrary, - Record <$> arbitrary, - NestedRecord <$> arbitrary, - NT <$> arbitrary, - NTRecord <$> arbitrary, - Map <$> arbitrary, - Set <$> arbitrary, - TwoFields <$> arbitrary, - pure $ Unit (), - Pair <$> arbitrary, - Triple <$> arbitrary, - Quad <$> arbitrary, - QuadSimple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary, - Enum <$> arbitrary - ] - -data TestRecursiveA = Nil | Recurse TestRecursiveB - deriving (Show, Eq, Ord, Generic) + arbitrary = + oneof + [ pure Nullary + , Bool <$> arbitrary + , Int <$> arbitrary + , Number <$> arbitrary + , String <$> arbitrary + , Array <$> arbitrary + , InlineRecord <$> arbitrary <*> arbitrary + , MultiInlineRecords <$> arbitrary + , Record <$> arbitrary + , NestedRecord <$> arbitrary + , NT <$> arbitrary + , NTRecord <$> arbitrary + , Map <$> arbitrary + , Set <$> arbitrary + , TwoFields <$> arbitrary + , pure $ Unit () + , Pair <$> arbitrary + , Triple <$> arbitrary + , Quad <$> arbitrary + , QuadSimple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , Enum <$> arbitrary + ] + +data TestRecursiveA + = Nil + | Recurse TestRecursiveB + deriving (Eq, Generic, Ord, Show) instance FromJSON TestRecursiveA instance ToJSON TestRecursiveA instance Arbitrary TestRecursiveA where - arbitrary = sized go - where - go size - | size > 0 = oneof [pure Nil, resize (size - 1) $ Recurse <$> arbitrary] - | otherwise = pure Nil + arbitrary = sized go + where + go size + | size > 0 = oneof [pure Nil, resize (size - 1) $ Recurse <$> arbitrary] + | otherwise = pure Nil -newtype TestRecursiveB = RecurseB TestRecursiveB - deriving (Show, Eq, Ord, Generic, Arbitrary) +newtype TestRecursiveB + = RecurseB TestRecursiveB + deriving (Arbitrary, Eq, Generic, Ord, Show) instance FromJSON TestRecursiveB @@ -118,91 +129,87 @@ instance ToJSON TestRecursiveB data TestMultiInlineRecords = Foo - { _foo1 :: Maybe Int, - _foo2 :: () - } + { _foo1 :: Maybe Int + , _foo2 :: () + } | Bar - { _bar1 :: String, - _bar2 :: Bool - } - deriving (Show, Eq, Ord, Generic) + { _bar1 :: String + , _bar2 :: Bool + } + deriving (Eq, Generic, Ord, Show) instance FromJSON TestMultiInlineRecords instance ToJSON TestMultiInlineRecords instance Arbitrary TestMultiInlineRecords where - arbitrary = - oneof - [ Foo <$> arbitrary <*> arbitrary, - Bar <$> arbitrary <*> arbitrary - ] + arbitrary = + oneof + [ Foo <$> arbitrary <*> arbitrary + , Bar <$> arbitrary <*> arbitrary + ] data TestRecord a = TestRecord - { _field1 :: Maybe Int, - _field2 :: a + { _field1 :: Maybe Int + , _field2 :: a } - deriving (Show, Eq, Ord, Generic) + deriving (Eq, Generic, Ord, Show) instance (FromJSON a) => FromJSON (TestRecord a) instance (ToJSON a) => ToJSON (TestRecord a) instance (Arbitrary a) => Arbitrary (TestRecord a) where - arbitrary = TestRecord <$> arbitrary <*> arbitrary + arbitrary = TestRecord <$> arbitrary <*> arbitrary data TestTwoFields = TestTwoFields Bool Int - deriving (Show, Eq, Ord, Generic) + deriving (Eq, Generic, Ord, Show) instance FromJSON TestTwoFields instance ToJSON TestTwoFields instance Arbitrary TestTwoFields where - arbitrary = TestTwoFields <$> arbitrary <*> arbitrary + arbitrary = TestTwoFields <$> arbitrary <*> arbitrary -newtype TestNewtype = TestNewtype (TestRecord Bool) - deriving (Show, Eq, Ord, Generic) +newtype TestNewtype + = TestNewtype (TestRecord Bool) + deriving (Eq, Generic, Ord, Show) instance FromJSON TestNewtype instance ToJSON TestNewtype instance Arbitrary TestNewtype where - arbitrary = TestNewtype <$> arbitrary + arbitrary = TestNewtype <$> arbitrary -newtype TestNewtypeRecord = TestNewtypeRecord {unTestNewtypeRecord :: TestNewtype} - deriving (Show, Eq, Ord, Generic) +newtype TestNewtypeRecord + = TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } + deriving (Eq, Generic, Ord, Show) instance FromJSON TestNewtypeRecord instance ToJSON TestNewtypeRecord instance Arbitrary TestNewtypeRecord where - arbitrary = TestNewtypeRecord <$> arbitrary - -data TestEnum - = Mon - | Tue - | Wed - | Thu - | Fri - | Sat - | Sun - deriving (Show, Eq, Ord, Bounded, Enum, Generic) + arbitrary = TestNewtypeRecord <$> arbitrary + +data TestEnum = Mon | Tue | Wed | Thu | Fri | Sat | Sun + deriving (Bounded, Enum, Eq, Generic, Ord, Show) instance FromJSON TestEnum instance ToJSON TestEnum instance Arbitrary TestEnum where - arbitrary = chooseEnum (minBound, maxBound) + arbitrary = chooseEnum (minBound, maxBound) -data MyUnit = U deriving (Show, Eq, Ord, Bounded, Enum, Generic) +data MyUnit = U + deriving (Bounded, Enum, Eq, Generic, Ord, Show) instance FromJSON MyUnit instance ToJSON MyUnit instance Arbitrary MyUnit where - arbitrary = pure U + arbitrary = pure U diff --git a/test/Spec.hs b/test/Spec.hs index 7cfdda56..75815132 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,36 +1,26 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Main where import qualified Data.Map as Map -import Data.Monoid ((<>)) -import Data.Text (Text) +import Data.Monoid ((<>)) +import Data.Text (Text) import qualified Data.Text as T -import Language.PureScript.Bridge -import Language.PureScript.Bridge.CodeGenSwitches -import Language.PureScript.Bridge.TypeParameters -import RoundTrip.Spec (roundtripSpec) -import Test.Hspec - ( Spec, - describe, - hspec, - it, - ) -import Test.Hspec.Expectations.Pretty -import TestData -import Text.PrettyPrint.Leijen.Text - ( Doc, - cat, - linebreak, - punctuate, - vsep, - ) +import Language.PureScript.Bridge +import Language.PureScript.Bridge.CodeGenSwitches +import Language.PureScript.Bridge.TypeParameters +import RoundTrip.Spec (roundtripSpec) +import Test.Hspec (Spec, describe, hspec, it) +import Test.Hspec.Expectations.Pretty +import TestData +import Text.PrettyPrint.Leijen.Text (Doc, cat, linebreak, punctuate, + vsep) main :: IO () main = hspec $ allTests *> roundtripSpec @@ -39,243 +29,243 @@ custom :: SumType 'Haskell -> SumType 'Haskell custom (SumType t cs is) = SumType t cs $ customInstance : is where customInstance = - Custom $ - CustomInstance [] (TypeInfo "" "Data.MyClass" "MyClass" [TypeInfo "" "" "Foo" []]) $ - Explicit - [ InstanceMember "member1" ["foo", "bar"] "undefined" [] mempty, - InstanceMember "member2" [] "do\npure unit" [] mempty - ] + Custom $ + CustomInstance [] (TypeInfo "" "Data.MyClass" "MyClass" [TypeInfo "" "" "Foo" []]) $ + Explicit + [ InstanceMember "member1" ["foo", "bar"] "undefined" [] mempty + , InstanceMember "member2" [] "do\npure unit" [] mempty + ] customNewtypeDerived :: SumType 'Haskell -> SumType 'Haskell customNewtypeDerived (SumType t cs is) = SumType t cs $ customInstance : is where customInstance = - Custom $ - CustomInstance - [TypeInfo "" "" "Eq" [TypeInfo "" "" "Foo" []]] - (TypeInfo "" "Data.MyNTClass" "MyNTClass" [TypeInfo "" "" "Foo" []]) - DeriveNewtype + Custom $ + CustomInstance + [TypeInfo "" "" "Eq" [TypeInfo "" "" "Foo" []]] + (TypeInfo "" "Data.MyNTClass" "MyNTClass" [TypeInfo "" "" "Foo" []]) + DeriveNewtype customDerived :: SumType 'Haskell -> SumType 'Haskell customDerived (SumType t cs is) = SumType t cs $ customInstance : is where customInstance = - Custom $ - CustomInstance - [ TypeInfo "" "" "Eq" [TypeInfo "" "" "Foo" []], - TypeInfo "" "" "Show" [TypeInfo "" "" "Foo" []] - ] - (TypeInfo "" "Data.MyDClass" "MyDClass" [TypeInfo "" "" "Foo" []]) - Derive + Custom $ + CustomInstance + [ TypeInfo "" "" "Eq" [TypeInfo "" "" "Foo" []] + , TypeInfo "" "" "Show" [TypeInfo "" "" "Foo" []] + ] + (TypeInfo "" "Data.MyDClass" "MyDClass" [TypeInfo "" "" "Foo" []]) + Derive allTests :: Spec allTests = do - describe "buildBridge without lens-code-gen" $ do - let settings = getSettings noLenses - it "tests generation of custom typeclasses" $ - let sumType = - bridgeSumType - (buildBridge defaultBridge) - (customNewtypeDerived . customDerived . custom $ mkSumType @Foo) - doc = vsep $ sumTypeToDocs settings sumType - txt = - T.unlines - [ "data Foo", - " = Foo", - " | Bar Int", - " | FooBar Int String", - "", - "derive newtype instance (Eq Foo) => MyNTClass Foo", - "", - "derive instance (Eq Foo, Show Foo) => MyDClass Foo", - "", - "instance MyClass Foo where", - " member1 foo bar = undefined", - " member2 = do", - " pure unit", - "", - "derive instance Generic Foo _" - ] - in doc `shouldRender` txt - it "tests generation of typeclasses for custom type Foo" $ - let sumType = - bridgeSumType - (buildBridge defaultBridge) - (genericShow . order $ mkSumType @Foo) - doc = vsep $ sumTypeToDocs settings sumType - txt = - T.unlines - [ "data Foo", - " = Foo", - " | Bar Int", - " | FooBar Int String", - "", - "instance Show Foo where", - " show a = genericShow a", - "", - "derive instance Eq Foo", - "", - "derive instance Ord Foo", - "", - "derive instance Generic Foo _" - ] - in doc `shouldRender` txt - it "tests generation of typeclasses for custom type Func" $ - let sumType = - bridgeSumType - (buildBridge defaultBridge) - (equal1 . functor . genericShow $ mkSumType @(Func A)) - doc = vsep $ sumTypeToDocs settings sumType - txt = - T.unlines - [ "data Func a = Func Int a", - "", - "derive instance Eq1 Func", - "", - "derive instance Functor Func", - "", - "instance (Show a) => Show (Func a) where", - " show a = genericShow a", - "", - "derive instance Generic (Func a) _" - ] - in doc `shouldRender` txt - it "tests the generation of a whole (dummy) module" $ - let advanced' :: SumType 'PureScript - advanced' = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType @(Bar A B M1 C)) - modules :: Modules - modules = sumTypeToModule Nothing advanced' - m = head . map (moduleToText settings) . Map.elems $ modules - txt = - T.unlines - [ "-- File auto generated by purescript-bridge! --", - "module TestData where", - "", - "import Prelude", - "", - "import Data.Either (Either)", - "import Data.Generic.Rep (class Generic)", - "import Data.Maybe (Maybe(..))", - "", - "data Bar a b m c", - " = Bar1 (Maybe a)", - " | Bar2 (Either a b)", - " | Bar3 a", - " | Bar4 { myMonadicResult :: m b }", - "", - "derive instance 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 @(SingleRecord A B)) - doc = vsep $ sumTypeToDocs settings recType' - txt = - T.unlines - [ "newtype SingleRecord a b = SingleRecord", - " { _a :: a", - " , _b :: b", - " , c :: String", - " }", - "", - "derive instance Generic (SingleRecord a b) _", - "", - "derive instance Newtype (SingleRecord a b) _" - ] - in doc `shouldRender` txt - it "tests generation of newtypes for haskell newtype" $ - let recType' = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType @SomeNewtype) - doc = vsep $ sumTypeToDocs settings recType' - txt = - T.unlines - [ "newtype SomeNewtype = SomeNewtype Int", - "", - "derive instance Generic SomeNewtype _", - "", - "derive instance Newtype SomeNewtype _" - ] - in doc `shouldRender` txt - it "tests generation of newtypes for haskell data type with one argument" $ - let recType' = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType @SingleValueConstr) - doc = vsep $ sumTypeToDocs settings recType' - txt = - T.unlines - [ "newtype SingleValueConstr = SingleValueConstr Int", - "", - "derive instance Generic SingleValueConstr _", - "", - "derive instance Newtype SingleValueConstr _" - ] - in doc `shouldRender` txt - it - "tests generation for haskell data type with one constructor, two arguments" - $ let recType' = - bridgeSumType - (buildBridge defaultBridge) - (mkSumType @SingleProduct) - doc = vsep $ sumTypeToDocs settings recType' - txt = - T.unlines - [ "data SingleProduct = SingleProduct String Int", - "", - "derive instance Generic SingleProduct _" - ] - in doc `shouldRender` txt - it "tests generation Eq instances for polymorphic types" $ - let recType' = - bridgeSumType - (buildBridge defaultBridge) - (equal $ mkSumType @(SingleRecord A B)) - doc = vsep $ sumTypeToDocs settings recType' - txt = - T.unlines - [ "newtype SingleRecord a b = SingleRecord", - " { _a :: a", - " , _b :: b", - " , c :: String", - " }", - "", - "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)", - "", - "derive instance Generic (SingleRecord a b) _", - "", - "derive instance Newtype (SingleRecord a b) _" - ] - in doc `shouldRender` txt - it "tests generation of Ord instances for polymorphic types" $ - let recType' = - bridgeSumType - (buildBridge defaultBridge) - (order $ mkSumType @(SingleRecord A B)) - doc = vsep $ sumTypeToDocs settings recType' - txt = - T.unlines - [ "newtype SingleRecord a b = SingleRecord", - " { _a :: a", - " , _b :: b", - " , c :: String", - " }", - "", - "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)", - "", - "derive instance (Ord a, Ord b) => Ord (SingleRecord a b)", - "", - "derive instance Generic (SingleRecord a b) _", - "", - "derive instance Newtype (SingleRecord a b) _" - ] - in doc `shouldRender` txt + describe "buildBridge without lens-code-gen" $ do + let settings = getSettings noLenses + it "tests generation of custom typeclasses" $ + let sumType = + bridgeSumType + (buildBridge defaultBridge) + (customNewtypeDerived . customDerived . custom $ mkSumType @Foo) + doc = vsep $ sumTypeToDocs settings sumType + txt = + T.unlines + [ "data Foo" + , " = Foo" + , " | Bar Int" + , " | FooBar Int String" + , "" + , "derive newtype instance (Eq Foo) => MyNTClass Foo" + , "" + , "derive instance (Eq Foo, Show Foo) => MyDClass Foo" + , "" + , "instance MyClass Foo where" + , " member1 foo bar = undefined" + , " member2 = do" + , " pure unit" + , "" + , "derive instance Generic Foo _" + ] + in doc `shouldRender` txt + it "tests generation of typeclasses for custom type Foo" $ + let sumType = + bridgeSumType + (buildBridge defaultBridge) + (genericShow . order $ mkSumType @Foo) + doc = vsep $ sumTypeToDocs settings sumType + txt = + T.unlines + [ "data Foo" + , " = Foo" + , " | Bar Int" + , " | FooBar Int String" + , "" + , "instance Show Foo where" + , " show a = genericShow a" + , "" + , "derive instance Eq Foo" + , "" + , "derive instance Ord Foo" + , "" + , "derive instance Generic Foo _" + ] + in doc `shouldRender` txt + it "tests generation of typeclasses for custom type Func" $ + let sumType = + bridgeSumType + (buildBridge defaultBridge) + (equal1 . functor . genericShow $ mkSumType @(Func A)) + doc = vsep $ sumTypeToDocs settings sumType + txt = + T.unlines + [ "data Func a = Func Int a" + , "" + , "derive instance Eq1 Func" + , "" + , "derive instance Functor Func" + , "" + , "instance (Show a) => Show (Func a) where" + , " show a = genericShow a" + , "" + , "derive instance Generic (Func a) _" + ] + in doc `shouldRender` txt + it "tests the generation of a whole (dummy) module" $ + let advanced' :: SumType 'PureScript + advanced' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType @(Bar A B M1 C)) + modules :: Modules + modules = sumTypeToModule Nothing advanced' + m = head . map (moduleToText settings) . Map.elems $ modules + txt = + T.unlines + [ "-- File auto generated by purescript-bridge! --" + , "module TestData where" + , "" + , "import Prelude" + , "" + , "import Data.Either (Either)" + , "import Data.Generic.Rep (class Generic)" + , "import Data.Maybe (Maybe(..))" + , "" + , "data Bar a b m c" + , " = Bar1 (Maybe a)" + , " | Bar2 (Either a b)" + , " | Bar3 a" + , " | Bar4 { myMonadicResult :: m b }" + , "" + , "derive instance 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 @(SingleRecord A B)) + doc = vsep $ sumTypeToDocs settings recType' + txt = + T.unlines + [ "newtype SingleRecord a b = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "derive instance Generic (SingleRecord a b) _" + , "" + , "derive instance Newtype (SingleRecord a b) _" + ] + in doc `shouldRender` txt + it "tests generation of newtypes for haskell newtype" $ + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType @SomeNewtype) + doc = vsep $ sumTypeToDocs settings recType' + txt = + T.unlines + [ "newtype SomeNewtype = SomeNewtype Int" + , "" + , "derive instance Generic SomeNewtype _" + , "" + , "derive instance Newtype SomeNewtype _" + ] + in doc `shouldRender` txt + it "tests generation of newtypes for haskell data type with one argument" $ + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType @SingleValueConstr) + doc = vsep $ sumTypeToDocs settings recType' + txt = + T.unlines + [ "newtype SingleValueConstr = SingleValueConstr Int" + , "" + , "derive instance Generic SingleValueConstr _" + , "" + , "derive instance Newtype SingleValueConstr _" + ] + in doc `shouldRender` txt + it + "tests generation for haskell data type with one constructor, two arguments" + $ let recType' = + bridgeSumType + (buildBridge defaultBridge) + (mkSumType @SingleProduct) + doc = vsep $ sumTypeToDocs settings recType' + txt = + T.unlines + [ "data SingleProduct = SingleProduct String Int" + , "" + , "derive instance Generic SingleProduct _" + ] + in doc `shouldRender` txt + it "tests generation Eq instances for polymorphic types" $ + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (equal $ mkSumType @(SingleRecord A B)) + doc = vsep $ sumTypeToDocs settings recType' + txt = + T.unlines + [ "newtype SingleRecord a b = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)" + , "" + , "derive instance Generic (SingleRecord a b) _" + , "" + , "derive instance Newtype (SingleRecord a b) _" + ] + in doc `shouldRender` txt + it "tests generation of Ord instances for polymorphic types" $ + let recType' = + bridgeSumType + (buildBridge defaultBridge) + (order $ mkSumType @(SingleRecord A B)) + doc = vsep $ sumTypeToDocs settings recType' + txt = + T.unlines + [ "newtype SingleRecord a b = SingleRecord" + , " { _a :: a" + , " , _b :: b" + , " , c :: String" + , " }" + , "" + , "derive instance (Eq a, Eq b) => Eq (SingleRecord a b)" + , "" + , "derive instance (Ord a, Ord b) => Ord (SingleRecord a b)" + , "" + , "derive instance Generic (SingleRecord a b) _" + , "" + , "derive instance Newtype (SingleRecord a b) _" + ] + in doc `shouldRender` txt shouldRender :: Doc -> Text -> Expectation shouldRender actual expected = renderText actual `shouldBe` T.stripEnd expected diff --git a/test/TestData.hs b/test/TestData.hs index c4020a02..1ad874cc 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -1,86 +1,91 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module TestData where -import Data.Functor.Classes (Eq1 (liftEq)) -import Data.Proxy -import Data.Text (Text) -import Data.Typeable -import GHC.Generics (Generic) -import Language.PureScript.Bridge -import Language.PureScript.Bridge.CodeGenSwitches (defaultSettings) -import Language.PureScript.Bridge.PSTypes +import Data.Functor.Classes (Eq1 (liftEq)) +import Data.Proxy +import Data.Text (Text) +import Data.Typeable +import GHC.Generics (Generic) +import Language.PureScript.Bridge +import Language.PureScript.Bridge.CodeGenSwitches (defaultSettings) +import Language.PureScript.Bridge.PSTypes -- Check that examples compile: textBridge :: BridgePart textBridge = do - typeName ^== "Text" - typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" - return psString + typeName ^== "Text" + typeModule ^== "Data.Text.Internal" <|> typeModule ^== "Data.Text.Internal.Lazy" + return psString stringBridge :: BridgePart stringBridge = do - haskType ^== mkTypeInfo @String - return psString + haskType ^== mkTypeInfo @String + return psString data Foo = Foo | Bar Int | FooBar Int Text - deriving (Eq, Ord, Generic, Typeable, Show) + deriving (Eq, Generic, Ord, Show, Typeable) data Func a = Func Int a - deriving (Eq, Ord, Functor, Generic, Typeable, Show) + deriving (Eq, Functor, Generic, Ord, Show, Typeable) instance Eq1 Func where - liftEq eq (Func n x) (Func m y) = n == m && x `eq` y + liftEq eq (Func n x) (Func m y) = n == m && x `eq` y data Test = TestIntInt Int Int - | TestBool {bool :: Bool} + | TestBool + { bool :: Bool + } | TestVoid - deriving (Generic, Typeable, Show) + deriving (Generic, Show, Typeable) data Bar a b m c = Bar1 (Maybe a) | Bar2 (Either a b) | Bar3 a - | Bar4 {myMonadicResult :: m b} - deriving (Generic, Typeable, Show) + | Bar4 + { myMonadicResult :: m b + } + deriving (Generic, Show, Typeable) data SingleRecord a b = SingleRecord - { _a :: a, - _b :: b, - c :: String + { _a :: a + , _b :: b + , c :: String } - deriving (Generic, Eq, Ord, Typeable, Show) + deriving (Eq, Generic, Ord, Show, Typeable) data TwoRecords = FirstRecord - { _fra :: String, - _frb :: Int - } + { _fra :: String + , _frb :: Int + } | SecondRecord - { _src :: Int, - _srd :: [Int] - } - deriving (Generic, Typeable, Show) + { _src :: Int + , _srd :: [Int] + } + deriving (Generic, Show, Typeable) -newtype SomeNewtype = SomeNewtype Int - deriving (Generic, Typeable, Show) +newtype SomeNewtype + = SomeNewtype Int + deriving (Generic, Show, Typeable) data SingleValueConstr = SingleValueConstr Int - deriving (Generic, Typeable, Show) + deriving (Generic, Show, Typeable) data SingleProduct = SingleProduct Text Int - deriving (Generic, Typeable, Show) + deriving (Generic, Show, Typeable) a :: HaskellType a = mkTypeInfo @(Either String Int) From 027e5e768efc67fbf884dc548a78d9128fb9c1d7 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 30 Sep 2023 13:39:26 -0700 Subject: [PATCH 062/111] Encode/Decode instances by IOHK using `purescript-bridge-json-helpers` https://github.com/input-output-hk/purescript-bridge-json-helpers --- src/Language/PureScript/Bridge.hs | 2 + src/Language/PureScript/Bridge/Printer.hs | 58 +++++++---------- src/Language/PureScript/Bridge/SumType.hs | 76 +++++++++++++++++------ 3 files changed, 82 insertions(+), 54 deletions(-) diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index b1190f83..bcc90072 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -136,6 +136,8 @@ bridgeSumType br (SumType t cs is) = bridgeInstance Enum = Enum bridgeInstance EncodeJson = EncodeJson bridgeInstance DecodeJson = DecodeJson + bridgeInstance EncodeJsonHelper = EncodeJsonHelper + bridgeInstance DecodeJsonHelper = DecodeJsonHelper bridgeInstance (ForeignObject x y) = ForeignObject x y bridgeInstance GenericShow = GenericShow bridgeInstance Functor = Functor diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 332864fd..2b08c182 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -150,17 +150,6 @@ instancesToImportLines = foldr unionImportLines Map.empty . fmap instanceToImportLines instanceToQualifiedImports :: PSInstance -> Map Text Text --- for IOHK library --- instanceToQualifiedImports EncodeJson = --- Map.fromList --- [ ("Data.Argonaut.Encode.Aeson", "E") --- , ("Data.Map", "Map") --- ] --- instanceToQualifiedImports DecodeJson = --- Map.fromList --- [ ("Data.Argonaut.Decode.Aeson", "D") --- , ("Data.Map", "Map") --- ] instanceToQualifiedImports _ = Map.empty printModule :: FilePath -> PSModule -> IO () @@ -388,29 +377,30 @@ instances st@(SumType t _ is) = go <$> is (mkType "DecodeJson" [t]) decodeJsonConstraints ["decodeJson = genericDecodeAeson Argonaut.defaultOptions"] - -- IOHK library - -- This relies on unpublished Purescript library `purescript-bridge-json-helpers`: - -- https://github.com/input-output-hk/purescript-bridge-json-helpers - -- and `purescript-argonaut-codecs` - -- https://pursuit.purescript.org/packages/purescript-argonaut-codecs - -- go EncodeJson = - -- vsep $ - -- punctuate - -- line - -- [ mkInstance - -- (mkType "EncodeJson" [t]) - -- encodeJsonConstraints - -- ["encodeJson = defer \\_ ->" <+> sumTypeToEncode st] - -- ] - -- go DecodeJson = - -- vsep $ - -- punctuate - -- line - -- [ mkInstance - -- (mkType "DecodeJson" [t]) - -- decodeJsonConstraints - -- [hang 2 $ "decodeJson = defer \\_ -> D.decode" <+> sumTypeToDecode st] - -- ] + {-| + This relies on unpublished Purescript library `purescript-bridge-json-helpers`: + https://github.com/input-output-hk/purescript-bridge-json-helpers + and `purescript-argonaut-codecs` + https://pursuit.purescript.org/packages/purescript-argonaut-codecs + -} + go EncodeJsonHelper = + vsep $ + punctuate + line + [ mkInstance + (mkType "EncodeJson" [t]) + encodeJsonConstraints + ["encodeJson = defer \\_ ->" <+> sumTypeToEncode st] + ] + go DecodeJsonHelper = + vsep $ + punctuate + line + [ mkInstance + (mkType "DecodeJson" [t]) + decodeJsonConstraints + [hang 2 $ "decodeJson = defer \\_ -> D.decode" <+> sumTypeToDecode st] + ] go GenericShow = mkInstance (mkType "Show" [t]) showConstraints ["show a = genericShow a"] go Functor = mkDerivedInstance (mkType "Functor" [toKind1 t]) (const []) go Eq = mkDerivedInstance (mkType "Eq" [t]) eqConstraints diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 8be49961..140bff6d 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -20,6 +20,7 @@ module Language.PureScript.Bridge.SumType , equal1 , order , argonautJson + , jsonHelper , genericShow , functor , DataConstructor (..) @@ -131,6 +132,14 @@ data Instance (lang :: Language) -- using argonaut-codecs: -- | DecodeJson + -- | Generate using unpublished Purescript library + -- `purescript-bridge-json-helpers` + -- + | EncodeJsonHelper + -- | Generate using unpublished Purescript library + -- `purescript-bridge-json-helpers` + -- + | DecodeJsonHelper -- | Generate `Foreign.Generic` and `Foreign.Object` -- using purescript-foreign-generic: -- @@ -190,6 +199,12 @@ nootype _ = Nothing argonautJson :: SumType t -> SumType t argonautJson (SumType ti dc is) = SumType ti dc . nub $ EncodeJson : DecodeJson : is +-- | Ensure that aeson-compatible `EncodeJson` and `DecodeJson` instances are generated for your type. +-- Uses unpublished library `purescript-bridge-json-helpers` +-- +jsonHelper :: SumType t -> SumType t +jsonHelper (SumType ti dc is) = SumType ti dc . nub $ EncodeJsonHelper : DecodeJsonHelper : is + -- | Ensure that a generic `Show` instance is generated for your type. genericShow :: SumType t -> SumType t genericShow (SumType ti dc is) = SumType ti dc . nub $ GenericShow : is @@ -303,6 +318,16 @@ instanceToTypes EncodeJson = pure . constraintToType $ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] instanceToTypes DecodeJson = pure . constraintToType $ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [] +{-| + For unpublished Purescript library `purescript-bridge-json-helpers`: + https://github.com/input-output-hk/purescript-bridge-json-helpers + and `purescript-argonaut-codecs` + https://pursuit.purescript.org/packages/purescript-argonaut-codecs +-} +instanceToTypes EncodeJsonHelper = + pure . constraintToType $ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] +instanceToTypes DecodeJsonHelper = + pure . constraintToType $ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [] instanceToTypes (ForeignObject _ _) = fmap constraintToType [ TypeInfo "purescript-foreign" "Foreign" "Foreign" [] , TypeInfo "purescript-foreign-object" "Foreign.Object" "Object" [] @@ -357,26 +382,37 @@ instanceToImportLines DecodeJson = , ImportLine "Data.Argonaut.Decode.Class" Nothing $ Set.fromList ["class DecodeJson", "class DecodeJsonField", "decodeJson"] ] --- for IOHK library --- This relies on unpublished Purescript library `purescript-bridge-json-helpers`: --- https://github.com/input-output-hk/purescript-bridge-json-helpers --- and `purescript-argonaut-codecs` --- https://pursuit.purescript.org/packages/purescript-argonaut-codecs --- instanceToImportLines EncodeJson = --- importsFromList --- [ ImportLine "Control.Lazy" Nothing $ Set.singleton "defer" --- , ImportLine "Data.Argonaut" Nothing $ Set.fromList ["encodeJson", "jsonNull"] --- , ImportLine "Data.Argonaut.Encode.Aeson" Nothing $ Set.fromList ["(>$<)", "(>/\\<)"] --- , ImportLine "Data.Newtype" Nothing $ Set.singleton "unwrap" --- , ImportLine "Data.Tuple.Nested" Nothing $ Set.singleton "(/\\)" --- ] --- instanceToImportLines DecodeJson = --- importsFromList --- [ ImportLine "Control.Lazy" Nothing $ Set.singleton "defer" --- , ImportLine "Data.Argonaut.Decode.Aeson" Nothing $ Set.fromList ["()", "()", "()"] --- , ImportLine "Data.Newtype" Nothing $ Set.singleton "unwrap" --- , ImportLine "Data.Tuple.Nested" Nothing $ Set.singleton "(/\\)" --- ] +{-| + This relies on unpublished Purescript library `purescript-bridge-json-helpers`: + https://github.com/input-output-hk/purescript-bridge-json-helpers + and `purescript-argonaut-codecs` + https://pursuit.purescript.org/packages/purescript-argonaut-codecs +-} +instanceToImportLines EncodeJsonHelper = + importsFromList + [ ImportLine "Control.Lazy" Nothing $ Set.singleton "defer" + , ImportLine "Data.Argonaut" Nothing $ Set.fromList ["encodeJson", "jsonNull"] + , ImportLine "Data.Argonaut.Encode.Aeson" Nothing $ Set.fromList ["(>$<)", "(>/\\<)"] + , ImportLine "Data.Newtype" Nothing $ Set.singleton "unwrap" + , ImportLine "Data.Tuple.Nested" Nothing $ Set.singleton "(/\\)" + , ImportLine "Data.Argonaut.Encode.Aeson" (Just "E") mempty + , ImportLine "Data.Map" (Just "Map") mempty + ] +{-| + This relies on unpublished Purescript library `purescript-bridge-json-helpers`: + https://github.com/input-output-hk/purescript-bridge-json-helpers + and `purescript-argonaut-codecs` + https://pursuit.purescript.org/packages/purescript-argonaut-codecs +-} +instanceToImportLines DecodeJsonHelper = + importsFromList + [ ImportLine "Control.Lazy" Nothing $ Set.singleton "defer" + , ImportLine "Data.Argonaut.Decode.Aeson" Nothing $ Set.fromList ["()", "()", "()"] + , ImportLine "Data.Newtype" Nothing $ Set.singleton "unwrap" + , ImportLine "Data.Tuple.Nested" Nothing $ Set.singleton "(/\\)" + , ImportLine "Data.Argonaut.Decode.Aeson" (Just "D") mempty + , ImportLine "Data.Map" (Just "Map") mempty + ] instanceToImportLines (ForeignObject _ _) = importsFromList [ ImportLine "Foreign.Class" Nothing From a57e39e3577cbe858492dc8b2cf87559423e347b Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 30 Sep 2023 14:48:10 -0700 Subject: [PATCH 063/111] bump to version 0.16.0.0; delete boilerplate --- purescript-bridge.cabal | 53 +---------------------------------------- 1 file changed, 1 insertion(+), 52 deletions(-) diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index b96d72ff..c25a759c 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -1,48 +1,12 @@ --- Initial purescript-bridge.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - --- The name of the package. name: purescript-bridge - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- http://www.haskell.org/haskellwiki/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.15.0.0 - --- A short (one-line) description of the package. +version: 0.16.0.0 synopsis: Generate PureScript data types from Haskell data types - --- A longer description of the package. --- description: - --- The license under which the package is released. license: BSD3 - --- The file containing the license text. license-file: LICENSE - --- The package author(s). author: Robert Klotzner - --- An email address to which users can send suggestions, bug reports, and --- patches. maintainer: robert . klotzner A T gmx . at - --- A copyright notice. --- copyright: - category: Web - build-type: Simple - --- Extra files to be distributed with the package, such as examples or a --- README. --- extra-source-files: - --- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.10 extra-source-files: README.md @@ -52,7 +16,6 @@ source-repository head location: https://github.com/eskimor/purescript-bridge.git library - -- Modules exported by the library. exposed-modules: Language.PureScript.Bridge , Language.PureScript.Bridge.CodeGenSwitches , Language.PureScript.Bridge.Builder @@ -63,14 +26,6 @@ library , Language.PureScript.Bridge.Tuple , Language.PureScript.Bridge.TypeInfo , Language.PureScript.Bridge.TypeParameters - - -- Modules included in this library but not exported. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. build-depends: base >=4.8 && < 6.0 , containers , directory @@ -81,16 +36,10 @@ library , transformers , wl-pprint-text , generic-deriving - ghc-options: -Wall - - -- Directories containing source files. hs-source-dirs: src - - -- Base language which the package is written in. default-language: Haskell2010 - Test-Suite tests type: exitcode-stdio-1.0 main-is: Spec.hs From fba4c7a0be37066afcc68d7b13a0f84980f9966a Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 30 Sep 2023 16:45:59 -0700 Subject: [PATCH 064/111] generate `DecodeJsonField` --- src/Language/PureScript/Bridge/Printer.hs | 18 +------- test/RoundTrip/Spec.hs | 28 ++++++++----- test/RoundTrip/app/src/RoundTrip/Types.purs | 46 ++++++++++----------- 3 files changed, 42 insertions(+), 50 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 2b08c182..b4e28e0c 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -432,7 +432,8 @@ showConstraints :: PSType -> [PSType] showConstraints = constrainWith "Show" decodeJsonConstraints :: PSType -> [PSType] -decodeJsonConstraints = constrainWith "DecodeJson" +decodeJsonConstraints psType = + (constrainWith "DecodeJson" psType) <> (constrainWith "DecodeJsonField" psType) encodeJsonConstraints :: PSType -> [PSType] encodeJsonConstraints = constrainWith "EncodeJson" @@ -499,21 +500,6 @@ sumTypeToEncode (SumType _ cs _) isTypeParam :: PSType -> PSType -> Bool isTypeParam t typ = _typeName typ `elem` map _typeName (_typeParameters t) --- encodeInstance :: PSType -> Text --- encodeInstance params = "Encode " <> typeInfoToText False params - --- encodeJsonInstance :: PSType -> Text --- encodeJsonInstance params = "EncodeJson " <> typeInfoToText False params - --- decodeInstance :: PSType -> Text --- decodeInstance params = "Decode " <> typeInfoToText False params - --- decodeJsonInstance :: PSType -> Text --- decodeJsonInstance params = "DecodeJson " <> typeInfoToText False params - --- decodeJsonFieldInstance :: PSType -> Text --- decodeJsonFieldInstance params = "DecodeJsonField " <> typeInfoToText False params - -- genericInstance :: Switches.Settings -> PSType -> Text -- genericInstance settings params = -- if not (Switches.genericsGenRep settings) diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index bbb78a6f..29be83e0 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -43,19 +43,25 @@ import Test.QuickCheck.Property (Testable (property)) myBridge :: BridgePart myBridge = defaultBridge +instancesToGenerate = equal + . order + . genericShow + . order + . argonautJson + myTypes :: [SumType 'Haskell] myTypes = - [ equal . genericShow . order . argonautJson $ mkSumType @TestData - , equal . genericShow . order . argonautJson $ mkSumType @TestSum - , equal . genericShow . order . argonautJson $ mkSumType @TestRecursiveA - , equal . genericShow . order . argonautJson $ mkSumType @TestRecursiveB - , functor . equal . genericShow . order . argonautJson $ mkSumType @(TestRecord A) - , equal . genericShow . order . argonautJson $ mkSumType @TestNewtype - , equal . genericShow . order . argonautJson $ mkSumType @TestNewtypeRecord - , equal . genericShow . order . argonautJson $ mkSumType @TestMultiInlineRecords - , equal . genericShow . order . argonautJson $ mkSumType @TestTwoFields - , equal . genericShow . order . argonautJson $ mkSumType @TestEnum - , equal . genericShow . order . argonautJson $ mkSumType @MyUnit + [ instancesToGenerate $ mkSumType @TestData + , instancesToGenerate $ mkSumType @TestSum + , instancesToGenerate $ mkSumType @TestRecursiveA + , instancesToGenerate $ mkSumType @TestRecursiveB + , functor . instancesToGenerate $ mkSumType @(TestRecord A) + , instancesToGenerate $ mkSumType @TestNewtype + , instancesToGenerate $ mkSumType @TestNewtypeRecord + , instancesToGenerate $ mkSumType @TestMultiInlineRecords + , instancesToGenerate $ mkSumType @TestTwoFields + , instancesToGenerate $ mkSumType @TestEnum + , instancesToGenerate $ mkSumType @MyUnit ] roundtripSpec :: Spec diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 5db82a6c..8dcd788f 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -31,11 +31,11 @@ data TestData derive instance Eq TestData +derive instance Ord TestData + instance Show TestData where show a = genericShow a -derive instance Ord TestData - instance EncodeJson TestData where encodeJson = genericEncodeAeson Argonaut.defaultOptions @@ -76,11 +76,11 @@ data TestSum derive instance Eq TestSum +derive instance Ord TestSum + instance Show TestSum where show a = genericShow a -derive instance Ord TestSum - instance EncodeJson TestSum where encodeJson = genericEncodeAeson Argonaut.defaultOptions @@ -97,11 +97,11 @@ data TestRecursiveA derive instance Eq TestRecursiveA +derive instance Ord TestRecursiveA + instance Show TestRecursiveA where show a = genericShow a -derive instance Ord TestRecursiveA - instance EncodeJson TestRecursiveA where encodeJson = genericEncodeAeson Argonaut.defaultOptions @@ -116,11 +116,11 @@ newtype TestRecursiveB = RecurseB TestRecursiveB derive instance Eq TestRecursiveB +derive instance Ord TestRecursiveB + instance Show TestRecursiveB where show a = genericShow a -derive instance Ord TestRecursiveB - instance EncodeJson TestRecursiveB where encodeJson = genericEncodeAeson Argonaut.defaultOptions @@ -142,15 +142,15 @@ derive instance Functor TestRecord derive instance (Eq a) => Eq (TestRecord a) +derive instance (Ord a) => Ord (TestRecord a) + instance (Show a) => Show (TestRecord a) where show a = genericShow a -derive instance (Ord a) => Ord (TestRecord a) - instance (EncodeJson a) => EncodeJson (TestRecord a) where encodeJson = genericEncodeAeson Argonaut.defaultOptions -instance (DecodeJson a) => DecodeJson (TestRecord a) where +instance (DecodeJson a, DecodeJsonField a) => DecodeJson (TestRecord a) where decodeJson = genericDecodeAeson Argonaut.defaultOptions derive instance Generic (TestRecord a) _ @@ -163,11 +163,11 @@ newtype TestNewtype = TestNewtype (TestRecord Boolean) derive instance Eq TestNewtype +derive instance Ord TestNewtype + instance Show TestNewtype where show a = genericShow a -derive instance Ord TestNewtype - instance EncodeJson TestNewtype where encodeJson = genericEncodeAeson Argonaut.defaultOptions @@ -184,11 +184,11 @@ newtype TestNewtypeRecord = TestNewtypeRecord { unTestNewtypeRecord :: TestNewty derive instance Eq TestNewtypeRecord +derive instance Ord TestNewtypeRecord + instance Show TestNewtypeRecord where show a = genericShow a -derive instance Ord TestNewtypeRecord - instance EncodeJson TestNewtypeRecord where encodeJson = genericEncodeAeson Argonaut.defaultOptions @@ -213,11 +213,11 @@ data TestMultiInlineRecords derive instance Eq TestMultiInlineRecords +derive instance Ord TestMultiInlineRecords + instance Show TestMultiInlineRecords where show a = genericShow a -derive instance Ord TestMultiInlineRecords - instance EncodeJson TestMultiInlineRecords where encodeJson = genericEncodeAeson Argonaut.defaultOptions @@ -232,11 +232,11 @@ data TestTwoFields = TestTwoFields Boolean Int derive instance Eq TestTwoFields +derive instance Ord TestTwoFields + instance Show TestTwoFields where show a = genericShow a -derive instance Ord TestTwoFields - instance EncodeJson TestTwoFields where encodeJson = genericEncodeAeson Argonaut.defaultOptions @@ -258,11 +258,11 @@ data TestEnum derive instance Eq TestEnum +derive instance Ord TestEnum + instance Show TestEnum where show a = genericShow a -derive instance Ord TestEnum - instance EncodeJson TestEnum where encodeJson = genericEncodeAeson Argonaut.defaultOptions @@ -285,11 +285,11 @@ data MyUnit = U derive instance Eq MyUnit +derive instance Ord MyUnit + instance Show MyUnit where show a = genericShow a -derive instance Ord MyUnit - instance EncodeJson MyUnit where encodeJson = genericEncodeAeson Argonaut.defaultOptions From 974d7db00a49d3398a53dafc39e65de353ec0ebd Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 30 Sep 2023 16:55:17 -0700 Subject: [PATCH 065/111] delete unused `CodeGenSwitches` `SumTypes` replace `CodeGenSwitches` --- example/app/GeneratePurescript.hs | 1 - purescript-bridge.cabal | 1 - src/Language/PureScript/Bridge.hs | 4 -- .../PureScript/Bridge/CodeGenSwitches.hs | 63 ------------------- src/Language/PureScript/Bridge/Printer.hs | 35 +++-------- test/RoundTrip/Spec.hs | 7 +-- test/RoundTrip/Types.hs | 4 +- test/Spec.hs | 1 - test/TestData.hs | 1 - 9 files changed, 13 insertions(+), 104 deletions(-) delete mode 100644 src/Language/PureScript/Bridge/CodeGenSwitches.hs diff --git a/example/app/GeneratePurescript.hs b/example/app/GeneratePurescript.hs index 4d6dc2bd..6ad65998 100644 --- a/example/app/GeneratePurescript.hs +++ b/example/app/GeneratePurescript.hs @@ -3,7 +3,6 @@ module Main where import Control.Lens import Data.Text (pack) import Language.PureScript.Bridge -import Language.PureScript.Bridge.CodeGenSwitches (ForeignOptions (ForeignOptions)) import qualified MyLib import Types diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index c25a759c..dfed73b4 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -17,7 +17,6 @@ source-repository head library exposed-modules: Language.PureScript.Bridge - , Language.PureScript.Bridge.CodeGenSwitches , Language.PureScript.Bridge.Builder , Language.PureScript.Bridge.Primitives , Language.PureScript.Bridge.Printer diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index bcc90072..e744f670 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -10,9 +10,6 @@ module Language.PureScript.Bridge , writePSTypes , writePSTypesWith , writePSTypesWithNamespace - , defaultSwitch - , noLenses - , genLenses ) where import Control.Applicative @@ -21,7 +18,6 @@ import qualified Data.Map as M import qualified Data.Set as Set import qualified Data.Text.IO as T import Language.PureScript.Bridge.Builder as Bridge -import Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.Primitives as Bridge import Language.PureScript.Bridge.Printer as Bridge import Language.PureScript.Bridge.SumType as Bridge diff --git a/src/Language/PureScript/Bridge/CodeGenSwitches.hs b/src/Language/PureScript/Bridge/CodeGenSwitches.hs deleted file mode 100644 index 919af835..00000000 --- a/src/Language/PureScript/Bridge/CodeGenSwitches.hs +++ /dev/null @@ -1,63 +0,0 @@ --- | General switches for the code generation, such as generating profunctor-lenses or not -module Language.PureScript.Bridge.CodeGenSwitches - ( Settings (..) - , ForeignOptions (..) - , defaultSettings - , Switch - , getSettings - , defaultSwitch - , noLenses - , genLenses - , noArgonautCodecs - , genArgonautCodecs - ) where - -import Data.Monoid (Endo (..)) - --- | General settings for code generation -data Settings = Settings - { generateLenses :: Bool - -- ^ use purescript-profunctor-lens for generated PS-types? - , generateArgonautCodecs :: Bool - -- ^ generate Data.Argonaut.Decode.Class EncodeJson and DecodeJson instances - } - deriving (Eq, Show) - -data ForeignOptions = ForeignOptions - { unwrapSingleConstructors :: Bool - , unwrapSingleArguments :: Bool - } - deriving (Eq, Show) - --- | Settings to generate Lenses -defaultSettings :: Settings -defaultSettings = Settings True True - --- | you can `mappend` switches to control the code generation -type Switch = Endo Settings - --- | Translate switches into settings -getSettings :: Switch -> Settings -getSettings switch = appEndo switch defaultSettings - --- | Default switches include code generation for lenses -defaultSwitch :: Switch -defaultSwitch = mempty - --- | Switch off the generation of profunctor-lenses -noLenses :: Switch -noLenses = Endo $ \settings -> settings {generateLenses = False} - --- | Switch off the generation of argonaut-codecs -noArgonautCodecs :: Switch -noArgonautCodecs = Endo $ \settings -> - settings {generateArgonautCodecs = False} - --- | Switch on the generation of profunctor-lenses -genLenses :: Switch -genLenses = Endo $ \settings -> settings {generateLenses = True} - -genArgonautCodecs :: Switch -genArgonautCodecs = Endo $ \settings -> - settings {generateArgonautCodecs = True} - diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index b4e28e0c..0c79478d 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -25,7 +25,6 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches import Language.PureScript.Bridge.PSTypes (psUnit) import Language.PureScript.Bridge.SumType (CustomInstance (..), DataConstructor (..), @@ -192,22 +191,6 @@ moduleToText m = allImports = Map.elems $ psImportLines m dashes = textStrict (T.replicate 80 "-") -genericsImports :: Switches.Settings -> [ImportLine] -genericsImports _ = - [ImportLine "Data.Generic.Rep" Nothing $ Set.singleton "class Generic"] - -lensImports :: Switches.Settings -> [ImportLine] -lensImports settings - | Switches.generateLenses settings = - [ ImportLine "Data.Maybe" Nothing $ Set.fromList ["Maybe(..)"] - , ImportLine "Data.Lens" Nothing $ - Set.fromList ["Iso'", "Prism'", "Lens'", "iso", "prism'", "lens"] - , ImportLine "Data.Lens.Record" Nothing $ Set.fromList ["prop"] - , ImportLine "Data.Lens.Iso.Newtype" Nothing $ Set.fromList ["_Newtype"] - , ImportLine "Type.Proxy" Nothing $ Set.fromList ["Proxy(Proxy)"] - ] - | otherwise = - [ImportLine "Data.Maybe" Nothing $ Set.fromList ["Maybe(..)"]] -- importLineToText :: ImportLine -> Text -- importLineToText = \case @@ -253,16 +236,6 @@ lensImports settings qualifiedImportToText :: Text -> Text -> Doc qualifiedImportToText m q = hsep ["import", textStrict m, "as", textStrict q] -foreignOptionsToPurescript :: Maybe Switches.ForeignOptions -> Text -foreignOptionsToPurescript = \case - Nothing -> mempty - Just (Switches.ForeignOptions {..}) -> - " { unwrapSingleConstructors = " - <> (T.toLower . T.pack . show $ unwrapSingleConstructors) - <> " , unwrapSingleArguments = " - <> (T.toLower . T.pack . show $ unwrapSingleArguments) - <> " }" - importLineToText :: ImportLine -> Doc importLineToText l = case importAlias l of @@ -362,6 +335,14 @@ instances st@(SumType t _ is) = go <$> is [ "succ = genericSucc" , "pred = genericPred" ] + + -- TODO + -- render ForeignObject instances with these configuration + -- " { unwrapSingleConstructors = " + -- <> (T.toLower . T.pack . show $ unwrapSingleConstructors) + -- <> " , unwrapSingleArguments = " + -- <> (T.toLower . T.pack . show $ unwrapSingleArguments) + -- <> " }" go (ForeignObject _ _) = go Generic -- This relies on `purescript-argonaut-aeson-generic`: -- https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 29be83e0..167f985b 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -17,10 +17,9 @@ import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, argonautJson, buildBridge, - defaultBridge, defaultSwitch, - equal, functor, genericShow, - mkSumType, order, writePSTypes, - writePSTypesWith) + defaultBridge, equal, functor, + genericShow, mkSumType, order, + writePSTypes, writePSTypesWith) import Language.PureScript.Bridge.TypeParameters (A) import RoundTrip.Types import System.Directory (removeDirectoryRecursive, removeFile, diff --git a/test/RoundTrip/Types.hs b/test/RoundTrip/Types.hs index 24c99efa..ba18fa4d 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTrip/Types.hs @@ -15,8 +15,8 @@ import Data.Text (Text) import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, buildBridge, defaultBridge, - defaultSwitch, mkSumType, - writePSTypes, writePSTypesWith) + mkSumType, writePSTypes, + writePSTypesWith) import Language.PureScript.Bridge.TypeParameters (A) import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) diff --git a/test/Spec.hs b/test/Spec.hs index a5b1c73a..475bb455 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -15,7 +15,6 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Word (Word, Word64) import Language.PureScript.Bridge -import Language.PureScript.Bridge.CodeGenSwitches import Language.PureScript.Bridge.TypeParameters import RoundTrip.Spec (roundtripSpec) import Test.Hspec (Spec, describe, hspec, it) diff --git a/test/TestData.hs b/test/TestData.hs index 336123f8..b9f3f8fd 100644 --- a/test/TestData.hs +++ b/test/TestData.hs @@ -16,7 +16,6 @@ import Data.Text (Text) import Data.Typeable import GHC.Generics (Generic) import Language.PureScript.Bridge -import Language.PureScript.Bridge.CodeGenSwitches (defaultSettings) import Language.PureScript.Bridge.PSTypes -- Check that examples compile: From 0d5edfe6d7da3df5699c95e261f1698fd456975c Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 30 Sep 2023 17:02:45 -0700 Subject: [PATCH 066/111] fix LSP server for RoundTrip test --- spago.dhall | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/spago.dhall b/spago.dhall index 23a5c262..b0678014 100644 --- a/spago.dhall +++ b/spago.dhall @@ -19,5 +19,9 @@ , "prelude" ] , packages = ./example/packages.dhall -, sources = [ "example/src/**/*.purs", "example/test/**/*.purs" ] +, sources = + [ "example/src/**/*.purs" + , "example/test/**/*.purs" + , "test/RoundTrip/app/src/RoundTrip/*.purs" + ] } From 88f1e315ec6979d3394d562f403a277224e6ff40 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 30 Sep 2023 17:12:59 -0700 Subject: [PATCH 067/111] fix rendered `EncodeJson` and `DecodeJson` instances `RoundTrip` builds successfully now: ``` cabal test --test-options="--match \"/writePSTypesWith/should be buildable/\"" ``` --- example/spago.dhall | 13 +++--- example/src/Types.purs | 15 +++---- src/Language/PureScript/Bridge/Printer.hs | 4 +- src/Language/PureScript/Bridge/SumType.hs | 2 + test/RoundTrip/app/spago.dhall | 4 +- test/RoundTrip/app/src/RoundTrip/Types.purs | 45 +++++++++++---------- 6 files changed, 43 insertions(+), 40 deletions(-) diff --git a/example/spago.dhall b/example/spago.dhall index 9687eb80..cab1af2e 100644 --- a/example/spago.dhall +++ b/example/spago.dhall @@ -1,23 +1,24 @@ { name = "purescript-bridge-example" , dependencies = - [ "console" - , "effect" - , "foreign-generic" - , "profunctor-lenses" - , "aff" + [ "aff" , "affjax" , "affjax-web" , "argonaut" , "argonaut-aeson-generic" - , "ordered-collections" , "argonaut-codecs" , "argonaut-generic" + , "console" + , "control" + , "effect" , "either" , "foldable-traversable" + , "foreign-generic" , "foreign-object" , "maybe" , "newtype" + , "ordered-collections" , "prelude" + , "profunctor-lenses" ] , packages = ./packages.dhall , sources = [ "src/**/*.purs", "test/**/*.purs" ] diff --git a/example/src/Types.purs b/example/src/Types.purs index 7ac8268b..96dde7b0 100644 --- a/example/src/Types.purs +++ b/example/src/Types.purs @@ -3,6 +3,7 @@ module Types where import Prelude +import Control.Lazy (defer) import Data.Argonaut.Aeson.Decode.Generic (genericDecodeAeson) import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson) import Data.Argonaut.Aeson.Options (defaultOptions) as Argonaut @@ -27,10 +28,10 @@ instance Show Baz where show a = genericShow a instance EncodeJson Baz where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson Baz where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic Baz _ @@ -60,10 +61,10 @@ instance Show Foo where show a = genericShow a instance EncodeJson Foo where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson Foo where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic Foo _ @@ -99,10 +100,10 @@ instance (Show a) => Show (Bar a) where show a = genericShow a instance (EncodeJson a) => EncodeJson (Bar a) where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions -instance (DecodeJson a) => DecodeJson (Bar a) where - decodeJson = genericDecodeAeson Argonaut.defaultOptions +instance (DecodeJson a, DecodeJsonField a) => DecodeJson (Bar a) where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic (Bar a) _ diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 0c79478d..895c6f07 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -350,14 +350,14 @@ instances st@(SumType t _ is) = go <$> is mkInstance (mkType "EncodeJson" [t]) encodeJsonConstraints - ["encodeJson = genericEncodeAeson Argonaut.defaultOptions"] + ["encodeJson = defer \\_ -> genericEncodeAeson Argonaut.defaultOptions"] -- This relies on `purescript-argonaut-aeson-generic`: -- https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic go DecodeJson = mkInstance (mkType "DecodeJson" [t]) decodeJsonConstraints - ["decodeJson = genericDecodeAeson Argonaut.defaultOptions"] + ["decodeJson = defer \\_ -> genericDecodeAeson Argonaut.defaultOptions"] {-| This relies on unpublished Purescript library `purescript-bridge-json-helpers`: https://github.com/input-output-hk/purescript-bridge-json-helpers diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 140bff6d..d318cca6 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -371,6 +371,7 @@ instanceToImportLines EncodeJson = , ImportLine "Data.Argonaut.Encode.Class" (Just "Argonaut") mempty , ImportLine "Data.Argonaut.Encode.Class" Nothing $ Set.fromList ["class EncodeJson", "encodeJson"] + , ImportLine "Control.Lazy" Nothing $ Set.fromList ["defer"] ] instanceToImportLines DecodeJson = importsFromList @@ -381,6 +382,7 @@ instanceToImportLines DecodeJson = , ImportLine "Data.Argonaut.Decode.Class" (Just "Argonaut") mempty , ImportLine "Data.Argonaut.Decode.Class" Nothing $ Set.fromList ["class DecodeJson", "class DecodeJsonField", "decodeJson"] + , ImportLine "Control.Lazy" Nothing $ Set.fromList ["defer"] ] {-| This relies on unpublished Purescript library `purescript-bridge-json-helpers`: diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index 62829e4f..f25a533d 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -1,7 +1,6 @@ { name = "my-project" , dependencies = - [ "argonaut" - , "foreign-object" + [ "foreign-object" , "argonaut-aeson-generic" , "argonaut-codecs" , "argonaut-core" @@ -10,7 +9,6 @@ , "effect" , "either" , "enums" - , "json-helpers" , "maybe" , "newtype" , "node-readline" diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 8dcd788f..288eedfe 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -3,6 +3,7 @@ module RoundTrip.Types where import Prelude +import Control.Lazy (defer) import Data.Argonaut.Aeson.Decode.Generic (genericDecodeAeson) import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson) import Data.Argonaut.Aeson.Options (defaultOptions) as Argonaut @@ -37,10 +38,10 @@ instance Show TestData where show a = genericShow a instance EncodeJson TestData where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson TestData where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic TestData _ @@ -82,10 +83,10 @@ instance Show TestSum where show a = genericShow a instance EncodeJson TestSum where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson TestSum where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic TestSum _ @@ -103,10 +104,10 @@ instance Show TestRecursiveA where show a = genericShow a instance EncodeJson TestRecursiveA where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson TestRecursiveA where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic TestRecursiveA _ @@ -122,10 +123,10 @@ instance Show TestRecursiveB where show a = genericShow a instance EncodeJson TestRecursiveB where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson TestRecursiveB where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic TestRecursiveB _ @@ -148,10 +149,10 @@ instance (Show a) => Show (TestRecord a) where show a = genericShow a instance (EncodeJson a) => EncodeJson (TestRecord a) where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance (DecodeJson a, DecodeJsonField a) => DecodeJson (TestRecord a) where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic (TestRecord a) _ @@ -169,10 +170,10 @@ instance Show TestNewtype where show a = genericShow a instance EncodeJson TestNewtype where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson TestNewtype where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic TestNewtype _ @@ -190,10 +191,10 @@ instance Show TestNewtypeRecord where show a = genericShow a instance EncodeJson TestNewtypeRecord where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson TestNewtypeRecord where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic TestNewtypeRecord _ @@ -219,10 +220,10 @@ instance Show TestMultiInlineRecords where show a = genericShow a instance EncodeJson TestMultiInlineRecords where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson TestMultiInlineRecords where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic TestMultiInlineRecords _ @@ -238,10 +239,10 @@ instance Show TestTwoFields where show a = genericShow a instance EncodeJson TestTwoFields where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson TestTwoFields where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic TestTwoFields _ @@ -264,10 +265,10 @@ instance Show TestEnum where show a = genericShow a instance EncodeJson TestEnum where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson TestEnum where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic TestEnum _ @@ -291,10 +292,10 @@ instance Show MyUnit where show a = genericShow a instance EncodeJson MyUnit where - encodeJson = genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions instance DecodeJson MyUnit where - decodeJson = genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions derive instance Generic MyUnit _ From d1a613b2c933c942d3ca8eecb0395b7698e18581 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 30 Sep 2023 23:10:45 -0700 Subject: [PATCH 068/111] extend example to show failing case ``` Error decoding Foo: An error occurred while decoding a JSON value: Under 'When decoding a Foo': Under '"tag" property is missing': No value was found. ``` --- example/packages.dhall | 4 +- example/src/Main.purs | 11 ++- example/src/MyLib.hs | 5 +- example/src/Types.hs | 24 ++++-- example/src/Types.purs | 82 ++++++++++++++++++++- purescript-bridge.cabal | 2 +- src/Language/PureScript/Bridge/Printer.hs | 3 +- src/Language/PureScript/Bridge/SumType.hs | 8 ++ test/RoundTrip/Spec.hs | 26 ++++--- test/RoundTrip/app/packages.dhall | 4 +- test/RoundTrip/app/spago.dhall | 4 +- test/RoundTrip/app/src/Main.purs | 5 +- test/RoundTrip/app/src/RoundTrip/Types.purs | 2 +- 13 files changed, 142 insertions(+), 38 deletions(-) diff --git a/example/packages.dhall b/example/packages.dhall index 90bb1736..04d53931 100644 --- a/example/packages.dhall +++ b/example/packages.dhall @@ -14,8 +14,8 @@ let additions = , "test-unit" ] , repo = - "https://github.com/coot/purescript-argonaut-aeson-generic.git" - , version = "v0.4.1" + "https://github.com/peterbecich/purescript-argonaut-aeson-generic.git" + , version = "e22b1b9046aef15d6441ea90870dfbfa455a70fb" } , foreign-generic = { dependencies = diff --git a/example/src/Main.purs b/example/src/Main.purs index 1f1d71f0..77e13d4e 100644 --- a/example/src/Main.purs +++ b/example/src/Main.purs @@ -22,7 +22,7 @@ import Types (Foo, fooMessage, fooNumber, fooList) import Data.Argonaut.Decode.Error (JsonDecodeError) import Data.Argonaut.Decode.Generic (genericDecodeJson) import Data.Argonaut.Encode.Generic (genericEncodeJson) -import Types (Foo, fooMessage, fooNumber, fooList, fooMap) +import Types (Foo, fooMessage, fooNumber, fooList, fooMap, fooTestSum) import Data.Map as Map import Foreign.Object as Object @@ -44,11 +44,10 @@ main = log "Hello, Purescript!" *> launchAff_ do for_ efoo \foo -> do liftEffect do log $ "Foo message: " <> (view fooMessage foo) - <> "\t Foo number: " <> (show $ view fooNumber foo) - <> "\t Foo list length: " - <> (show (length $ view fooList foo :: Int)) - <> "\t Foo map size: " - <> (show (Object.size $ view fooMap foo :: Int)) + log $ "Foo number: " <> (show $ view fooNumber foo) + log $ "Foo list length: " <> (show (length $ view fooList foo :: Int)) + log $ "Foo map size: " <> (show (Object.size $ view fooMap foo :: Int)) + log $ "Foo test sum: " <> show (view fooTestSum foo) let -- modify the Foo received and send it back foo' = set fooMessage "Hola" diff --git a/example/src/MyLib.hs b/example/src/MyLib.hs index 7efc91db..91ddebbe 100644 --- a/example/src/MyLib.hs +++ b/example/src/MyLib.hs @@ -20,7 +20,8 @@ import Servant import System.Environment (lookupEnv) import Types (Baz (Baz), Foo (Foo), fooList, fooMap, fooMessage, - fooNumber) + fooNumber, TestData(..), TestSum(..)) +import qualified Types type FooServer = "foo" :> (Get '[JSON] Foo @@ -34,6 +35,8 @@ foo = Foo [10..20] (Map.fromList [(pack "foo", 2), (pack "bar", 3), (pack "baz", 3)]) (Baz $ pack "hello") + -- (Types.Maybe (Just (Int 5))) + (Types.Number 1.23) fooServer :: Server FooServer fooServer = getFoo :<|> postFoo diff --git a/example/src/Types.hs b/example/src/Types.hs index f01c171b..3ea62b15 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -27,8 +27,18 @@ data Baz = Baz makeLenses ''Baz -bazProxy :: Proxy Baz -bazProxy = Proxy +data TestSum + = Nullary + | Bool Bool + | Int Int + | Number Double + deriving (Eq, Generic, Ord, Show, FromJSON, ToJSON) + +data TestData + = Maybe (Maybe TestSum) + | Either (Either (Maybe Int) (Maybe Bool)) + deriving (Eq, Generic, Ord, Show, FromJSON, ToJSON) + data Foo = Foo { _fooMessage :: Text @@ -36,23 +46,19 @@ data Foo = Foo , _fooList :: [Int] , _fooMap :: Map.Map Text Int , _fooBaz :: Baz + -- , _fooTestData :: TestData + , _fooTestSum :: TestSum } deriving (FromJSON, Generic, ToJSON) makeLenses ''Foo -fooProxy :: Proxy Foo -fooProxy = Proxy - -- TODO newtype data Bar a = Bar a deriving (FromJSON, Generic, Show, ToJSON, Typeable) makeLenses ''Bar -barProxy :: Proxy Bar -barProxy = Proxy - myBridge :: BridgePart myBridge = defaultBridge @@ -63,4 +69,6 @@ myTypes = [ additionalInstances $ mkSumType @Baz , additionalInstances $ mkSumType @Foo , additionalInstances $ mkSumType @(Bar A) + , additionalInstances $ mkSumType @TestSum + , additionalInstances $ mkSumType @TestData ] diff --git a/example/src/Types.purs b/example/src/Types.purs index 96dde7b0..a1dccbb1 100644 --- a/example/src/Types.purs +++ b/example/src/Types.purs @@ -11,10 +11,12 @@ import Data.Argonaut.Decode (class DecodeJson) import Data.Argonaut.Decode.Class (class DecodeJson, class DecodeJsonField, decodeJson) import Data.Argonaut.Encode (class EncodeJson) import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) +import Data.Either (Either) import Data.Generic.Rep (class Generic) import Data.Lens (Iso', Lens', Prism', iso, lens, prism') import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) +import Data.Maybe (Maybe(..)) import Data.Newtype (class Newtype) import Data.Show.Generic (genericShow) import Foreign.Object (Object) @@ -53,6 +55,7 @@ newtype Foo = Foo , _fooList :: Array Int , _fooMap :: Object Int , _fooBaz :: Baz + , _fooTestSum :: TestSum } @@ -72,7 +75,7 @@ derive instance Newtype Foo _ -------------------------------------------------------------------------------- -_Foo :: Iso' Foo {_fooMessage :: String, _fooNumber :: Int, _fooList :: Array Int, _fooMap :: Object Int, _fooBaz :: Baz} +_Foo :: Iso' Foo {_fooMessage :: String, _fooNumber :: Int, _fooList :: Array Int, _fooMap :: Object Int, _fooBaz :: Baz, _fooTestSum :: TestSum} _Foo = _Newtype fooMessage :: Lens' Foo String @@ -90,6 +93,9 @@ fooMap = _Newtype <<< prop (Proxy :: _"_fooMap") fooBaz :: Lens' Foo Baz fooBaz = _Newtype <<< prop (Proxy :: _"_fooBaz") +fooTestSum :: Lens' Foo TestSum +fooTestSum = _Newtype <<< prop (Proxy :: _"_fooTestSum") + -------------------------------------------------------------------------------- newtype Bar a = Bar a @@ -113,3 +119,77 @@ derive instance Newtype (Bar a) _ _Bar :: forall a. Iso' (Bar a) a _Bar = _Newtype + +-------------------------------------------------------------------------------- + +data TestSum + = Nullary + | Bool Boolean + | Int Int + | Number Number + + + +instance Show TestSum where + show a = genericShow a + +instance EncodeJson TestSum where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestSum where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestSum _ + +-------------------------------------------------------------------------------- + +_Nullary :: Prism' TestSum Unit +_Nullary = prism' (const Nullary) case _ of + Nullary -> Just unit + _ -> Nothing + +_Bool :: Prism' TestSum Boolean +_Bool = prism' Bool case _ of + (Bool a) -> Just a + _ -> Nothing + +_Int :: Prism' TestSum Int +_Int = prism' Int case _ of + (Int a) -> Just a + _ -> Nothing + +_Number :: Prism' TestSum Number +_Number = prism' Number case _ of + (Number a) -> Just a + _ -> Nothing + +-------------------------------------------------------------------------------- + +data TestData + = Maybe (Maybe TestSum) + | Either (Either (Maybe Int) (Maybe Boolean)) + + + +instance Show TestData where + show a = genericShow a + +instance EncodeJson TestData where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestData where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestData _ + +-------------------------------------------------------------------------------- + +_Maybe :: Prism' TestData (Maybe TestSum) +_Maybe = prism' Maybe case _ of + (Maybe a) -> Just a + _ -> Nothing + +_Either :: Prism' TestData (Either (Maybe Int) (Maybe Boolean)) +_Either = prism' Either case _ of + (Either a) -> Just a + _ -> Nothing diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index dfed73b4..c08aba90 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -51,7 +51,7 @@ Test-Suite tests , base , containers , directory - , hspec + , hspec >= 2.11 , hspec-expectations-pretty-diff , process , purescript-bridge diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 895c6f07..65d0014f 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -39,6 +39,7 @@ import Language.PureScript.Bridge.SumType (CustomInstance (..), _recLabel, getUsedTypes, importsFromList, instanceToImportLines, + baselineImports, nootype, recLabel, recValue, sigConstructor) import Language.PureScript.Bridge.TypeInfo (Language (PureScript), @@ -107,7 +108,7 @@ sumTypeToModule packageName st@(SumType t _ is) = dropSelf $ unionImportLines (typesToImportLines (getUsedTypes st)) - (instancesToImportLines is) + (instancesToImportLines is <> baselineImports) , psQualifiedImports = instancesToQualifiedImports is , psTypes = [st] } diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index d318cca6..5c23da4d 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -44,6 +44,7 @@ module Language.PureScript.Bridge.SumType , PSInstance , importsFromList , instanceToImportLines + , baselineImports , nootype , lenses , prisms @@ -359,6 +360,13 @@ implementationToTypes :: InstanceImplementation lang -> [TypeInfo lang] implementationToTypes (Explicit members) = concatMap _memberDependencies members implementationToTypes _ = [] +baselineImports :: ImportLines +baselineImports = importsFromList + [ ImportLine "Data.Maybe" Nothing $ Set.singleton "Maybe(..)" + , ImportLine "Data.Newtype" Nothing $ Set.singleton "class Newtype" + ] + + instanceToImportLines :: PSInstance -> ImportLines instanceToImportLines GenericShow = importsFromList [ImportLine "Data.Show.Generic" Nothing $ Set.singleton "genericShow"] diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 167f985b..fb07444b 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -36,7 +36,7 @@ import Test.Hspec (Spec, around, aroundAll_, around_, describe, it) import Test.Hspec.Expectations.Pretty (shouldBe) import Test.Hspec.QuickCheck (prop) import Test.HUnit (assertBool, assertEqual) -import Test.QuickCheck (noShrinking, once, verbose, withMaxSuccess) +import Test.QuickCheck (verbose) import Test.QuickCheck.Property (Testable (property)) myBridge :: BridgePart @@ -75,15 +75,21 @@ roundtripSpec = do assertBool stderr $ not $ "[warn]" `isInfixOf` stderr around withApp $ it "should produce aeson-compatible argonaut instances" $ - \(hin, hout, herr, hproc) -> - property $ - \testData -> do - let input = toString $ encode @TestData testData - hPutStrLn hin input - err <- hGetLine herr - output <- hGetLine hout - assertEqual input "" err - assertEqual output (Right testData) $ eitherDecode @TestData $ fromString output + \(hin, hout, herr, hproc) -> verbose . property $ \testData -> do + let input = toString $ encode @TestData testData + hPutStrLn hin input + err <- hGetLine herr + output <- hGetLine hout + + -- empty string signifies no error from Purescript process + assertEqual ("Error from Purescript, parsing: " <> input) "" err + + -- compare the value parsed by Purescipt to the + -- source value in Haskell + assertEqual ("Mismatch between value sent to Purescript and value returned: " <> output) (Right testData) + . eitherDecode @TestData + $ fromString output + where withApp = bracket runApp killApp runApp = do diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTrip/app/packages.dhall index 7d229ad8..a82ba358 100644 --- a/test/RoundTrip/app/packages.dhall +++ b/test/RoundTrip/app/packages.dhall @@ -14,8 +14,8 @@ let additions = , "test-unit" ] , repo = - "https://github.com/coot/purescript-argonaut-aeson-generic.git" - , version = "v0.4.1" + "https://github.com/peterbecich/purescript-argonaut-aeson-generic.git" + , version = "e22b1b9046aef15d6441ea90870dfbfa455a70fb" } , foreign-generic = { dependencies = diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index f25a533d..051ff196 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -1,7 +1,6 @@ { name = "my-project" , dependencies = - [ "foreign-object" - , "argonaut-aeson-generic" + [ "argonaut-aeson-generic" , "argonaut-codecs" , "argonaut-core" , "console" @@ -9,6 +8,7 @@ , "effect" , "either" , "enums" + , "foreign-object" , "maybe" , "newtype" , "node-readline" diff --git a/test/RoundTrip/app/src/Main.purs b/test/RoundTrip/app/src/Main.purs index 52c14eba..9e8e22e0 100644 --- a/test/RoundTrip/app/src/Main.purs +++ b/test/RoundTrip/app/src/Main.purs @@ -24,9 +24,8 @@ main = do parsed = decodeJson =<< parseJson input case parsed of Left err -> do - error $ "got " <> input - error $ printJsonDecodeError err - log "" + error $ input <> " " <> show err + log $ printJsonDecodeError err Right testData -> do error "" log $ stringify $ encodeJson testData diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 288eedfe..5753e421 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -18,7 +18,7 @@ import Data.Enum.Generic (genericPred, genericSucc) import Data.Generic.Rep (class Generic) import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) -import Data.Maybe (Maybe) +import Data.Maybe (Maybe(..)) import Data.Newtype (class Newtype) import Data.Set (Set) import Data.Show.Generic (genericShow) From 5933ef78281621810f6e06e6c1ec22a6a117e0d6 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 1 Oct 2023 10:19:58 -0700 Subject: [PATCH 069/111] fix printing of import list --- src/Language/PureScript/Bridge/Printer.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 65d0014f..2108ef56 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -239,11 +239,15 @@ qualifiedImportToText m q = hsep ["import", textStrict m, "as", textStrict q] importLineToText :: ImportLine -> Doc importLineToText l = - case importAlias l of + let + typeListDoc = if null typeList + then mempty + else encloseHsep lparen rparen comma typeList + in case importAlias l of Just alias -> - hsep ["import", textStrict $ importModule l, encloseHsep lparen rparen comma typeList, "as", textStrict alias] + hsep ["import", textStrict $ importModule l, typeListDoc, "as", textStrict alias] Nothing -> - hsep ["import", textStrict $ importModule l, encloseHsep lparen rparen comma typeList] + hsep ["import", textStrict $ importModule l, typeListDoc] where typeList = map (textStrict . last) From a2acbbb51d3f27b4f0292162657398300d1bba16 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 1 Oct 2023 11:20:44 -0700 Subject: [PATCH 070/111] fix printing of imports with/without aliases import lines with and without aliases should not be merged --- example/src/MyLib.hs | 2 +- example/src/Types.hs | 9 +++-- example/src/Types.purs | 8 +++- src/Language/PureScript/Bridge/Printer.hs | 23 ++++++----- src/Language/PureScript/Bridge/SumType.hs | 43 ++++++++++++++------- test/RoundTrip/Spec.hs | 2 +- test/RoundTrip/app/spago.dhall | 1 + test/RoundTrip/app/src/RoundTrip/Types.purs | 6 +++ 8 files changed, 61 insertions(+), 33 deletions(-) diff --git a/example/src/MyLib.hs b/example/src/MyLib.hs index 91ddebbe..e4a6752e 100644 --- a/example/src/MyLib.hs +++ b/example/src/MyLib.hs @@ -35,7 +35,7 @@ foo = Foo [10..20] (Map.fromList [(pack "foo", 2), (pack "bar", 3), (pack "baz", 3)]) (Baz $ pack "hello") - -- (Types.Maybe (Just (Int 5))) + (Types.Maybe (Just (Int 5))) (Types.Number 1.23) fooServer :: Server FooServer diff --git a/example/src/Types.hs b/example/src/Types.hs index 3ea62b15..f8850fad 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -17,7 +17,7 @@ import Data.Typeable import GHC.Generics import Language.PureScript.Bridge import Language.PureScript.Bridge.PSTypes -import qualified Language.PureScript.Bridge.SumType as SumType +import Language.PureScript.Bridge.SumType import Language.PureScript.Bridge.TypeParameters (A) data Baz = Baz @@ -46,7 +46,7 @@ data Foo = Foo , _fooList :: [Int] , _fooMap :: Map.Map Text Int , _fooBaz :: Baz - -- , _fooTestData :: TestData + , _fooTestData :: TestData , _fooTestSum :: TestSum } deriving (FromJSON, Generic, ToJSON) @@ -62,7 +62,10 @@ makeLenses ''Bar myBridge :: BridgePart myBridge = defaultBridge -additionalInstances = SumType.lenses . SumType.genericShow . SumType.argonautJson +additionalInstances = lenses + . genericShow + -- . jsonHelper + . argonautJson myTypes :: [SumType 'Haskell] myTypes = diff --git a/example/src/Types.purs b/example/src/Types.purs index a1dccbb1..1180aa27 100644 --- a/example/src/Types.purs +++ b/example/src/Types.purs @@ -9,8 +9,10 @@ import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson) import Data.Argonaut.Aeson.Options (defaultOptions) as Argonaut import Data.Argonaut.Decode (class DecodeJson) import Data.Argonaut.Decode.Class (class DecodeJson, class DecodeJsonField, decodeJson) +import Data.Argonaut.Decode.Class as Argonaut import Data.Argonaut.Encode (class EncodeJson) import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) +import Data.Argonaut.Encode.Class as Argonaut import Data.Either (Either) import Data.Generic.Rep (class Generic) import Data.Lens (Iso', Lens', Prism', iso, lens, prism') @@ -55,6 +57,7 @@ newtype Foo = Foo , _fooList :: Array Int , _fooMap :: Object Int , _fooBaz :: Baz + , _fooTestData :: TestData , _fooTestSum :: TestSum } @@ -75,7 +78,7 @@ derive instance Newtype Foo _ -------------------------------------------------------------------------------- -_Foo :: Iso' Foo {_fooMessage :: String, _fooNumber :: Int, _fooList :: Array Int, _fooMap :: Object Int, _fooBaz :: Baz, _fooTestSum :: TestSum} +_Foo :: Iso' Foo {_fooMessage :: String, _fooNumber :: Int, _fooList :: Array Int, _fooMap :: Object Int, _fooBaz :: Baz, _fooTestData :: TestData, _fooTestSum :: TestSum} _Foo = _Newtype fooMessage :: Lens' Foo String @@ -93,6 +96,9 @@ fooMap = _Newtype <<< prop (Proxy :: _"_fooMap") fooBaz :: Lens' Foo Baz fooBaz = _Newtype <<< prop (Proxy :: _"_fooBaz") +fooTestData :: Lens' Foo TestData +fooTestData = _Newtype <<< prop (Proxy :: _"_fooTestData") + fooTestSum :: Lens' Foo TestSum fooTestSum = _Newtype <<< prop (Proxy :: _"_fooTestSum") diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index 2108ef56..be25f431 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -96,27 +96,26 @@ unionModules m1 m2 = } sumTypeToModule :: Maybe PackageName -> SumType 'PureScript -> Modules -sumTypeToModule packageName st@(SumType t _ is) = +sumTypeToModule packageName sumType@(SumType typeInfo _ stInstances) = Map.singleton typedModuleName $ PSModule { psModuleName = psModuleName - , psImportLines = - dropEmpty $ - dropPrelude $ - dropPrim $ - dropSelf $ - unionImportLines - (typesToImportLines (getUsedTypes st)) - (instancesToImportLines is <> baselineImports) - , psQualifiedImports = instancesToQualifiedImports is - , psTypes = [st] + , psImportLines = dropEmpty + . dropPrelude + . dropPrim + . dropSelf + $ unionImportLines + (typesToImportLines (getUsedTypes sumType)) + (instancesToImportLines stInstances <> baselineImports) + , psQualifiedImports = instancesToQualifiedImports stInstances + , psTypes = [sumType] } where dropEmpty = Map.delete "" dropPrelude = Map.delete "Prelude" dropPrim = Map.delete "Prim" - typedModuleName = _typeModule t + typedModuleName = _typeModule typeInfo dropSelf = Map.delete typedModuleName psModuleName = fromMaybe typedModuleName do PackageName pn <- packageName diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 5c23da4d..1b54c9d8 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -64,7 +64,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (maybeToList) +import Data.Maybe (maybeToList, fromMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -406,8 +406,9 @@ instanceToImportLines EncodeJsonHelper = , ImportLine "Data.Newtype" Nothing $ Set.singleton "unwrap" , ImportLine "Data.Tuple.Nested" Nothing $ Set.singleton "(/\\)" , ImportLine "Data.Argonaut.Encode.Aeson" (Just "E") mempty - , ImportLine "Data.Map" (Just "Map") mempty + , ImportLine "Data.Map" Nothing mempty ] + <> instanceToImportLines EncodeJson {-| This relies on unpublished Purescript library `purescript-bridge-json-helpers`: https://github.com/input-output-hk/purescript-bridge-json-helpers @@ -423,6 +424,7 @@ instanceToImportLines DecodeJsonHelper = , ImportLine "Data.Argonaut.Decode.Aeson" (Just "D") mempty , ImportLine "Data.Map" (Just "Map") mempty ] + <> instanceToImportLines DecodeJson instanceToImportLines (ForeignObject _ _) = importsFromList [ ImportLine "Foreign.Class" Nothing @@ -442,14 +444,8 @@ instanceToImportLines (Custom CustomInstance {_customImplementation = Explicit m importsFromList $ concatMap (Map.elems . _memberImportLines) members instanceToImportLines Lenses = importsFromList - [ ImportLine "Data.Lens" Nothing $ Set.fromList - [ "Iso'" - , "Lens'" - , "Prism'" - , "iso" - , "lens" - , "prism'" - ] + [ ImportLine "Data.Lens" Nothing + $ Set.fromList [ "Iso'", "Lens'", "Prism'", "iso", "lens", "prism'" ] ] instanceToImportLines Prisms = instanceToImportLines Prisms instanceToImportLines (Custom _) = mempty @@ -466,12 +462,29 @@ instanceToImportLines Eq = mempty instanceToImportLines Eq1 = mempty instanceToImportLines Ord = mempty +{-| +This function merges import lines which import the same module. + +The exception are aliased imports. For example, these two import lines +will not be merged: +import Data.Argonaut.Decode.Aeson ((), (), ()) +import Data.Argonaut.Decode.Aeson as D +-} importsFromList :: [ImportLine] -> Map Text ImportLine -importsFromList ls = - let pairs = zip (importModule <$> ls) ls - merge a b = - ImportLine (importModule a) Nothing (importTypes a `Set.union` importTypes b) - in Map.fromListWith merge pairs +importsFromList unmergedLines = let + filteredLines :: [ImportLine] + filteredLines = filter (not . T.null . importModule) unmergedLines + + makeKey :: ImportLine -> Text + makeKey (ImportLine md mAlias _) = case mAlias of + Just alias -> md <> " " <> alias + Nothing -> md + pairs :: [(Text, ImportLine)] + pairs = zip (fmap makeKey filteredLines) filteredLines + merge :: ImportLine -> ImportLine -> ImportLine + merge a b = + ImportLine (importModule a) (importAlias a) (importTypes a `Set.union` importTypes b) + in Map.fromListWith merge pairs -- Lenses: makeLenses ''DataConstructor diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index fb07444b..7262245e 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -18,7 +18,7 @@ import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, argonautJson, buildBridge, defaultBridge, equal, functor, - genericShow, mkSumType, order, + genericShow, mkSumType, order, jsonHelper, writePSTypes, writePSTypesWith) import Language.PureScript.Bridge.TypeParameters (A) import RoundTrip.Types diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index 051ff196..9a73c6f1 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -16,6 +16,7 @@ , "prelude" , "profunctor-lenses" , "tuples" + , "json-helpers" ] , packages = ./packages.dhall , sources = [ "src/**/*.purs" ] diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index 5753e421..c2ffbb6c 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -3,14 +3,17 @@ module RoundTrip.Types where import Prelude +import (a) import Control.Lazy (defer) import Data.Argonaut.Aeson.Decode.Generic (genericDecodeAeson) import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson) import Data.Argonaut.Aeson.Options (defaultOptions) as Argonaut import Data.Argonaut.Decode (class DecodeJson) import Data.Argonaut.Decode.Class (class DecodeJson, class DecodeJsonField, decodeJson) +import Data.Argonaut.Decode.Class as Argonaut import Data.Argonaut.Encode (class EncodeJson) import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) +import Data.Argonaut.Encode.Class as Argonaut import Data.Bounded.Generic (genericBottom, genericTop) import Data.Either (Either) import Data.Enum (class Enum) @@ -24,6 +27,9 @@ import Data.Set (Set) import Data.Show.Generic (genericShow) import Data.Tuple (Tuple) import Foreign.Object (Object) +import Prelude (Unit, class Bounded, class Eq, class Functor, class Ord, class Show) +import Prim (Array, Boolean, Int, Number, String) +import RoundTrip.Types (MyUnit, TestEnum, TestMultiInlineRecords, TestNewtype, TestNewtypeRecord, TestRecord, TestRecursiveA, TestRecursiveB, TestSum, TestTwoFields) import Type.Proxy (Proxy(Proxy)) data TestData From c9fa2f07120c5efcaa3b11e0d884c4118998262b Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 15 Oct 2023 13:53:04 -0700 Subject: [PATCH 071/111] RoundTrip test succeeds with json-helper library --- purescript-bridge.cabal | 2 +- test/RoundTrip/Spec.hs | 3 +- test/RoundTrip/app/spago.dhall | 5 +- test/RoundTrip/app/src/RoundTrip/Types.purs | 152 ++++++++++++++++---- 4 files changed, 131 insertions(+), 31 deletions(-) diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index c08aba90..59a802ed 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -51,7 +51,7 @@ Test-Suite tests , base , containers , directory - , hspec >= 2.11 + , hspec >= 2.10 , hspec-expectations-pretty-diff , process , purescript-bridge diff --git a/test/RoundTrip/Spec.hs b/test/RoundTrip/Spec.hs index 7262245e..df219c49 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTrip/Spec.hs @@ -46,7 +46,8 @@ instancesToGenerate = equal . order . genericShow . order - . argonautJson + . jsonHelper + -- . argonautJson myTypes :: [SumType 'Haskell] myTypes = diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTrip/app/spago.dhall index 9a73c6f1..b94d982d 100644 --- a/test/RoundTrip/app/spago.dhall +++ b/test/RoundTrip/app/spago.dhall @@ -1,6 +1,7 @@ { name = "my-project" , dependencies = - [ "argonaut-aeson-generic" + [ "argonaut" + , "argonaut-aeson-generic" , "argonaut-codecs" , "argonaut-core" , "console" @@ -9,6 +10,7 @@ , "either" , "enums" , "foreign-object" + , "json-helpers" , "maybe" , "newtype" , "node-readline" @@ -16,7 +18,6 @@ , "prelude" , "profunctor-lenses" , "tuples" - , "json-helpers" ] , packages = ./packages.dhall , sources = [ "src/**/*.purs" ] diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTrip/app/src/RoundTrip/Types.purs index c2ffbb6c..20b11b5d 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTrip/app/src/RoundTrip/Types.purs @@ -3,15 +3,19 @@ module RoundTrip.Types where import Prelude -import (a) import Control.Lazy (defer) +import Data.Argonaut (encodeJson, jsonNull) import Data.Argonaut.Aeson.Decode.Generic (genericDecodeAeson) import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson) import Data.Argonaut.Aeson.Options (defaultOptions) as Argonaut import Data.Argonaut.Decode (class DecodeJson) +import Data.Argonaut.Decode.Aeson ((), (), ()) +import Data.Argonaut.Decode.Aeson as D import Data.Argonaut.Decode.Class (class DecodeJson, class DecodeJsonField, decodeJson) import Data.Argonaut.Decode.Class as Argonaut import Data.Argonaut.Encode (class EncodeJson) +import Data.Argonaut.Encode.Aeson ((>$<), (>/\<)) +import Data.Argonaut.Encode.Aeson as E import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) import Data.Argonaut.Encode.Class as Argonaut import Data.Bounded.Generic (genericBottom, genericTop) @@ -21,15 +25,15 @@ import Data.Enum.Generic (genericPred, genericSucc) import Data.Generic.Rep (class Generic) import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) +import Data.Map +import Data.Map as Map import Data.Maybe (Maybe(..)) -import Data.Newtype (class Newtype) +import Data.Newtype (class Newtype, unwrap) import Data.Set (Set) import Data.Show.Generic (genericShow) import Data.Tuple (Tuple) +import Data.Tuple.Nested ((/\)) import Foreign.Object (Object) -import Prelude (Unit, class Bounded, class Eq, class Functor, class Ord, class Show) -import Prim (Array, Boolean, Int, Number, String) -import RoundTrip.Types (MyUnit, TestEnum, TestMultiInlineRecords, TestNewtype, TestNewtypeRecord, TestRecord, TestRecursiveA, TestRecursiveB, TestSum, TestTwoFields) import Type.Proxy (Proxy(Proxy)) data TestData @@ -44,10 +48,16 @@ instance Show TestData where show a = genericShow a instance EncodeJson TestData where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> case _ of + Maybe a -> E.encodeTagged "Maybe" a (E.maybe E.value) + Either a -> E.encodeTagged "Either" a (E.either (E.maybe E.value) (E.maybe E.value)) instance DecodeJson TestData where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode + $ D.sumType "TestData" $ Map.fromFoldable + [ "Maybe" /\ D.content (Maybe <$> (D.maybe D.value)) + , "Either" /\ D.content (Either <$> (D.either (D.maybe D.value) (D.maybe D.value))) + ] derive instance Generic TestData _ @@ -89,10 +99,65 @@ instance Show TestSum where show a = genericShow a instance EncodeJson TestSum where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> case _ of + Nullary -> encodeJson { tag: "Nullary", contents: jsonNull } + Bool a -> E.encodeTagged "Bool" a E.value + Int a -> E.encodeTagged "Int" a E.value + Number a -> E.encodeTagged "Number" a E.value + String a -> E.encodeTagged "String" a E.value + Array a -> E.encodeTagged "Array" a E.value + InlineRecord {why, wouldYouDoThis} -> encodeJson + { tag: "InlineRecord" + , why: flip E.encode why E.value + , wouldYouDoThis: flip E.encode wouldYouDoThis E.value + } + MultiInlineRecords a -> E.encodeTagged "MultiInlineRecords" a E.value + Record a -> E.encodeTagged "Record" a E.value + NestedRecord a -> E.encodeTagged "NestedRecord" a E.value + NT a -> E.encodeTagged "NT" a E.value + NTRecord a -> E.encodeTagged "NTRecord" a E.value + TwoFields a -> E.encodeTagged "TwoFields" a E.value + Set a -> E.encodeTagged "Set" a E.value + Map a -> E.encodeTagged "Map" a E.value + Unit a -> E.encodeTagged "Unit" a E.unit + MyUnit a -> E.encodeTagged "MyUnit" a E.value + Pair a -> E.encodeTagged "Pair" a (E.tuple (E.value >/\< E.value)) + Triple a -> E.encodeTagged "Triple" a (E.tuple (E.value >/\< E.unit >/\< E.value)) + Quad a -> E.encodeTagged "Quad" a (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + QuadSimple a b c d -> E.encodeTagged "QuadSimple" (a /\ b /\ c /\ d) (E.tuple (E.value >/\< E.value >/\< E.value >/\< E.value)) + Recursive a -> E.encodeTagged "Recursive" a E.value + Enum a -> E.encodeTagged "Enum" a E.value instance DecodeJson TestSum where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode + $ D.sumType "TestSum" $ Map.fromFoldable + [ "Nullary" /\ pure Nullary + , "Bool" /\ D.content (Bool <$> D.value) + , "Int" /\ D.content (Int <$> D.value) + , "Number" /\ D.content (Number <$> D.value) + , "String" /\ D.content (String <$> D.value) + , "Array" /\ D.content (Array <$> D.value) + , "InlineRecord" /\ (InlineRecord <$> D.object "InlineRecord" + { why: D.value :: _ String + , wouldYouDoThis: D.value :: _ Int + }) + , "MultiInlineRecords" /\ D.content (MultiInlineRecords <$> D.value) + , "Record" /\ D.content (Record <$> D.value) + , "NestedRecord" /\ D.content (NestedRecord <$> D.value) + , "NT" /\ D.content (NT <$> D.value) + , "NTRecord" /\ D.content (NTRecord <$> D.value) + , "TwoFields" /\ D.content (TwoFields <$> D.value) + , "Set" /\ D.content (Set <$> D.value) + , "Map" /\ D.content (Map <$> D.value) + , "Unit" /\ D.content (Unit <$> D.unit) + , "MyUnit" /\ D.content (MyUnit <$> D.value) + , "Pair" /\ D.content (Pair <$> (D.tuple (D.value D.value))) + , "Triple" /\ D.content (Triple <$> (D.tuple (D.value D.unit D.value))) + , "Quad" /\ D.content (Quad <$> (D.tuple (D.value D.value D.value D.value))) + , "QuadSimple" /\ D.content (D.tuple $ QuadSimple D.value D.value D.value D.value) + , "Recursive" /\ D.content (Recursive <$> D.value) + , "Enum" /\ D.content (Enum <$> D.value) + ] derive instance Generic TestSum _ @@ -110,10 +175,16 @@ instance Show TestRecursiveA where show a = genericShow a instance EncodeJson TestRecursiveA where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> case _ of + Nil -> encodeJson { tag: "Nil", contents: jsonNull } + Recurse a -> E.encodeTagged "Recurse" a E.value instance DecodeJson TestRecursiveA where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode + $ D.sumType "TestRecursiveA" $ Map.fromFoldable + [ "Nil" /\ pure Nil + , "Recurse" /\ D.content (Recurse <$> D.value) + ] derive instance Generic TestRecursiveA _ @@ -129,10 +200,10 @@ instance Show TestRecursiveB where show a = genericShow a instance EncodeJson TestRecursiveB where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> E.encode $ unwrap >$< E.value instance DecodeJson TestRecursiveB where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode $ (RecurseB <$> D.value) derive instance Generic TestRecursiveB _ @@ -155,10 +226,16 @@ instance (Show a) => Show (TestRecord a) where show a = genericShow a instance (EncodeJson a) => EncodeJson (TestRecord a) where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record + { _field1: (E.maybe E.value) :: _ (Maybe Int) + , _field2: E.value :: _ a + }) instance (DecodeJson a, DecodeJsonField a) => DecodeJson (TestRecord a) where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode $ (TestRecord <$> D.record "TestRecord" + { _field1: (D.maybe D.value) :: _ (Maybe Int) + , _field2: D.value :: _ a + }) derive instance Generic (TestRecord a) _ @@ -176,10 +253,10 @@ instance Show TestNewtype where show a = genericShow a instance EncodeJson TestNewtype where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> E.encode $ unwrap >$< E.value instance DecodeJson TestNewtype where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode $ (TestNewtype <$> D.value) derive instance Generic TestNewtype _ @@ -197,10 +274,11 @@ instance Show TestNewtypeRecord where show a = genericShow a instance EncodeJson TestNewtypeRecord where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record + { unTestNewtypeRecord: E.value :: _ TestNewtype }) instance DecodeJson TestNewtypeRecord where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode $ (TestNewtypeRecord <$> D.record "TestNewtypeRecord" { unTestNewtypeRecord: D.value :: _ TestNewtype }) derive instance Generic TestNewtypeRecord _ @@ -226,10 +304,30 @@ instance Show TestMultiInlineRecords where show a = genericShow a instance EncodeJson TestMultiInlineRecords where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> case _ of + Foo {_foo1, _foo2} -> encodeJson + { tag: "Foo" + , _foo1: flip E.encode _foo1 (E.maybe E.value) + , _foo2: flip E.encode _foo2 E.unit + } + Bar {_bar1, _bar2} -> encodeJson + { tag: "Bar" + , _bar1: flip E.encode _bar1 E.value + , _bar2: flip E.encode _bar2 E.value + } instance DecodeJson TestMultiInlineRecords where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode + $ D.sumType "TestMultiInlineRecords" $ Map.fromFoldable + [ "Foo" /\ (Foo <$> D.object "Foo" + { _foo1: (D.maybe D.value) :: _ (Maybe Int) + , _foo2: D.unit :: _ Unit + }) + , "Bar" /\ (Bar <$> D.object "Bar" + { _bar1: D.value :: _ String + , _bar2: D.value :: _ Boolean + }) + ] derive instance Generic TestMultiInlineRecords _ @@ -245,10 +343,10 @@ instance Show TestTwoFields where show a = genericShow a instance EncodeJson TestTwoFields where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> E.encode $ (case _ of TestTwoFields a b -> (a /\ b)) >$< (E.tuple (E.value >/\< E.value)) instance DecodeJson TestTwoFields where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode $ (D.tuple $ TestTwoFields D.value D.value) derive instance Generic TestTwoFields _ @@ -271,10 +369,10 @@ instance Show TestEnum where show a = genericShow a instance EncodeJson TestEnum where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> E.encode E.enum instance DecodeJson TestEnum where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode D.enum derive instance Generic TestEnum _ @@ -298,10 +396,10 @@ instance Show MyUnit where show a = genericShow a instance EncodeJson MyUnit where - encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + encodeJson = defer \_ -> E.encode E.enum instance DecodeJson MyUnit where - decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + decodeJson = defer \_ -> D.decode D.enum derive instance Generic MyUnit _ From 5480bffa515317368dd679a17c871b6a117fd817 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 15 Oct 2023 16:11:53 -0700 Subject: [PATCH 072/111] RoundTrip tests for both json-helpers and argonaut-aeson-generic --- example/packages.dhall | 32 ++ example/src/Types.hs | 2 +- purescript-bridge.cabal | 6 +- spago.dhall | 21 +- src/Language/PureScript/Bridge/SumType.hs | 8 +- test/RoundTripArgonautAesonGeneric/Spec.hs | 125 +++++++ test/RoundTripArgonautAesonGeneric/Types.hs | 215 ++++++++++++ .../app/.gitignore | 0 .../app/packages.dhall | 0 .../app/spago.dhall | 22 ++ .../app/src/Main.purs | 32 ++ .../RoundTripArgonautAesonGeneric/Types.purs | 310 ++++++++++++++++++ .../Spec.hs | 20 +- .../Types.hs | 2 +- test/RoundTripJsonHelpers/app/.gitignore | 10 + test/RoundTripJsonHelpers/app/packages.dhall | 100 ++++++ .../app/spago.dhall | 0 .../app/src/Main.purs | 2 +- .../app/src/RoundTripJsonHelpers}/Types.purs | 2 +- test/Spec.hs | 15 +- test/readme.md | 8 + 21 files changed, 905 insertions(+), 27 deletions(-) create mode 100644 test/RoundTripArgonautAesonGeneric/Spec.hs create mode 100644 test/RoundTripArgonautAesonGeneric/Types.hs rename test/{RoundTrip => RoundTripArgonautAesonGeneric}/app/.gitignore (100%) rename test/{RoundTrip => RoundTripArgonautAesonGeneric}/app/packages.dhall (100%) create mode 100644 test/RoundTripArgonautAesonGeneric/app/spago.dhall create mode 100644 test/RoundTripArgonautAesonGeneric/app/src/Main.purs create mode 100644 test/RoundTripArgonautAesonGeneric/app/src/RoundTripArgonautAesonGeneric/Types.purs rename test/{RoundTrip => RoundTripJsonHelpers}/Spec.hs (90%) rename test/{RoundTrip => RoundTripJsonHelpers}/Types.hs (99%) create mode 100644 test/RoundTripJsonHelpers/app/.gitignore create mode 100644 test/RoundTripJsonHelpers/app/packages.dhall rename test/{RoundTrip => RoundTripJsonHelpers}/app/spago.dhall (100%) rename test/{RoundTrip => RoundTripJsonHelpers}/app/src/Main.purs (95%) rename test/{RoundTrip/app/src/RoundTrip => RoundTripJsonHelpers/app/src/RoundTripJsonHelpers}/Types.purs (99%) create mode 100644 test/readme.md diff --git a/example/packages.dhall b/example/packages.dhall index 04d53931..9e54c5e4 100644 --- a/example/packages.dhall +++ b/example/packages.dhall @@ -30,6 +30,38 @@ let additions = , repo = "https://github.com/jsparkes/purescript-foreign-generic.git" , version = "844f2ababa2c7a0482bf871e1e6bf970b7e51313" } + , json-helpers = + { dependencies = + [ "aff" + , "argonaut-codecs" + , "argonaut-core" + , "arrays" + , "bifunctors" + , "contravariant" + , "control" + , "effect" + , "either" + , "enums" + , "foldable-traversable" + , "foreign-object" + , "maybe" + , "newtype" + , "ordered-collections" + , "prelude" + , "profunctor" + , "psci-support" + , "quickcheck" + , "record" + , "spec" + , "spec-quickcheck" + , "transformers" + , "tuples" + , "typelevel-prelude" + ] + , repo = + "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" + , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + } } in upstream // additions diff --git a/example/src/Types.hs b/example/src/Types.hs index f8850fad..11c7f036 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -65,7 +65,7 @@ myBridge = defaultBridge additionalInstances = lenses . genericShow -- . jsonHelper - . argonautJson + . argonautAesonGeneric myTypes :: [SumType 'Haskell] myTypes = diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index 59a802ed..2b57e193 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -43,8 +43,10 @@ Test-Suite tests type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: TestData - , RoundTrip.Spec - , RoundTrip.Types + , RoundTripArgonautAesonGeneric.Spec + , RoundTripArgonautAesonGeneric.Types + , RoundTripJsonHelpers.Spec + , RoundTripJsonHelpers.Types build-depends: aeson , bytestring , HUnit diff --git a/spago.dhall b/spago.dhall index b0678014..c05eed21 100644 --- a/spago.dhall +++ b/spago.dhall @@ -1,27 +1,34 @@ { name = "purescript-bridge-example" , dependencies = - [ "console" - , "effect" - , "foreign-generic" - , "profunctor-lenses" - , "aff" + [ "aff" , "affjax" , "affjax-web" + , "argonaut" , "argonaut-aeson-generic" - , "ordered-collections" , "argonaut-codecs" + , "argonaut-core" , "argonaut-generic" + , "console" + , "control" + , "effect" , "either" + , "enums" , "foldable-traversable" + , "foreign-generic" , "foreign-object" + , "json-helpers" , "maybe" , "newtype" + , "ordered-collections" , "prelude" + , "profunctor-lenses" + , "tuples" ] , packages = ./example/packages.dhall , sources = [ "example/src/**/*.purs" , "example/test/**/*.purs" - , "test/RoundTrip/app/src/RoundTrip/*.purs" + , "test/RoundTripArgonautAesonGeneric/app/src/RoundTripArgonautAesonGeneric/*.purs" + , "test/RoundTripJsonHelpers/app/src/RoundTripJsonHelpers/*.purs" ] } diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 1b54c9d8..99517f6f 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -19,7 +19,7 @@ module Language.PureScript.Bridge.SumType , equal , equal1 , order - , argonautJson + , argonautAesonGeneric , jsonHelper , genericShow , functor @@ -197,8 +197,10 @@ nootype [DataConstructor _ (Normal [_])] = Just Newtype nootype _ = Nothing -- | Ensure that aeson-compatible `EncodeJson` and `DecodeJson` instances are generated for your type. -argonautJson :: SumType t -> SumType t -argonautJson (SumType ti dc is) = SumType ti dc . nub $ EncodeJson : DecodeJson : is +-- Uses `argonaut-aeson-generic` +-- +argonautAesonGeneric :: SumType t -> SumType t +argonautAesonGeneric (SumType ti dc is) = SumType ti dc . nub $ EncodeJson : DecodeJson : is -- | Ensure that aeson-compatible `EncodeJson` and `DecodeJson` instances are generated for your type. -- Uses unpublished library `purescript-bridge-json-helpers` diff --git a/test/RoundTripArgonautAesonGeneric/Spec.hs b/test/RoundTripArgonautAesonGeneric/Spec.hs new file mode 100644 index 00000000..82bbca0b --- /dev/null +++ b/test/RoundTripArgonautAesonGeneric/Spec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module RoundTripArgonautAesonGeneric.Spec where + +import Control.Exception (bracket) +import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, encode, + fromJSON) +import Data.ByteString.Lazy (hGetContents, stripSuffix) +import Data.ByteString.Lazy.UTF8 (fromString, toString) +import Data.List (isInfixOf) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, + argonautAesonGeneric, buildBridge, + defaultBridge, equal, functor, + genericShow, mkSumType, order, jsonHelper, + writePSTypes, writePSTypesWith) +import Language.PureScript.Bridge.TypeParameters (A) +import RoundTripArgonautAesonGeneric.Types +import System.Directory (removeDirectoryRecursive, removeFile, + withCurrentDirectory) +import System.Exit (ExitCode (ExitSuccess)) +import System.IO (BufferMode (..), hFlush, hGetLine, hPutStrLn, + hSetBuffering, stderr, stdout) +import System.Process (CreateProcess (std_err, std_in, std_out), + StdStream (CreatePipe), createProcess, + getProcessExitCode, proc, + readProcessWithExitCode, terminateProcess, + waitForProcess) +import Test.Hspec (Spec, around, aroundAll_, around_, describe, it) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.HUnit (assertBool, assertEqual) +import Test.QuickCheck (verbose) +import Test.QuickCheck.Property (Testable (property)) + +myBridge :: BridgePart +myBridge = defaultBridge + +-- test `argonaut-aeson-generic` +instancesToGenerate = equal + . order + . genericShow + . order + . argonautAesonGeneric + +myTypes :: [SumType 'Haskell] +myTypes = + [ instancesToGenerate $ mkSumType @TestData + , instancesToGenerate $ mkSumType @TestSum + , instancesToGenerate $ mkSumType @TestRecursiveA + , instancesToGenerate $ mkSumType @TestRecursiveB + , functor . instancesToGenerate $ mkSumType @(TestRecord A) + , instancesToGenerate $ mkSumType @TestNewtype + , instancesToGenerate $ mkSumType @TestNewtypeRecord + , instancesToGenerate $ mkSumType @TestMultiInlineRecords + , instancesToGenerate $ mkSumType @TestTwoFields + , instancesToGenerate $ mkSumType @TestEnum + , instancesToGenerate $ mkSumType @MyUnit + ] + +roundtripSpec :: Spec +roundtripSpec = do + -- test `argonaut-aeson-generic` + aroundAll_ withProject $ + describe "writePSTypesWith argonaut-aeson-generics" do + it "should be buildable" do + (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" + assertEqual (stdout <> stderr) exitCode ExitSuccess + it "should not warn of unused packages buildable" do + (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" + assertBool stderr $ not $ "[warn]" `isInfixOf` stderr + around withApp $ + it "should produce aeson-compatible argonaut instances with argonaut-aeson-generics library" $ + \(hin, hout, herr, hproc) -> verbose . property $ \testData -> do + let input = toString $ encode @TestData testData + hPutStrLn hin input + err <- hGetLine herr + output <- hGetLine hout + + -- empty string signifies no error from Purescript process + assertEqual ("Error from Purescript, parsing: " <> input) "" err + + -- compare the value parsed by Purescipt to the + -- source value in Haskell + assertEqual ("Mismatch between value sent to Purescript and value returned: " <> output) (Right testData) + . eitherDecode @TestData + $ fromString output + + where + withApp = bracket runApp killApp + runApp = do + (Just hin, Just hout, Just herr, hproc) <- + createProcess + (proc "spago" ["run"]) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + hSetBuffering hin LineBuffering + hSetBuffering hout LineBuffering + hSetBuffering herr LineBuffering + -- flush stderr output from build + _ <- hGetLine herr + -- wait for initial log message + _ <- hGetLine hout + pure (hin, hout, herr, hproc) + + killApp (_, _, _, hproc) = terminateProcess hproc + + withProject :: IO () -> IO () + withProject runSpec = + withCurrentDirectory "test/RoundTripArgonautAesonGeneric/app" $ generate *> runSpec + + generate :: IO () + generate = do + writePSTypesWith + "src" + (buildBridge myBridge) + myTypes diff --git a/test/RoundTripArgonautAesonGeneric/Types.hs b/test/RoundTripArgonautAesonGeneric/Types.hs new file mode 100644 index 00000000..cd0cb679 --- /dev/null +++ b/test/RoundTripArgonautAesonGeneric/Types.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} + +module RoundTripArgonautAesonGeneric.Types where + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import Data.Text (Text) +import GHC.Generics (Generic) +import Language.PureScript.Bridge (BridgePart, Language (..), SumType, + buildBridge, defaultBridge, + mkSumType, writePSTypes, + writePSTypesWith) +import Language.PureScript.Bridge.TypeParameters (A) +import System.Directory (removeDirectoryRecursive, removeFile, + withCurrentDirectory) +import System.Exit (ExitCode (ExitSuccess)) +import System.Process (readProcessWithExitCode) +import Test.Hspec (Spec, aroundAll_, describe, it) +import Test.Hspec.Expectations.Pretty (shouldBe) +import Test.HUnit (assertEqual) +import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, + sized) + +data TestData + = Maybe (Maybe TestSum) + | Either (Either (Maybe Int) (Maybe Bool)) + deriving (Eq, Generic, Ord, Show) + +instance FromJSON TestData + +instance ToJSON TestData + +instance Arbitrary TestData where + arbitrary = + oneof + [ Maybe <$> arbitrary + , Either <$> arbitrary + ] + +data TestSum + = Nullary + | Bool Bool + | Int Int + | Number Double + | String String + | Array [Int] + | InlineRecord + { why :: String + , wouldYouDoThis :: Int + } + | MultiInlineRecords TestMultiInlineRecords + | Record (TestRecord Int) + | NestedRecord (TestRecord (TestRecord Int)) + | NT TestNewtype + | NTRecord TestNewtypeRecord + | TwoFields TestTwoFields + | Set (Set Int) + | Map (Map String Int) + | Unit () + | MyUnit MyUnit + | Pair (Int, Double) + | Triple (Int, (), Bool) + | Quad (Int, Double, Bool, Double) + | QuadSimple Int Double Bool Double + | Recursive TestRecursiveA + | Enum TestEnum + deriving (Eq, Generic, Ord, Show) + +instance FromJSON TestSum + +instance ToJSON TestSum + +instance Arbitrary TestSum where + arbitrary = + oneof + [ pure Nullary + , Bool <$> arbitrary + , Int <$> arbitrary + , Number <$> arbitrary + , String <$> arbitrary + , Array <$> arbitrary + , InlineRecord <$> arbitrary <*> arbitrary + , MultiInlineRecords <$> arbitrary + , Record <$> arbitrary + , NestedRecord <$> arbitrary + , NT <$> arbitrary + , NTRecord <$> arbitrary + , Map <$> arbitrary + , Set <$> arbitrary + , TwoFields <$> arbitrary + , pure $ Unit () + , Pair <$> arbitrary + , Triple <$> arbitrary + , Quad <$> arbitrary + , QuadSimple <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , Enum <$> arbitrary + ] + +data TestRecursiveA + = Nil + | Recurse TestRecursiveB + deriving (Eq, Generic, Ord, Show) + +instance FromJSON TestRecursiveA + +instance ToJSON TestRecursiveA + +instance Arbitrary TestRecursiveA where + arbitrary = sized go + where + go size + | size > 0 = oneof [pure Nil, resize (size - 1) $ Recurse <$> arbitrary] + | otherwise = pure Nil + +newtype TestRecursiveB + = RecurseB TestRecursiveB + deriving (Arbitrary, Eq, Generic, Ord, Show) + +instance FromJSON TestRecursiveB + +instance ToJSON TestRecursiveB + +data TestMultiInlineRecords + = Foo + { _foo1 :: Maybe Int + , _foo2 :: () + } + | Bar + { _bar1 :: String + , _bar2 :: Bool + } + deriving (Eq, Generic, Ord, Show) + +instance FromJSON TestMultiInlineRecords + +instance ToJSON TestMultiInlineRecords + +instance Arbitrary TestMultiInlineRecords where + arbitrary = + oneof + [ Foo <$> arbitrary <*> arbitrary + , Bar <$> arbitrary <*> arbitrary + ] + +data TestRecord a = TestRecord + { _field1 :: Maybe Int + , _field2 :: a + } + deriving (Eq, Generic, Ord, Show) + +instance (FromJSON a) => FromJSON (TestRecord a) + +instance (ToJSON a) => ToJSON (TestRecord a) + +instance (Arbitrary a) => Arbitrary (TestRecord a) where + arbitrary = TestRecord <$> arbitrary <*> arbitrary + +data TestTwoFields = TestTwoFields Bool Int + deriving (Eq, Generic, Ord, Show) + +instance FromJSON TestTwoFields + +instance ToJSON TestTwoFields + +instance Arbitrary TestTwoFields where + arbitrary = TestTwoFields <$> arbitrary <*> arbitrary + +newtype TestNewtype + = TestNewtype (TestRecord Bool) + deriving (Eq, Generic, Ord, Show) + +instance FromJSON TestNewtype + +instance ToJSON TestNewtype + +instance Arbitrary TestNewtype where + arbitrary = TestNewtype <$> arbitrary + +newtype TestNewtypeRecord + = TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } + deriving (Eq, Generic, Ord, Show) + +instance FromJSON TestNewtypeRecord + +instance ToJSON TestNewtypeRecord + +instance Arbitrary TestNewtypeRecord where + arbitrary = TestNewtypeRecord <$> arbitrary + +data TestEnum = Mon | Tue | Wed | Thu | Fri | Sat | Sun + deriving (Bounded, Enum, Eq, Generic, Ord, Show) + +instance FromJSON TestEnum + +instance ToJSON TestEnum + +instance Arbitrary TestEnum where + arbitrary = chooseEnum (minBound, maxBound) + +data MyUnit = U + deriving (Bounded, Enum, Eq, Generic, Ord, Show) + +instance FromJSON MyUnit + +instance ToJSON MyUnit + +instance Arbitrary MyUnit where + arbitrary = pure U diff --git a/test/RoundTrip/app/.gitignore b/test/RoundTripArgonautAesonGeneric/app/.gitignore similarity index 100% rename from test/RoundTrip/app/.gitignore rename to test/RoundTripArgonautAesonGeneric/app/.gitignore diff --git a/test/RoundTrip/app/packages.dhall b/test/RoundTripArgonautAesonGeneric/app/packages.dhall similarity index 100% rename from test/RoundTrip/app/packages.dhall rename to test/RoundTripArgonautAesonGeneric/app/packages.dhall diff --git a/test/RoundTripArgonautAesonGeneric/app/spago.dhall b/test/RoundTripArgonautAesonGeneric/app/spago.dhall new file mode 100644 index 00000000..051ff196 --- /dev/null +++ b/test/RoundTripArgonautAesonGeneric/app/spago.dhall @@ -0,0 +1,22 @@ +{ name = "my-project" +, dependencies = + [ "argonaut-aeson-generic" + , "argonaut-codecs" + , "argonaut-core" + , "console" + , "control" + , "effect" + , "either" + , "enums" + , "foreign-object" + , "maybe" + , "newtype" + , "node-readline" + , "ordered-collections" + , "prelude" + , "profunctor-lenses" + , "tuples" + ] +, packages = ./packages.dhall +, sources = [ "src/**/*.purs" ] +} diff --git a/test/RoundTripArgonautAesonGeneric/app/src/Main.purs b/test/RoundTripArgonautAesonGeneric/app/src/Main.purs new file mode 100644 index 00000000..a30bb902 --- /dev/null +++ b/test/RoundTripArgonautAesonGeneric/app/src/Main.purs @@ -0,0 +1,32 @@ +module Main where + +import Prelude + +import Data.Argonaut.Core (stringify) +import Data.Argonaut.Decode (JsonDecodeError, decodeJson, parseJson, printJsonDecodeError) +import Data.Argonaut.Encode (encodeJson) +import Data.Either (Either(..)) +import Effect (Effect) +import Effect.Class.Console (error, log) +import Node.ReadLine (createConsoleInterface, noCompletion, question) +import RoundTripArgonautAesonGeneric.Types (TestData) + +main :: Effect Unit +main = do + interface <- createConsoleInterface noCompletion + log "ready" + go interface + where + go interface = + interface # question "" \input -> do + let + parsed :: Either JsonDecodeError TestData + parsed = decodeJson =<< parseJson input + case parsed of + Left err -> do + error $ input <> " " <> show err + log $ printJsonDecodeError err + Right testData -> do + error "" + log $ stringify $ encodeJson testData + go interface diff --git a/test/RoundTripArgonautAesonGeneric/app/src/RoundTripArgonautAesonGeneric/Types.purs b/test/RoundTripArgonautAesonGeneric/app/src/RoundTripArgonautAesonGeneric/Types.purs new file mode 100644 index 00000000..8b397ab3 --- /dev/null +++ b/test/RoundTripArgonautAesonGeneric/app/src/RoundTripArgonautAesonGeneric/Types.purs @@ -0,0 +1,310 @@ +-- File auto generated by purescript-bridge! -- +module RoundTripArgonautAesonGeneric.Types where + +import Prelude + +import Control.Lazy (defer) +import Data.Argonaut.Aeson.Decode.Generic (genericDecodeAeson) +import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson) +import Data.Argonaut.Aeson.Options (defaultOptions) as Argonaut +import Data.Argonaut.Decode (class DecodeJson) +import Data.Argonaut.Decode.Class (class DecodeJson, class DecodeJsonField, decodeJson) +import Data.Argonaut.Decode.Class as Argonaut +import Data.Argonaut.Encode (class EncodeJson) +import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) +import Data.Argonaut.Encode.Class as Argonaut +import Data.Bounded.Generic (genericBottom, genericTop) +import Data.Either (Either) +import Data.Enum (class Enum) +import Data.Enum.Generic (genericPred, genericSucc) +import Data.Generic.Rep (class Generic) +import Data.Lens.Iso.Newtype (_Newtype) +import Data.Lens.Record (prop) +import Data.Maybe (Maybe(..)) +import Data.Newtype (class Newtype) +import Data.Set (Set) +import Data.Show.Generic (genericShow) +import Data.Tuple (Tuple) +import Foreign.Object (Object) +import Type.Proxy (Proxy(Proxy)) + +data TestData + = Maybe (Maybe TestSum) + | Either (Either (Maybe Int) (Maybe Boolean)) + +derive instance Eq TestData + +derive instance Ord TestData + +instance Show TestData where + show a = genericShow a + +instance EncodeJson TestData where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestData where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestData _ + +-------------------------------------------------------------------------------- + +data TestSum + = Nullary + | Bool Boolean + | Int Int + | Number Number + | String String + | Array (Array Int) + | InlineRecord + { why :: String + , wouldYouDoThis :: Int + } + | MultiInlineRecords TestMultiInlineRecords + | Record (TestRecord Int) + | NestedRecord (TestRecord (TestRecord Int)) + | NT TestNewtype + | NTRecord TestNewtypeRecord + | TwoFields TestTwoFields + | Set (Set Int) + | Map (Object Int) + | Unit Unit + | MyUnit MyUnit + | Pair (Tuple Int Number) + | Triple (Tuple Int (Tuple Unit Boolean)) + | Quad (Tuple Int (Tuple Number (Tuple Boolean Number))) + | QuadSimple Int Number Boolean Number + | Recursive TestRecursiveA + | Enum TestEnum + +derive instance Eq TestSum + +derive instance Ord TestSum + +instance Show TestSum where + show a = genericShow a + +instance EncodeJson TestSum where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestSum where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestSum _ + +-------------------------------------------------------------------------------- + +data TestRecursiveA + = Nil + | Recurse TestRecursiveB + +derive instance Eq TestRecursiveA + +derive instance Ord TestRecursiveA + +instance Show TestRecursiveA where + show a = genericShow a + +instance EncodeJson TestRecursiveA where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestRecursiveA where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestRecursiveA _ + +-------------------------------------------------------------------------------- + +newtype TestRecursiveB = RecurseB TestRecursiveB + +derive instance Eq TestRecursiveB + +derive instance Ord TestRecursiveB + +instance Show TestRecursiveB where + show a = genericShow a + +instance EncodeJson TestRecursiveB where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestRecursiveB where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestRecursiveB _ + +derive instance Newtype TestRecursiveB _ + +-------------------------------------------------------------------------------- + +newtype TestRecord a = TestRecord + { _field1 :: Maybe Int + , _field2 :: a + } + +derive instance Functor TestRecord + +derive instance (Eq a) => Eq (TestRecord a) + +derive instance (Ord a) => Ord (TestRecord a) + +instance (Show a) => Show (TestRecord a) where + show a = genericShow a + +instance (EncodeJson a) => EncodeJson (TestRecord a) where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance (DecodeJson a, DecodeJsonField a) => DecodeJson (TestRecord a) where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic (TestRecord a) _ + +derive instance Newtype (TestRecord a) _ + +-------------------------------------------------------------------------------- + +newtype TestNewtype = TestNewtype (TestRecord Boolean) + +derive instance Eq TestNewtype + +derive instance Ord TestNewtype + +instance Show TestNewtype where + show a = genericShow a + +instance EncodeJson TestNewtype where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestNewtype where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestNewtype _ + +derive instance Newtype TestNewtype _ + +-------------------------------------------------------------------------------- + +newtype TestNewtypeRecord = TestNewtypeRecord { unTestNewtypeRecord :: TestNewtype } + +derive instance Eq TestNewtypeRecord + +derive instance Ord TestNewtypeRecord + +instance Show TestNewtypeRecord where + show a = genericShow a + +instance EncodeJson TestNewtypeRecord where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestNewtypeRecord where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestNewtypeRecord _ + +derive instance Newtype TestNewtypeRecord _ + +-------------------------------------------------------------------------------- + +data TestMultiInlineRecords + = Foo + { _foo1 :: Maybe Int + , _foo2 :: Unit + } + | Bar + { _bar1 :: String + , _bar2 :: Boolean + } + +derive instance Eq TestMultiInlineRecords + +derive instance Ord TestMultiInlineRecords + +instance Show TestMultiInlineRecords where + show a = genericShow a + +instance EncodeJson TestMultiInlineRecords where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestMultiInlineRecords where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestMultiInlineRecords _ + +-------------------------------------------------------------------------------- + +data TestTwoFields = TestTwoFields Boolean Int + +derive instance Eq TestTwoFields + +derive instance Ord TestTwoFields + +instance Show TestTwoFields where + show a = genericShow a + +instance EncodeJson TestTwoFields where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestTwoFields where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestTwoFields _ + +-------------------------------------------------------------------------------- + +data TestEnum + = Mon + | Tue + | Wed + | Thu + | Fri + | Sat + | Sun + +derive instance Eq TestEnum + +derive instance Ord TestEnum + +instance Show TestEnum where + show a = genericShow a + +instance EncodeJson TestEnum where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson TestEnum where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic TestEnum _ + +instance Enum TestEnum where + succ = genericSucc + pred = genericPred + +instance Bounded TestEnum where + bottom = genericBottom + top = genericTop + +-------------------------------------------------------------------------------- + +data MyUnit = U + +derive instance Eq MyUnit + +derive instance Ord MyUnit + +instance Show MyUnit where + show a = genericShow a + +instance EncodeJson MyUnit where + encodeJson = defer \_ -> genericEncodeAeson Argonaut.defaultOptions + +instance DecodeJson MyUnit where + decodeJson = defer \_ -> genericDecodeAeson Argonaut.defaultOptions + +derive instance Generic MyUnit _ + +instance Enum MyUnit where + succ = genericSucc + pred = genericPred + +instance Bounded MyUnit where + bottom = genericBottom + top = genericTop diff --git a/test/RoundTrip/Spec.hs b/test/RoundTripJsonHelpers/Spec.hs similarity index 90% rename from test/RoundTrip/Spec.hs rename to test/RoundTripJsonHelpers/Spec.hs index df219c49..015bee5a 100644 --- a/test/RoundTrip/Spec.hs +++ b/test/RoundTripJsonHelpers/Spec.hs @@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -module RoundTrip.Spec where +module RoundTripJsonHelpers.Spec where import Control.Exception (bracket) import Data.Aeson (FromJSON, ToJSON (toJSON), eitherDecode, encode, @@ -16,12 +16,12 @@ import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, - argonautJson, buildBridge, + argonautAesonGeneric, buildBridge, defaultBridge, equal, functor, genericShow, mkSumType, order, jsonHelper, writePSTypes, writePSTypesWith) import Language.PureScript.Bridge.TypeParameters (A) -import RoundTrip.Types +import RoundTripJsonHelpers.Types import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) @@ -42,12 +42,12 @@ import Test.QuickCheck.Property (Testable (property)) myBridge :: BridgePart myBridge = defaultBridge +-- test `json-helpers` instancesToGenerate = equal . order . genericShow . order . jsonHelper - -- . argonautJson myTypes :: [SumType 'Haskell] myTypes = @@ -66,8 +66,9 @@ myTypes = roundtripSpec :: Spec roundtripSpec = do + -- test `json-helpers` aroundAll_ withProject $ - describe "writePSTypesWith" do + describe "writePSTypesWith json-helpers" do it "should be buildable" do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" assertEqual (stdout <> stderr) exitCode ExitSuccess @@ -75,8 +76,8 @@ roundtripSpec = do (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" assertBool stderr $ not $ "[warn]" `isInfixOf` stderr around withApp $ - it "should produce aeson-compatible argonaut instances" $ - \(hin, hout, herr, hproc) -> verbose . property $ \testData -> do + it "should produce aeson-compatible argonaut instances with json-helpers library" $ + \(hin, hout, herr, hproc) -> property $ \testData -> do let input = toString $ encode @TestData testData hPutStrLn hin input err <- hGetLine herr @@ -90,7 +91,6 @@ roundtripSpec = do assertEqual ("Mismatch between value sent to Purescript and value returned: " <> output) (Right testData) . eitherDecode @TestData $ fromString output - where withApp = bracket runApp killApp runApp = do @@ -112,9 +112,11 @@ roundtripSpec = do killApp (_, _, _, hproc) = terminateProcess hproc + withProject :: IO () -> IO () withProject runSpec = - withCurrentDirectory "test/RoundTrip/app" $ generate *> runSpec + withCurrentDirectory "test/RoundTripJsonHelpers/app" $ generate *> runSpec + generate :: IO () generate = do writePSTypesWith "src" diff --git a/test/RoundTrip/Types.hs b/test/RoundTripJsonHelpers/Types.hs similarity index 99% rename from test/RoundTrip/Types.hs rename to test/RoundTripJsonHelpers/Types.hs index ba18fa4d..5cb8778a 100644 --- a/test/RoundTrip/Types.hs +++ b/test/RoundTripJsonHelpers/Types.hs @@ -4,7 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} -module RoundTrip.Types where +module RoundTripJsonHelpers.Types where import Control.Applicative ((<|>)) import Data.Aeson (FromJSON, ToJSON) diff --git a/test/RoundTripJsonHelpers/app/.gitignore b/test/RoundTripJsonHelpers/app/.gitignore new file mode 100644 index 00000000..30efe199 --- /dev/null +++ b/test/RoundTripJsonHelpers/app/.gitignore @@ -0,0 +1,10 @@ +/bower_components/ +/node_modules/ +/.pulp-cache/ +/output/ +/generated-docs/ +/.psc-package/ +/.psc* +/.purs* +/.psa* +/.spago diff --git a/test/RoundTripJsonHelpers/app/packages.dhall b/test/RoundTripJsonHelpers/app/packages.dhall new file mode 100644 index 00000000..a82ba358 --- /dev/null +++ b/test/RoundTripJsonHelpers/app/packages.dhall @@ -0,0 +1,100 @@ +let upstream = + https://github.com/purescript/package-sets/releases/download/psc-0.15.7-20230331/packages.dhall + sha256:97a54e4c5c1a76f51cef8fb8c91a8ff602dca7828dc464e07e48ee563b6bd058 + +let additions = + { argonaut-aeson-generic = + { dependencies = + [ "argonaut" + , "argonaut-codecs" + , "argonaut-generic" + , "console" + , "effect" + , "foreign-object" + , "test-unit" + ] + , repo = + "https://github.com/peterbecich/purescript-argonaut-aeson-generic.git" + , version = "e22b1b9046aef15d6441ea90870dfbfa455a70fb" + } + , foreign-generic = + { dependencies = + [ "effect" + , "foreign" + , "foreign-object" + , "ordered-collections" + , "exceptions" + , "record" + , "identity" + ] + , repo = "https://github.com/jsparkes/purescript-foreign-generic.git" + , version = "844f2ababa2c7a0482bf871e1e6bf970b7e51313" + } + , json-helpers = + { dependencies = + [ "aff" + , "argonaut-codecs" + , "argonaut-core" + , "arrays" + , "bifunctors" + , "contravariant" + , "control" + , "effect" + , "either" + , "enums" + , "foldable-traversable" + , "foreign-object" + , "maybe" + , "newtype" + , "ordered-collections" + , "prelude" + , "profunctor" + , "psci-support" + , "quickcheck" + , "record" + , "spec" + , "spec-quickcheck" + , "transformers" + , "tuples" + , "typelevel-prelude" + ] + , repo = + "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" + , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + } + } + + +in upstream // additions // { + json-helpers = + { dependencies = + [ "aff" + , "argonaut-codecs" + , "argonaut-core" + , "arrays" + , "bifunctors" + , "contravariant" + , "control" + , "effect" + , "either" + , "enums" + , "foldable-traversable" + , "foreign-object" + , "maybe" + , "newtype" + , "ordered-collections" + , "prelude" + , "profunctor" + , "psci-support" + , "quickcheck" + , "record" + , "spec" + , "spec-quickcheck" + , "transformers" + , "tuples" + , "typelevel-prelude" + ] + , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" + , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + } +} diff --git a/test/RoundTrip/app/spago.dhall b/test/RoundTripJsonHelpers/app/spago.dhall similarity index 100% rename from test/RoundTrip/app/spago.dhall rename to test/RoundTripJsonHelpers/app/spago.dhall diff --git a/test/RoundTrip/app/src/Main.purs b/test/RoundTripJsonHelpers/app/src/Main.purs similarity index 95% rename from test/RoundTrip/app/src/Main.purs rename to test/RoundTripJsonHelpers/app/src/Main.purs index 9e8e22e0..fa12da5f 100644 --- a/test/RoundTrip/app/src/Main.purs +++ b/test/RoundTripJsonHelpers/app/src/Main.purs @@ -9,7 +9,7 @@ import Data.Either (Either(..)) import Effect (Effect) import Effect.Class.Console (error, log) import Node.ReadLine (createConsoleInterface, noCompletion, question) -import RoundTrip.Types (TestData) +import RoundTripJsonHelpers.Types (TestData) main :: Effect Unit main = do diff --git a/test/RoundTrip/app/src/RoundTrip/Types.purs b/test/RoundTripJsonHelpers/app/src/RoundTripJsonHelpers/Types.purs similarity index 99% rename from test/RoundTrip/app/src/RoundTrip/Types.purs rename to test/RoundTripJsonHelpers/app/src/RoundTripJsonHelpers/Types.purs index 20b11b5d..e03ecdc1 100644 --- a/test/RoundTrip/app/src/RoundTrip/Types.purs +++ b/test/RoundTripJsonHelpers/app/src/RoundTripJsonHelpers/Types.purs @@ -1,5 +1,5 @@ -- File auto generated by purescript-bridge! -- -module RoundTrip.Types where +module RoundTripJsonHelpers.Types where import Prelude diff --git a/test/Spec.hs b/test/Spec.hs index 475bb455..716ffab1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -16,15 +16,26 @@ import qualified Data.Text as T import Data.Word (Word, Word64) import Language.PureScript.Bridge import Language.PureScript.Bridge.TypeParameters -import RoundTrip.Spec (roundtripSpec) +import qualified RoundTripArgonautAesonGeneric.Spec (roundtripSpec) +import qualified RoundTripJsonHelpers.Spec (roundtripSpec) import Test.Hspec (Spec, describe, hspec, it) import Test.Hspec.Expectations.Pretty import TestData import Text.PrettyPrint.Leijen.Text (Doc, cat, linebreak, punctuate, vsep) +-- | There are RoundTrip tests for both the `json-helpers` library and the +-- `argonaut-aeson-generic` library. +-- These have been separated into two directories, and the test specs are duplicated. +-- This is necessary because the generated PureScript takes its module name from the +-- Haskell module which generates it. +-- If both generated PureScript modules have the same module name, the root +-- Spago project will fail to build because of module name duplication. main :: IO () -main = hspec $ allTests *> roundtripSpec +main = + hspec $ allTests + *> RoundTripArgonautAesonGeneric.Spec.roundtripSpec + *> RoundTripJsonHelpers.Spec.roundtripSpec custom :: SumType 'Haskell -> SumType 'Haskell custom (SumType t cs is) = SumType t cs $ customInstance : is diff --git a/test/readme.md b/test/readme.md new file mode 100644 index 00000000..04c00770 --- /dev/null +++ b/test/readme.md @@ -0,0 +1,8 @@ +# Tests + +There are RoundTrip tests for both the `json-helpers` library and the `argonaut-aeson-generic` library. + +These have been separated into two directories, and the test specs are duplicated. + +This is necessary because the generated PureScript takes its module name from the Haskell module which generates it. If both generated PureScript modules have the same module name, the root Spago project will fail to build because of module name duplication. + From 1bc3046072e5e9323c8e079bfdce2cb8232a5e1f Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 15 Oct 2023 18:37:58 -0700 Subject: [PATCH 073/111] fix dependency notice for `json-helpers` "The following purescript packages are needed by the generated code:" --- src/Language/PureScript/Bridge/SumType.hs | 38 +++++++++++++------ .../app/src/RoundTripJsonHelpers/Types.purs | 2 - 2 files changed, 26 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 99517f6f..5661a7ed 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -317,20 +317,30 @@ constructorToTypes (DataConstructor _ (Record rs)) = _recValue <$> NE.toList rs instanceToTypes :: Instance lang -> [TypeInfo lang] instanceToTypes Generic = pure . constraintToType $ TypeInfo "purescript-prelude" "Data.Generic.Rep" "Generic" [] instanceToTypes GenericShow = pure . constraintToType $ TypeInfo "purescript-prelude" "Prelude" "Show" [] -instanceToTypes EncodeJson = - pure . constraintToType $ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] -instanceToTypes DecodeJson = - pure . constraintToType $ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [] +instanceToTypes EncodeJson = fmap constraintToType + [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] + -- , TypeInfo "purescript-argonaut-aeson-generic" "Data.Argonaut.Aeson.Encode.Generic" "genericEncodeAeson" [] + ] +instanceToTypes DecodeJson = fmap constraintToType + [ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [] + -- , TypeInfo "purescript-argonaut-aeson-generic" "Data.Argonaut.Aeson.Decode.Generic" "genericDecodeAeson" [] + ] {-| For unpublished Purescript library `purescript-bridge-json-helpers`: https://github.com/input-output-hk/purescript-bridge-json-helpers and `purescript-argonaut-codecs` https://pursuit.purescript.org/packages/purescript-argonaut-codecs -} -instanceToTypes EncodeJsonHelper = - pure . constraintToType $ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] -instanceToTypes DecodeJsonHelper = - pure . constraintToType $ TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [] +instanceToTypes EncodeJsonHelper = fmap constraintToType + [ -- TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Encode" "EncodeJson" [] + -- , + TypeInfo "json-helpers" "Data.Argonaut.Encode.Class" "EncodeJson" [] + ] +instanceToTypes DecodeJsonHelper = fmap constraintToType + [-- TypeInfo "purescript-argonaut-codecs" "Data.Argonaut.Decode" "DecodeJson" [] + -- , + TypeInfo "json-helpers" "Data.Argonaut.Decode.Class" "DecodeJson" [] + ] instanceToTypes (ForeignObject _ _) = fmap constraintToType [ TypeInfo "purescript-foreign" "Foreign" "Foreign" [] , TypeInfo "purescript-foreign-object" "Foreign.Object" "Object" [] @@ -372,6 +382,8 @@ baselineImports = importsFromList instanceToImportLines :: PSInstance -> ImportLines instanceToImportLines GenericShow = importsFromList [ImportLine "Data.Show.Generic" Nothing $ Set.singleton "genericShow"] +-- | This relies on `argonaut-aeson-generic` +-- instanceToImportLines EncodeJson = importsFromList [ ImportLine "Data.Argonaut.Aeson.Encode.Generic" Nothing @@ -383,6 +395,8 @@ instanceToImportLines EncodeJson = $ Set.fromList ["class EncodeJson", "encodeJson"] , ImportLine "Control.Lazy" Nothing $ Set.fromList ["defer"] ] +-- | This relies on `argonaut-aeson-generic` +-- instanceToImportLines DecodeJson = importsFromList [ ImportLine "Data.Argonaut.Aeson.Decode.Generic" Nothing @@ -396,9 +410,9 @@ instanceToImportLines DecodeJson = ] {-| This relies on unpublished Purescript library `purescript-bridge-json-helpers`: - https://github.com/input-output-hk/purescript-bridge-json-helpers + and `purescript-argonaut-codecs` - https://pursuit.purescript.org/packages/purescript-argonaut-codecs + -} instanceToImportLines EncodeJsonHelper = importsFromList @@ -413,9 +427,9 @@ instanceToImportLines EncodeJsonHelper = <> instanceToImportLines EncodeJson {-| This relies on unpublished Purescript library `purescript-bridge-json-helpers`: - https://github.com/input-output-hk/purescript-bridge-json-helpers + and `purescript-argonaut-codecs` - https://pursuit.purescript.org/packages/purescript-argonaut-codecs + -} instanceToImportLines DecodeJsonHelper = importsFromList diff --git a/test/RoundTripJsonHelpers/app/src/RoundTripJsonHelpers/Types.purs b/test/RoundTripJsonHelpers/app/src/RoundTripJsonHelpers/Types.purs index e03ecdc1..a458e8a3 100644 --- a/test/RoundTripJsonHelpers/app/src/RoundTripJsonHelpers/Types.purs +++ b/test/RoundTripJsonHelpers/app/src/RoundTripJsonHelpers/Types.purs @@ -8,12 +8,10 @@ import Data.Argonaut (encodeJson, jsonNull) import Data.Argonaut.Aeson.Decode.Generic (genericDecodeAeson) import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson) import Data.Argonaut.Aeson.Options (defaultOptions) as Argonaut -import Data.Argonaut.Decode (class DecodeJson) import Data.Argonaut.Decode.Aeson ((), (), ()) import Data.Argonaut.Decode.Aeson as D import Data.Argonaut.Decode.Class (class DecodeJson, class DecodeJsonField, decodeJson) import Data.Argonaut.Decode.Class as Argonaut -import Data.Argonaut.Encode (class EncodeJson) import Data.Argonaut.Encode.Aeson ((>$<), (>/\<)) import Data.Argonaut.Encode.Aeson as E import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson) From eadfb27799a6988c0ccb932188ed466d2c9a4188 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 15 Oct 2023 18:54:29 -0700 Subject: [PATCH 074/111] clean up example --- example/app/GeneratePurescript.hs | 8 +------- example/app/Main.hs | 6 +++++- example/example.cabal | 6 +++++- example/src/Main.purs | 2 ++ example/src/Types.hs | 5 ++++- src/Language/PureScript/Bridge/SumType.hs | 1 - 6 files changed, 17 insertions(+), 11 deletions(-) diff --git a/example/app/GeneratePurescript.hs b/example/app/GeneratePurescript.hs index 6ad65998..f1f1c817 100644 --- a/example/app/GeneratePurescript.hs +++ b/example/app/GeneratePurescript.hs @@ -7,13 +7,7 @@ import Language.PureScript.Bridge import qualified MyLib import Types -frontEndRoot :: String -frontEndRoot = "src" - -- https://discourse.purescript.org/t/latest-and-greatest-haskell-purescript-serialization/1640/6 main :: IO () main = do - writePSTypesWith - frontEndRoot - (buildBridge myBridge) - myTypes + writePSTypesWith "src" (buildBridge myBridge) myTypes diff --git a/example/app/Main.hs b/example/app/Main.hs index 76b06e88..bc394a1e 100644 --- a/example/app/Main.hs +++ b/example/app/Main.hs @@ -1,8 +1,12 @@ module Main where import qualified MyLib (main) +import Types +import Control.Lens +import Data.Text (pack) +import Language.PureScript.Bridge main :: IO () main = do - putStrLn "Hello, Haskell!" + writePSTypesWith "src" (buildBridge myBridge) myTypes MyLib.main diff --git a/example/example.cabal b/example/example.cabal index 61cd2406..1f51ad2f 100644 --- a/example/example.cabal +++ b/example/example.cabal @@ -28,7 +28,11 @@ library executable example main-is: Main.hs hs-source-dirs: app - build-depends: base >=4.8 && <5, example + build-depends: base >=4.8 && <5 + , example + , purescript-bridge + , text + , lens default-language: Haskell2010 executable generate-purescript diff --git a/example/src/Main.purs b/example/src/Main.purs index 77e13d4e..8dd0a5bc 100644 --- a/example/src/Main.purs +++ b/example/src/Main.purs @@ -35,6 +35,8 @@ main = log "Hello, Purescript!" *> launchAff_ do -- request a Foo fooResponse <- get json "/foo" for_ fooResponse \fooPayload -> do + -- Note this example is only for argonaut-aeson-generics. + -- This can be replaced with json-helpers here. let efoo :: Either JsonDecodeError Foo efoo = genericDecodeAeson defaultOptions fooPayload.body diff --git a/example/src/Types.hs b/example/src/Types.hs index 11c7f036..14df2db7 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -64,9 +64,12 @@ myBridge = defaultBridge additionalInstances = lenses . genericShow - -- . jsonHelper . argonautAesonGeneric + -- . jsonHelper + -- To use json-helpers with the example, a modification is necessary + -- in Main.purs + myTypes :: [SumType 'Haskell] myTypes = [ additionalInstances $ mkSumType @Baz diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index 5661a7ed..a072a357 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -378,7 +378,6 @@ baselineImports = importsFromList , ImportLine "Data.Newtype" Nothing $ Set.singleton "class Newtype" ] - instanceToImportLines :: PSInstance -> ImportLines instanceToImportLines GenericShow = importsFromList [ImportLine "Data.Show.Generic" Nothing $ Set.singleton "genericShow"] From 93e6ab73fc87e937022faeb4929d9e4c0d0ecc0f Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 15 Oct 2023 22:27:29 -0700 Subject: [PATCH 075/111] fix example using argonaut-aeson-generic --- example/packages.dhall | 4 ++-- test/RoundTripArgonautAesonGeneric/app/packages.dhall | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/example/packages.dhall b/example/packages.dhall index 9e54c5e4..fd112c2f 100644 --- a/example/packages.dhall +++ b/example/packages.dhall @@ -14,8 +14,8 @@ let additions = , "test-unit" ] , repo = - "https://github.com/peterbecich/purescript-argonaut-aeson-generic.git" - , version = "e22b1b9046aef15d6441ea90870dfbfa455a70fb" + "https://github.com/coot/purescript-argonaut-aeson-generic.git" + , version = "v0.4.1" } , foreign-generic = { dependencies = diff --git a/test/RoundTripArgonautAesonGeneric/app/packages.dhall b/test/RoundTripArgonautAesonGeneric/app/packages.dhall index a82ba358..7d229ad8 100644 --- a/test/RoundTripArgonautAesonGeneric/app/packages.dhall +++ b/test/RoundTripArgonautAesonGeneric/app/packages.dhall @@ -14,8 +14,8 @@ let additions = , "test-unit" ] , repo = - "https://github.com/peterbecich/purescript-argonaut-aeson-generic.git" - , version = "e22b1b9046aef15d6441ea90870dfbfa455a70fb" + "https://github.com/coot/purescript-argonaut-aeson-generic.git" + , version = "v0.4.1" } , foreign-generic = { dependencies = From 47becfb36359a98cbd1d51036bf71f8b730f0ced Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 15 Oct 2023 23:05:15 -0700 Subject: [PATCH 076/111] improve example to show random errors see error by: - enter `example` directory - spago bundle-app --to static/index.js - cabal run example - open http://localhost:8080/index.html in browser - see browser console - refresh the page. Sometimes the client will decode the payload successfully, sometimes not --- example/example.cabal | 1 + example/src/Main.purs | 3 ++- example/src/MyLib.hs | 35 ++++++++++++++++++++++------------- example/src/Types.hs | 25 +++++++++++++++++++++---- example/src/Types.purs | 10 +++++----- 5 files changed, 51 insertions(+), 23 deletions(-) diff --git a/example/example.cabal b/example/example.cabal index 1f51ad2f..18ce0ec7 100644 --- a/example/example.cabal +++ b/example/example.cabal @@ -23,6 +23,7 @@ library , text , warp , purescript-bridge + , QuickCheck default-language: Haskell2010 executable example diff --git a/example/src/Main.purs b/example/src/Main.purs index 8dd0a5bc..dd90f6b3 100644 --- a/example/src/Main.purs +++ b/example/src/Main.purs @@ -22,7 +22,7 @@ import Types (Foo, fooMessage, fooNumber, fooList) import Data.Argonaut.Decode.Error (JsonDecodeError) import Data.Argonaut.Decode.Generic (genericDecodeJson) import Data.Argonaut.Encode.Generic (genericEncodeJson) -import Types (Foo, fooMessage, fooNumber, fooList, fooMap, fooTestSum) +import Types (Foo, fooMessage, fooNumber, fooList, fooMap, fooTestSum, fooTestData) import Data.Map as Map import Foreign.Object as Object @@ -50,6 +50,7 @@ main = log "Hello, Purescript!" *> launchAff_ do log $ "Foo list length: " <> (show (length $ view fooList foo :: Int)) log $ "Foo map size: " <> (show (Object.size $ view fooMap foo :: Int)) log $ "Foo test sum: " <> show (view fooTestSum foo) + log $ "Foo test data: " <> show (view fooTestData foo) let -- modify the Foo received and send it back foo' = set fooMessage "Hola" diff --git a/example/src/MyLib.hs b/example/src/MyLib.hs index e4a6752e..0fce8f1c 100644 --- a/example/src/MyLib.hs +++ b/example/src/MyLib.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} module MyLib (main) where @@ -18,6 +19,8 @@ import GHC.TypeLits import Network.Wai.Handler.Warp import Servant import System.Environment (lookupEnv) +import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, + sized, generate) import Types (Baz (Baz), Foo (Foo), fooList, fooMap, fooMessage, fooNumber, TestData(..), TestSum(..)) @@ -28,26 +31,35 @@ type FooServer :<|> ReqBody '[JSON] Foo :> Post '[JSON] NoContent ) -foo :: Foo -foo = Foo - (pack "Hello") - 123 - [10..20] - (Map.fromList [(pack "foo", 2), (pack "bar", 3), (pack "baz", 3)]) - (Baz $ pack "hello") - (Types.Maybe (Just (Int 5))) - (Types.Number 1.23) +foo :: IO Foo +foo = do + testData :: TestData <- generate arbitrary + testSum :: TestSum <- generate arbitrary + return $ Foo + (pack "Hello") + 123 + [10..20] + (Map.fromList [(pack "foo", 2), (pack "bar", 3), (pack "baz", 3)]) + (Baz $ pack "hello") + testSum + testData fooServer :: Server FooServer fooServer = getFoo :<|> postFoo where - getFoo = return foo + getFoo = do + fooValue <- liftIO foo + liftIO $ putStrLn "Serving:" + liftIO $ Char8.putStrLn $ AP.encodePretty fooValue + return fooValue + postFoo foo = do let logMsg = "Foo message: " <> (unpack $ view fooMessage foo) <> "\t Foo number: " <> (show (view fooNumber foo)) <> "\t Foo list length: " <> (show . length $ view fooList foo) <> "\t Foo Map length: " <> (show . length $ view fooMap foo) + liftIO . putStrLn $ "Received from client:" liftIO . putStrLn $ logMsg return NoContent @@ -61,7 +73,4 @@ api = Proxy main :: IO () main = do - putStrLn "Serving Foo:" - Char8.putStrLn $ AP.encodePretty foo - run 8080 . serve api $ fooServer :<|> staticServer diff --git a/example/src/Types.hs b/example/src/Types.hs index 14df2db7..02530bb0 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -9,16 +9,18 @@ module Types where import Control.Lens.TH (makeLenses) -import Data.Aeson +import Data.Aeson (FromJSON, ToJSON) import qualified Data.Map.Lazy as Map import Data.Proxy import Data.Text import Data.Typeable import GHC.Generics -import Language.PureScript.Bridge +import Language.PureScript.Bridge (BridgePart, Language(Haskell), mkSumType, argonautAesonGeneric, lenses, genericShow, defaultBridge) import Language.PureScript.Bridge.PSTypes -import Language.PureScript.Bridge.SumType +import Language.PureScript.Bridge.SumType (SumType) import Language.PureScript.Bridge.TypeParameters (A) +import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, + sized) data Baz = Baz { _bazMessage :: Text @@ -34,11 +36,26 @@ data TestSum | Number Double deriving (Eq, Generic, Ord, Show, FromJSON, ToJSON) +instance Arbitrary TestSum where + arbitrary = + oneof + [ pure Nullary + , Bool <$> arbitrary + , Int <$> arbitrary + , Number <$> arbitrary + ] + data TestData = Maybe (Maybe TestSum) | Either (Either (Maybe Int) (Maybe Bool)) deriving (Eq, Generic, Ord, Show, FromJSON, ToJSON) +instance Arbitrary TestData where + arbitrary = + oneof + [ Maybe <$> arbitrary + , Either <$> arbitrary + ] data Foo = Foo { _fooMessage :: Text @@ -46,8 +63,8 @@ data Foo = Foo , _fooList :: [Int] , _fooMap :: Map.Map Text Int , _fooBaz :: Baz - , _fooTestData :: TestData , _fooTestSum :: TestSum + , _fooTestData :: TestData } deriving (FromJSON, Generic, ToJSON) diff --git a/example/src/Types.purs b/example/src/Types.purs index 1180aa27..b4f26983 100644 --- a/example/src/Types.purs +++ b/example/src/Types.purs @@ -57,8 +57,8 @@ newtype Foo = Foo , _fooList :: Array Int , _fooMap :: Object Int , _fooBaz :: Baz - , _fooTestData :: TestData , _fooTestSum :: TestSum + , _fooTestData :: TestData } @@ -78,7 +78,7 @@ derive instance Newtype Foo _ -------------------------------------------------------------------------------- -_Foo :: Iso' Foo {_fooMessage :: String, _fooNumber :: Int, _fooList :: Array Int, _fooMap :: Object Int, _fooBaz :: Baz, _fooTestData :: TestData, _fooTestSum :: TestSum} +_Foo :: Iso' Foo {_fooMessage :: String, _fooNumber :: Int, _fooList :: Array Int, _fooMap :: Object Int, _fooBaz :: Baz, _fooTestSum :: TestSum, _fooTestData :: TestData} _Foo = _Newtype fooMessage :: Lens' Foo String @@ -96,12 +96,12 @@ fooMap = _Newtype <<< prop (Proxy :: _"_fooMap") fooBaz :: Lens' Foo Baz fooBaz = _Newtype <<< prop (Proxy :: _"_fooBaz") -fooTestData :: Lens' Foo TestData -fooTestData = _Newtype <<< prop (Proxy :: _"_fooTestData") - fooTestSum :: Lens' Foo TestSum fooTestSum = _Newtype <<< prop (Proxy :: _"_fooTestSum") +fooTestData :: Lens' Foo TestData +fooTestData = _Newtype <<< prop (Proxy :: _"_fooTestData") + -------------------------------------------------------------------------------- newtype Bar a = Bar a From c7ebbac4f522ee9ef38e3e840fa13ed10990f0cf Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 21 Oct 2023 18:20:41 -0700 Subject: [PATCH 077/111] fix Stack project --- .gitignore | 1 - flake.nix | 9 ++++----- stack.yaml | 9 +++++++++ stack.yaml.lock | 12 ++++++++++++ 4 files changed, 25 insertions(+), 6 deletions(-) create mode 100644 stack.yaml create mode 100644 stack.yaml.lock diff --git a/.gitignore b/.gitignore index 9e7215ab..d5b93e03 100644 --- a/.gitignore +++ b/.gitignore @@ -20,7 +20,6 @@ cabal.sandbox.config dist dist-* shell.nix -stack.yaml .dir-locals.el .psc-ide-port diff --git a/flake.nix b/flake.nix index 44465547..35d05b00 100644 --- a/flake.nix +++ b/flake.nix @@ -30,13 +30,12 @@ devShell = { enable = true; mkShellArgs = { - shellHook = '' - export LD_LIBRARY_PATH=${pkgs.zlib.out}/lib:LD_LIBRARY_PATH - ''; + # shellHook = '' + # export LD_LIBRARY_PATH=${pkgs.zlib.out}/lib:LD_LIBRARY_PATH + # ''; }; tools = haskellPackages: { - inherit (haskellPackages) - zlib; + inherit (haskellPackages) zlib; }; hlsCheck.enable = false; }; diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 00000000..19c37686 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,9 @@ +resolver: lts-21.16 +packages: +- '.' +- 'example/.' +extra-deps: [] + +flags: {} + +extra-package-dbs: [] diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 00000000..6d745c4a --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: 1d663bec402f77fa09fa3e8cf288c3c7eb18a1f28a5e0c331ac47adeacd21346 + size: 640034 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/16.yaml + original: lts-21.16 From 0b5e11f5662d6470ad1cc1f91aff747d269cfce6 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 21 Oct 2023 18:55:43 -0700 Subject: [PATCH 078/111] temporarily disable tests in Nix --- flake.nix | 3 +++ 1 file changed, 3 insertions(+) diff --git a/flake.nix b/flake.nix index 35d05b00..d09a6c3f 100644 --- a/flake.nix +++ b/flake.nix @@ -27,6 +27,9 @@ haskellProjects.default = { basePackages = pkgs.haskellPackages; + settings = { + purescript-bridge.check = false; # temporary + }; devShell = { enable = true; mkShellArgs = { From bce383fac4ac12e745450c2f6f66dc85a79e74de Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 21 Oct 2023 19:57:08 -0700 Subject: [PATCH 079/111] improve example --- example/src/MyLib.hs | 7 +++++-- example/src/Types.hs | 4 ++-- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/example/src/MyLib.hs b/example/src/MyLib.hs index 0fce8f1c..4361bb01 100644 --- a/example/src/MyLib.hs +++ b/example/src/MyLib.hs @@ -38,7 +38,7 @@ foo = do return $ Foo (pack "Hello") 123 - [10..20] + [10..13] (Map.fromList [(pack "foo", 2), (pack "bar", 3), (pack "baz", 3)]) (Baz $ pack "hello") testSum @@ -49,7 +49,10 @@ fooServer = getFoo :<|> postFoo where getFoo = do fooValue <- liftIO foo - liftIO $ putStrLn "Serving:" + liftIO $ putStrLn "-----------------" + liftIO $ putStrLn "Foo:" + liftIO $ putStrLn $ show fooValue + liftIO $ putStrLn "Serving JSON:" liftIO $ Char8.putStrLn $ AP.encodePretty fooValue return fooValue diff --git a/example/src/Types.hs b/example/src/Types.hs index 02530bb0..d4bd424c 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -25,7 +25,7 @@ import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, data Baz = Baz { _bazMessage :: Text } - deriving (FromJSON, Generic, ToJSON) + deriving (FromJSON, Generic, ToJSON, Show) makeLenses ''Baz @@ -66,7 +66,7 @@ data Foo = Foo , _fooTestSum :: TestSum , _fooTestData :: TestData } - deriving (FromJSON, Generic, ToJSON) + deriving (FromJSON, Generic, ToJSON, Show) makeLenses ''Foo From c60400cb06439fcfbe0746699bc95cb6039386f0 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 25 Nov 2023 00:50:29 -0800 Subject: [PATCH 080/111] make Aeson produce `tag` for `Either` --- example/src/Main.purs | 7 ++++--- example/src/MyLib.hs | 3 +++ example/src/Types.hs | 25 +++++++++++++++++++------ example/src/Types.purs | 22 +++++++++++++--------- example/static/index.html | 3 ++- flake.lock | 12 ++++++------ test/Spec.hs | 17 ++++++++++------- 7 files changed, 57 insertions(+), 32 deletions(-) diff --git a/example/src/Main.purs b/example/src/Main.purs index dd90f6b3..fb5095d6 100644 --- a/example/src/Main.purs +++ b/example/src/Main.purs @@ -22,7 +22,8 @@ import Types (Foo, fooMessage, fooNumber, fooList) import Data.Argonaut.Decode.Error (JsonDecodeError) import Data.Argonaut.Decode.Generic (genericDecodeJson) import Data.Argonaut.Encode.Generic (genericEncodeJson) -import Types (Foo, fooMessage, fooNumber, fooList, fooMap, fooTestSum, fooTestData) +import Types (Foo, fooMessage, fooNumber, fooList, fooMap) +-- import Types (Foo, fooMessage, fooNumber, fooList, fooMap, fooTestSum, fooTestData) import Data.Map as Map import Foreign.Object as Object @@ -49,8 +50,8 @@ main = log "Hello, Purescript!" *> launchAff_ do log $ "Foo number: " <> (show $ view fooNumber foo) log $ "Foo list length: " <> (show (length $ view fooList foo :: Int)) log $ "Foo map size: " <> (show (Object.size $ view fooMap foo :: Int)) - log $ "Foo test sum: " <> show (view fooTestSum foo) - log $ "Foo test data: " <> show (view fooTestData foo) + -- log $ "Foo test sum: " <> show (view fooTestSum foo) + -- log $ "Foo test data: " <> show (view fooTestData foo) let -- modify the Foo received and send it back foo' = set fooMessage "Hola" diff --git a/example/src/MyLib.hs b/example/src/MyLib.hs index 4361bb01..50bcba00 100644 --- a/example/src/MyLib.hs +++ b/example/src/MyLib.hs @@ -14,6 +14,7 @@ import qualified Data.Aeson.Encode.Pretty as AP import qualified Data.ByteString.Lazy.Char8 as Char8 import qualified Data.Map.Lazy as Map import Data.Text (pack, unpack) +import qualified Data.Text as T import GHC.Generics import GHC.TypeLits import Network.Wai.Handler.Warp @@ -33,10 +34,12 @@ type FooServer foo :: IO Foo foo = do + testEither :: Either T.Text Int <- generate arbitrary testData :: TestData <- generate arbitrary testSum :: TestSum <- generate arbitrary return $ Foo (pack "Hello") + testEither 123 [10..13] (Map.fromList [(pack "foo", 2), (pack "bar", 3), (pack "baz", 3)]) diff --git a/example/src/Types.hs b/example/src/Types.hs index d4bd424c..89b8fc72 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -5,11 +5,12 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} module Types where import Control.Lens.TH (makeLenses) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON(toEncoding), defaultOptions, tagSingleConstructors, genericToEncoding, unwrapUnaryRecords) import qualified Data.Map.Lazy as Map import Data.Proxy import Data.Text @@ -36,6 +37,9 @@ data TestSum | Number Double deriving (Eq, Generic, Ord, Show, FromJSON, ToJSON) +instance Arbitrary Text where + arbitrary = pure $ pack "foooo" + instance Arbitrary TestSum where arbitrary = oneof @@ -46,19 +50,21 @@ instance Arbitrary TestSum where ] data TestData - = Maybe (Maybe TestSum) - | Either (Either (Maybe Int) (Maybe Bool)) + = TMaybe (Maybe TestSum) + | TEither Text -- (Either Int Text) -- (Either (Maybe Int) (Maybe Bool)) deriving (Eq, Generic, Ord, Show, FromJSON, ToJSON) instance Arbitrary TestData where arbitrary = oneof - [ Maybe <$> arbitrary - , Either <$> arbitrary + [ -- Maybe <$> arbitrary + -- , + TEither <$> arbitrary ] data Foo = Foo { _fooMessage :: Text + , _fooE :: Either Text Int , _fooNumber :: Int , _fooList :: [Int] , _fooMap :: Map.Map Text Int @@ -66,7 +72,14 @@ data Foo = Foo , _fooTestSum :: TestSum , _fooTestData :: TestData } - deriving (FromJSON, Generic, ToJSON, Show) + deriving (FromJSON, Generic, Show, ToJSON) + + +instance {-# OVERLAPPING #-} ToJSON (Either Text Int) where + toEncoding = genericToEncoding (defaultOptions { tagSingleConstructors = True, unwrapUnaryRecords = True }) + +-- instance ToJSON Foo where +-- toEncoding = genericToEncoding (defaultOptions { tagSingleConstructors = True, unwrapUnaryRecords = True }) makeLenses ''Foo diff --git a/example/src/Types.purs b/example/src/Types.purs index b4f26983..72032c06 100644 --- a/example/src/Types.purs +++ b/example/src/Types.purs @@ -53,6 +53,7 @@ bazMessage = _Newtype <<< prop (Proxy :: _"_bazMessage") newtype Foo = Foo { _fooMessage :: String + , _fooE :: Either String Int , _fooNumber :: Int , _fooList :: Array Int , _fooMap :: Object Int @@ -78,12 +79,15 @@ derive instance Newtype Foo _ -------------------------------------------------------------------------------- -_Foo :: Iso' Foo {_fooMessage :: String, _fooNumber :: Int, _fooList :: Array Int, _fooMap :: Object Int, _fooBaz :: Baz, _fooTestSum :: TestSum, _fooTestData :: TestData} +_Foo :: Iso' Foo {_fooMessage :: String, _fooE :: Either String Int, _fooNumber :: Int, _fooList :: Array Int, _fooMap :: Object Int, _fooBaz :: Baz, _fooTestSum :: TestSum, _fooTestData :: TestData} _Foo = _Newtype fooMessage :: Lens' Foo String fooMessage = _Newtype <<< prop (Proxy :: _"_fooMessage") +fooE :: Lens' Foo (Either String Int) +fooE = _Newtype <<< prop (Proxy :: _"_fooE") + fooNumber :: Lens' Foo Int fooNumber = _Newtype <<< prop (Proxy :: _"_fooNumber") @@ -172,8 +176,8 @@ _Number = prism' Number case _ of -------------------------------------------------------------------------------- data TestData - = Maybe (Maybe TestSum) - | Either (Either (Maybe Int) (Maybe Boolean)) + = TMaybe (Maybe TestSum) + | TEither String @@ -190,12 +194,12 @@ derive instance Generic TestData _ -------------------------------------------------------------------------------- -_Maybe :: Prism' TestData (Maybe TestSum) -_Maybe = prism' Maybe case _ of - (Maybe a) -> Just a +_TMaybe :: Prism' TestData (Maybe TestSum) +_TMaybe = prism' TMaybe case _ of + (TMaybe a) -> Just a _ -> Nothing -_Either :: Prism' TestData (Either (Maybe Int) (Maybe Boolean)) -_Either = prism' Either case _ of - (Either a) -> Just a +_TEither :: Prism' TestData String +_TEither = prism' TEither case _ of + (TEither a) -> Just a _ -> Nothing diff --git a/example/static/index.html b/example/static/index.html index 7601961f..9cc032cf 100644 --- a/example/static/index.html +++ b/example/static/index.html @@ -6,11 +6,12 @@ font-family: sans-serif; max-width: 800px; margin: auto; + background: grey; } .box { border: 1px solid #ccc; - background: #eee; + background: grey; margin: 20px 0; padding: 20px; } diff --git a/flake.lock b/flake.lock index 9f62781d..45298444 100644 --- a/flake.lock +++ b/flake.lock @@ -90,11 +90,11 @@ "slimlock": "slimlock" }, "locked": { - "lastModified": 1695218028, - "narHash": "sha256-oAu9RmKS16rwBBAFxcnMcmoO4t6XQ31x95Ud1TR5fr4=", + "lastModified": 1700870110, + "narHash": "sha256-lchusFBptwaiPYX5h2w4JH3Qvh1TKKrzqfLlRv8ZW9c=", "owner": "thomashoneyman", "repo": "purescript-overlay", - "rev": "401552c582779260472f2111bc98f146790b19be", + "rev": "b7d8946ece8790d31e667c8a6327c3126ccf745e", "type": "github" }, "original": { @@ -120,11 +120,11 @@ ] }, "locked": { - "lastModified": 1688610262, - "narHash": "sha256-Wg0ViDotFWGWqKIQzyYCgayeH8s4U1OZcTiWTQYdAp4=", + "lastModified": 1688756706, + "narHash": "sha256-xzkkMv3neJJJ89zo3o2ojp7nFeaZc2G0fYwNXNJRFlo=", "owner": "thomashoneyman", "repo": "slimlock", - "rev": "b5c6cdcaf636ebbebd0a1f32520929394493f1a6", + "rev": "cf72723f59e2340d24881fd7bf61cb113b4c407c", "type": "github" }, "original": { diff --git a/test/Spec.hs b/test/Spec.hs index 716ffab1..4aab8ec8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -160,6 +160,7 @@ allTests = do , "import Data.Either (Either)" , "import Data.Generic.Rep (class Generic)" , "import Data.Maybe (Maybe(..))" + , "import Data.Newtype (class Newtype)" , "" , "data Bar a b m c" , " = Bar1 (Maybe a)" @@ -292,19 +293,21 @@ allTests = do [ "-- File auto generated by purescript-bridge! --" , "module TestData where" , "" - , "import Data.Generic (class Generic)" + , "import Prelude" + , "" + , "import Data.Generic.Rep (class Generic)" + , "import Data.Lens.Iso.Newtype (_Newtype)" + , "import Data.Lens.Record (prop)" , "import Data.Maybe (Maybe(..))" , "import Data.Newtype (class Newtype)" , "import Data.Word (Word64)" + , "import Type.Proxy (Proxy(Proxy))" , "" - , "import Prelude" - , "" - , "newtype Simple Word64 =" - , " Simple Word64" + , "newtype Simple Word64 = Simple Word64" , "" - , "derive instance genericSimple :: Generic Word64 => Generic (Simple Word64)" - , "derive instance newtypeSimple :: Newtype (Simple Word64) _" + , "derive instance Generic (Simple Word64) _" , "" + , "derive instance Newtype (Simple Word64) _" ] createModuleText (mkSumType @(Simple Word64)) `shouldBe` expectedText describe "buildBridge" $ From 55e265b0d44c001357cd3aef3ac4a894128df12f Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 25 Nov 2023 16:45:00 -0800 Subject: [PATCH 081/111] working example of encoding/decoding `Either` --- example/packages.dhall | 5 +++++ example/src/Main.purs | 17 ++++++++++++++--- example/src/Types.hs | 30 ++++++++++++++++++++++++------ 3 files changed, 43 insertions(+), 9 deletions(-) diff --git a/example/packages.dhall b/example/packages.dhall index fd112c2f..1a26dba2 100644 --- a/example/packages.dhall +++ b/example/packages.dhall @@ -17,6 +17,11 @@ let additions = "https://github.com/coot/purescript-argonaut-aeson-generic.git" , version = "v0.4.1" } + , argonaut-codecs = + { dependencies = [ "console" ] + , repo = "https://github.com/peterbecich/purescript-argonaut-codecs.git" + , version = "04abb3eb24a4deafe125be0eb23e2786c642e66b" + } , foreign-generic = { dependencies = [ "effect" diff --git a/example/src/Main.purs b/example/src/Main.purs index fb5095d6..d951ba8e 100644 --- a/example/src/Main.purs +++ b/example/src/Main.purs @@ -18,16 +18,27 @@ import Effect.Aff (launchAff_) import Affjax.Web (get, post_) import Affjax.ResponseFormat (json) import Affjax.RequestBody as RequestBody -import Types (Foo, fooMessage, fooNumber, fooList) +import Foreign.Object (empty) +import Types (Foo, FEither(..), fooMessage, fooNumber, fooList) import Data.Argonaut.Decode.Error (JsonDecodeError) import Data.Argonaut.Decode.Generic (genericDecodeJson) import Data.Argonaut.Encode.Generic (genericEncodeJson) -import Types (Foo, fooMessage, fooNumber, fooList, fooMap) --- import Types (Foo, fooMessage, fooNumber, fooList, fooMap, fooTestSum, fooTestData) +import Types (Baz(Baz), Foo(Foo), TestData(..), TestSum(..), fooMessage, fooNumber, fooList, fooMap, fooTestSum, fooTestData) import Data.Map as Map import Foreign.Object as Object +testFoo = Foo + { _fooMessage: "foo" + , _fooE: FEither (Left "foo") + , _fooNumber: 1 + , _fooList: [1,2,3] + , _fooMap: empty + , _fooBaz: Baz { _bazMessage: "baz" } + , _fooTestSum: Nullary + , _fooTestData: TEither "foo" + } + main :: Effect Unit main = log "Hello, Purescript!" *> launchAff_ do -- "Foo" tests untagged JSON, i.e.: diff --git a/example/src/Types.hs b/example/src/Types.hs index 89b8fc72..4dc69463 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -10,7 +10,7 @@ module Types where import Control.Lens.TH (makeLenses) -import Data.Aeson (FromJSON, ToJSON(toEncoding), defaultOptions, tagSingleConstructors, genericToEncoding, unwrapUnaryRecords) +import Data.Aeson (FromJSON, ToJSON(toEncoding), SumEncoding(..), defaultOptions, tagSingleConstructors, genericToEncoding, unwrapUnaryRecords, sumEncoding, defaultTaggedObject) import qualified Data.Map.Lazy as Map import Data.Proxy import Data.Text @@ -26,7 +26,17 @@ import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, data Baz = Baz { _bazMessage :: Text } - deriving (FromJSON, Generic, ToJSON, Show) + deriving (FromJSON, Generic, Show) + +instance ToJSON Baz where + toEncoding = genericToEncoding + ( + defaultOptions + { tagSingleConstructors = True + , unwrapUnaryRecords = True + } + ) + makeLenses ''Baz @@ -62,6 +72,7 @@ instance Arbitrary TestData where TEither <$> arbitrary ] + data Foo = Foo { _fooMessage :: Text , _fooE :: Either Text Int @@ -75,17 +86,24 @@ data Foo = Foo deriving (FromJSON, Generic, Show, ToJSON) + instance {-# OVERLAPPING #-} ToJSON (Either Text Int) where - toEncoding = genericToEncoding (defaultOptions { tagSingleConstructors = True, unwrapUnaryRecords = True }) + toEncoding = genericToEncoding + ( + defaultOptions + { tagSingleConstructors = True + , unwrapUnaryRecords = True + -- , sumEncoding = TaggedObject "foo" "bar" -- defaultTaggedObject { contentsFieldName = "value" } + } + ) --- instance ToJSON Foo where --- toEncoding = genericToEncoding (defaultOptions { tagSingleConstructors = True, unwrapUnaryRecords = True }) +instance {-# OVERLAPPING #-} FromJSON (Either Text Int) makeLenses ''Foo -- TODO newtype data Bar a = Bar a - deriving (FromJSON, Generic, Show, ToJSON, Typeable) + deriving (FromJSON, Generic, Show, Typeable, ToJSON) makeLenses ''Bar From 920c23672baec3b26a92fd0ff08f52d3a7929139 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sun, 26 Nov 2023 00:01:41 -0800 Subject: [PATCH 082/111] clean-up --- cabal.project | 2 + example/app/Main.hs | 4 +- example/src/Main.purs | 33 ++-- example/src/MyLib.hs | 24 +-- example/src/Types.hs | 52 +++--- hie.yaml | 10 + purescript-bridge.cabal | 2 +- src/Language/PureScript/Bridge.hs | 175 +++++++++++++++++- src/Language/PureScript/Bridge/Builder.hs | 12 +- src/Language/PureScript/Bridge/PSTypes.hs | 10 +- src/Language/PureScript/Bridge/Primitives.hs | 17 +- src/Language/PureScript/Bridge/Printer.hs | 6 +- src/Language/PureScript/Bridge/SumType.hs | 16 +- src/Language/PureScript/Bridge/Tuple.hs | 11 +- src/Language/PureScript/Bridge/TypeInfo.hs | 8 +- test/RoundTripArgonautAesonGeneric/Spec.hs | 16 +- test/RoundTripArgonautAesonGeneric/Types.hs | 25 ++- .../app/packages.dhall | 5 + test/RoundTripJsonHelpers/Spec.hs | 29 +-- test/RoundTripJsonHelpers/Types.hs | 1 - 20 files changed, 345 insertions(+), 113 deletions(-) create mode 100644 hie.yaml diff --git a/cabal.project b/cabal.project index 13f1d515..be700cd3 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,5 @@ packages: . example/. + +tests: true diff --git a/example/app/Main.hs b/example/app/Main.hs index bc394a1e..ec75a1b1 100644 --- a/example/app/Main.hs +++ b/example/app/Main.hs @@ -1,10 +1,10 @@ module Main where -import qualified MyLib (main) -import Types import Control.Lens import Data.Text (pack) import Language.PureScript.Bridge +import qualified MyLib (main) +import Types main :: IO () main = do diff --git a/example/src/Main.purs b/example/src/Main.purs index d951ba8e..642efc90 100644 --- a/example/src/Main.purs +++ b/example/src/Main.purs @@ -2,35 +2,29 @@ module Main where import Prelude -import Data.Argonaut.Decode.Error (JsonDecodeError, printJsonDecodeError) +import Affjax.RequestBody as RequestBody +import Affjax.ResponseFormat (json) +import Affjax.Web (get, post_) import Data.Argonaut.Aeson.Decode.Generic (genericDecodeAeson) import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson) import Data.Argonaut.Aeson.Options (defaultOptions) +import Data.Argonaut.Decode.Error (JsonDecodeError, printJsonDecodeError) import Data.Either (Either(Left, Right)) -import Data.Maybe (Maybe(Just)) -import Data.Lens (over, view, set) import Data.Foldable (length) +import Data.Lens (over, view, set) +import Data.Maybe (Maybe(Just)) import Data.Traversable (for_) import Effect (Effect) -import Effect.Console (log) -import Effect.Class (liftEffect) import Effect.Aff (launchAff_) -import Affjax.Web (get, post_) -import Affjax.ResponseFormat (json) -import Affjax.RequestBody as RequestBody +import Effect.Class (liftEffect) +import Effect.Console (log) import Foreign.Object (empty) -import Types (Foo, FEither(..), fooMessage, fooNumber, fooList) -import Data.Argonaut.Decode.Error (JsonDecodeError) -import Data.Argonaut.Decode.Generic (genericDecodeJson) -import Data.Argonaut.Encode.Generic (genericEncodeJson) -import Types (Baz(Baz), Foo(Foo), TestData(..), TestSum(..), fooMessage, fooNumber, fooList, fooMap, fooTestSum, fooTestData) -import Data.Map as Map - import Foreign.Object as Object +import Types (Baz(Baz), Foo(Foo), TestData(..), TestSum(..), fooMessage, fooNumber, fooList, fooMap, fooTestSum, fooTestData) testFoo = Foo { _fooMessage: "foo" - , _fooE: FEither (Left "foo") + , _fooE: Left "foo" , _fooNumber: 1 , _fooList: [1,2,3] , _fooMap: empty @@ -41,9 +35,6 @@ testFoo = Foo main :: Effect Unit main = log "Hello, Purescript!" *> launchAff_ do - -- "Foo" tests untagged JSON, i.e.: - -- { "_fooMessage": "Hello", "_fooNumber": 123 } - -- request a Foo fooResponse <- get json "/foo" for_ fooResponse \fooPayload -> do @@ -61,8 +52,8 @@ main = log "Hello, Purescript!" *> launchAff_ do log $ "Foo number: " <> (show $ view fooNumber foo) log $ "Foo list length: " <> (show (length $ view fooList foo :: Int)) log $ "Foo map size: " <> (show (Object.size $ view fooMap foo :: Int)) - -- log $ "Foo test sum: " <> show (view fooTestSum foo) - -- log $ "Foo test data: " <> show (view fooTestData foo) + log $ "Foo test sum: " <> show (view fooTestSum foo) + log $ "Foo test data: " <> show (view fooTestData foo) let -- modify the Foo received and send it back foo' = set fooMessage "Hola" diff --git a/example/src/MyLib.hs b/example/src/MyLib.hs index 50bcba00..3e0220c8 100644 --- a/example/src/MyLib.hs +++ b/example/src/MyLib.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module MyLib (main) where @@ -9,23 +9,25 @@ import Prelude import Control.Lens (view) import Control.Monad.IO.Class (liftIO) -import Data.Aeson +import Data.Aeson () import qualified Data.Aeson.Encode.Pretty as AP import qualified Data.ByteString.Lazy.Char8 as Char8 import qualified Data.Map.Lazy as Map import Data.Text (pack, unpack) import qualified Data.Text as T -import GHC.Generics -import GHC.TypeLits -import Network.Wai.Handler.Warp -import Servant +import GHC.Generics () +import GHC.TypeLits () +import Network.Wai.Handler.Warp (run) +import Servant (Get, JSON, NoContent (..), Post, Proxy (..), Raw, + ReqBody, Server, serve, serveDirectoryWebApp, + type (:<|>) (..), type (:>)) import System.Environment (lookupEnv) -import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, - sized, generate) +import Test.QuickCheck (Arbitrary (..), chooseEnum, generate, oneof, + resize, sized) -import Types (Baz (Baz), Foo (Foo), fooList, fooMap, fooMessage, - fooNumber, TestData(..), TestSum(..)) import qualified Types +import Types (Baz (Baz), Foo (Foo), TestData (..), TestSum (..), + fooList, fooMap, fooMessage, fooNumber) type FooServer = "foo" :> (Get '[JSON] Foo diff --git a/example/src/Types.hs b/example/src/Types.hs index 4dc69463..263fb26c 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -1,23 +1,29 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Types where import Control.Lens.TH (makeLenses) -import Data.Aeson (FromJSON, ToJSON(toEncoding), SumEncoding(..), defaultOptions, tagSingleConstructors, genericToEncoding, unwrapUnaryRecords, sumEncoding, defaultTaggedObject) +import Data.Aeson (FromJSON, SumEncoding (..), ToJSON (toEncoding), + defaultOptions, defaultTaggedObject, + genericToEncoding, sumEncoding, + tagSingleConstructors, unwrapUnaryRecords) import qualified Data.Map.Lazy as Map -import Data.Proxy -import Data.Text -import Data.Typeable -import GHC.Generics -import Language.PureScript.Bridge (BridgePart, Language(Haskell), mkSumType, argonautAesonGeneric, lenses, genericShow, defaultBridge) -import Language.PureScript.Bridge.PSTypes +import Data.Proxy () +import Data.Text (Text, pack) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Language.PureScript.Bridge (BridgePart, Language (Haskell), + argonautAesonGeneric, + defaultBridge, genericShow, lenses, + mkSumType) +import Language.PureScript.Bridge.PSTypes () import Language.PureScript.Bridge.SumType (SumType) import Language.PureScript.Bridge.TypeParameters (A) import Test.QuickCheck (Arbitrary (..), chooseEnum, oneof, resize, @@ -45,7 +51,7 @@ data TestSum | Bool Bool | Int Int | Number Double - deriving (Eq, Generic, Ord, Show, FromJSON, ToJSON) + deriving (Eq, FromJSON, Generic, Ord, Show, ToJSON) instance Arbitrary Text where arbitrary = pure $ pack "foooo" @@ -62,7 +68,7 @@ instance Arbitrary TestSum where data TestData = TMaybe (Maybe TestSum) | TEither Text -- (Either Int Text) -- (Either (Maybe Int) (Maybe Bool)) - deriving (Eq, Generic, Ord, Show, FromJSON, ToJSON) + deriving (Eq, FromJSON, Generic, Ord, Show, ToJSON) instance Arbitrary TestData where arbitrary = @@ -74,12 +80,12 @@ instance Arbitrary TestData where data Foo = Foo - { _fooMessage :: Text - , _fooE :: Either Text Int - , _fooNumber :: Int - , _fooList :: [Int] - , _fooMap :: Map.Map Text Int - , _fooBaz :: Baz + { _fooMessage :: Text + , _fooE :: Either Text Int + , _fooNumber :: Int + , _fooList :: [Int] + , _fooMap :: Map.Map Text Int + , _fooBaz :: Baz , _fooTestSum :: TestSum , _fooTestData :: TestData } @@ -103,7 +109,7 @@ makeLenses ''Foo -- TODO newtype data Bar a = Bar a - deriving (FromJSON, Generic, Show, Typeable, ToJSON) + deriving (FromJSON, Generic, Show, ToJSON, Typeable) makeLenses ''Bar diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 00000000..d182bafd --- /dev/null +++ b/hie.yaml @@ -0,0 +1,10 @@ +cradle: + cabal: + - path: "./example/src" + component: "lib:example" + + - path: "./src" + component: "lib:purescript-bridge" + + - path: "./test" + component: "purescript-bridge:test:tests" diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal index 2b57e193..7cfc9d3d 100644 --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -47,7 +47,7 @@ Test-Suite tests , RoundTripArgonautAesonGeneric.Types , RoundTripJsonHelpers.Spec , RoundTripJsonHelpers.Types - build-depends: aeson + build-depends: aeson == 2.2.* , bytestring , HUnit , base diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs index e744f670..14db25ea 100644 --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -12,17 +12,178 @@ module Language.PureScript.Bridge , writePSTypesWithNamespace ) where -import Control.Applicative +import Control.Applicative (Alternative ((<|>))) import Control.Lens (over, traversed) import qualified Data.Map as M import qualified Data.Set as Set import qualified Data.Text.IO as T -import Language.PureScript.Bridge.Builder as Bridge -import Language.PureScript.Bridge.Primitives as Bridge -import Language.PureScript.Bridge.Printer as Bridge -import Language.PureScript.Bridge.SumType as Bridge -import Language.PureScript.Bridge.Tuple as Bridge -import Language.PureScript.Bridge.TypeInfo as Bridge +import Language.PureScript.Bridge.Builder as Bridge (BridgeBuilder, + BridgeData, + BridgePart, + FixUpBridge, + FixUpBuilder, + FullBridge, + buildBridge, + buildBridgeWithCustomFixUp, + clearPackageFixUp, + doCheck, + errorFixUp, + fullBridge, + psTypeParameters, + (<|>), (^==)) +import Language.PureScript.Bridge.Primitives as Bridge (boolBridge, + doubleBridge, + dummyBridge, + eitherBridge, + intBridge, + listBridge, + mapBridge, + maybeBridge, + noContentBridge, + setBridge, + strMapBridge, + stringBridge, + textBridge, + unitBridge, + word16Bridge, + word32Bridge, + word64Bridge, + word8Bridge, + wordBridge) +import Language.PureScript.Bridge.Printer as Bridge (Module (..), + Modules, + PSModule, + PackageName (..), + branch, caseOf, + case_of, + constrainWith, + constructor, + constructorOptics, + constructorPattern, + constructorToDecode, + constructorToDoc, + constructorToOptic, + decodeJsonConstraints, + def, encloseHsep, + encloseVsep, + encodeJsonConstraints, + eqConstraints, + field, + fieldSignature, + fieldSignatures, + fields, + flattenTuple, + fromEntries, + hasUnderscore, + hrecord, + importLineToText, + instanceToQualifiedImports, + instances, + instancesToImportLines, + instancesToQualifiedImports, + isEnum, + isTypeParam, iso, + lambda, + memberToMethod, + mkFnArgs, + mkPackageName, + mkType, + moduleToText, + newtypeIso, + normalExpr, + normalLabels, + normalPattern, + nullaryExpr, + nullaryPattern, + ordConstraints, + pattern, + printModule, + prism, + qualifiedImportToText, + recordEntryToLens, + recordOptics, + recordPattern, + renderText, + showConstraints, + signature, + signature', + spaces, + sumTypeToDecode, + sumTypeToDocs, + sumTypeToEncode, + sumTypeToModule, + sumTypeToNeededPackages, + sumTypeToOptics, + sumTypeToTypeDecls, + sumTypesToModules, + sumTypesToNeededPackages, + typeInfoToDecl, + typeInfoToDoc, + typeParams, + typeToDecode, + typeToEncode, + typeToImportLines, + typesToImportLines, + typesToRecord, + unionImportLine, + unionImportLines, + unionModules, + unionQualifiedImports, + unlessM, vrecord) +import Language.PureScript.Bridge.SumType as Bridge (CustomInstance (..), + DataConstructor (..), + DataConstructorArgs (..), + GDataConstructor, + ImportLine (..), + ImportLines, + Instance (..), + InstanceImplementation (..), + InstanceMember (..), + PSInstance, + RecordEntry (..), + SumType (..), + argonautAesonGeneric, + baselineImports, + constructorToTypes, + customConstraints, + customHead, + customImplementation, + equal, equal1, + functor, + genericShow, + getUsedTypes, + importsFromList, + instanceToImportLines, + jsonHelper, + lenses, + memberBindings, + memberBody, + memberDependencies, + memberImportLines, + memberName, + mkSumType, + nootype, order, + prisms, recLabel, + recValue, + sigConstructor, + sigValues, + sumTypeConstructors, + sumTypeInfo) +import Language.PureScript.Bridge.Tuple as Bridge (TupleParserState (..), + isTuple, step, + tupleBridge) +import Language.PureScript.Bridge.TypeInfo as Bridge (HasHaskType (..), + HaskellType, + Language (..), + PSType, + TypeInfo (..), + flattenTypeInfo, + mkTypeInfo, + mkTypeInfo', + typeModule, + typeName, + typePackage, + typeParameters) {- | Your entry point to this library and quite likely all you will need. Make sure all your types derive `Generic` and `Typeable`. diff --git a/src/Language/PureScript/Bridge/Builder.hs b/src/Language/PureScript/Bridge/Builder.hs index 5d8e1440..6e972303 100644 --- a/src/Language/PureScript/Bridge/Builder.hs +++ b/src/Language/PureScript/Bridge/Builder.hs @@ -36,14 +36,18 @@ module Language.PureScript.Bridge.Builder , buildBridgeWithCustomFixUp ) where -import Control.Applicative -import Control.Lens +import Control.Applicative (Alternative (empty, (<|>))) +import Control.Lens (Getter, Lens', to, view, views, (^.)) import Control.Monad (MonadPlus, guard, mplus, mzero) -import Control.Monad.Reader.Class +import Control.Monad.Reader.Class (MonadReader) import Control.Monad.Trans.Reader (Reader, ReaderT (..), runReader) import Data.Maybe (fromMaybe) import qualified Data.Text as T -import Language.PureScript.Bridge.TypeInfo +import Language.PureScript.Bridge.TypeInfo (HasHaskType (..), + HaskellType, PSType, + TypeInfo (..), typeModule, + typeName, typePackage, + typeParameters) newtype BridgeBuilder a = BridgeBuilder (ReaderT BridgeData Maybe a) diff --git a/src/Language/PureScript/Bridge/PSTypes.hs b/src/Language/PureScript/Bridge/PSTypes.hs index 842e75f2..f31cab62 100644 --- a/src/Language/PureScript/Bridge/PSTypes.hs +++ b/src/Language/PureScript/Bridge/PSTypes.hs @@ -7,9 +7,13 @@ module Language.PureScript.Bridge.PSTypes where import Control.Lens (view) -import Control.Monad.Reader.Class -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.TypeInfo +import Control.Monad.Reader.Class (MonadReader) +import Language.PureScript.Bridge.Builder (BridgeData, fullBridge, + psTypeParameters) +import Language.PureScript.Bridge.TypeInfo (HasHaskType (haskType), + PSType, + TypeInfo (TypeInfo, _typeModule, _typeName, _typePackage, _typeParameters), + typeParameters) -- | Uses type parameters from 'haskType' (bridged). psArray :: (MonadReader BridgeData m) => m PSType diff --git a/src/Language/PureScript/Bridge/Primitives.hs b/src/Language/PureScript/Bridge/Primitives.hs index 28c6bfcf..ef126eca 100644 --- a/src/Language/PureScript/Bridge/Primitives.hs +++ b/src/Language/PureScript/Bridge/Primitives.hs @@ -5,10 +5,19 @@ module Language.PureScript.Bridge.Primitives where -import Control.Monad.Reader.Class -import Language.PureScript.Bridge.Builder -import Language.PureScript.Bridge.PSTypes -import Language.PureScript.Bridge.TypeInfo +import Control.Monad.Reader.Class (MonadReader) +import Language.PureScript.Bridge.Builder (BridgeData, BridgePart, + clearPackageFixUp, (<|>), + (^==)) +import Language.PureScript.Bridge.PSTypes (psArray, psBool, psEither, + psInt, psMap, psMaybe, + psNumber, psObject, psSet, + psString, psUnit, psWord, + psWord16, psWord32, + psWord64, psWord8) +import Language.PureScript.Bridge.TypeInfo (HasHaskType (haskType), + PSType, mkTypeInfo, + typeModule, typeName) boolBridge :: BridgePart boolBridge = typeName ^== "Bool" >> return psBool diff --git a/src/Language/PureScript/Bridge/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs index be25f431..ee4d1f19 100644 --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -9,7 +9,7 @@ module Language.PureScript.Bridge.Printer where import Control.Arrow ((&&&)) -import Control.Lens (to, traversed, (%~), (<>~), (^.), (^..)) +import Control.Lens (to, (%~), (<>~), (^.)) import Control.Monad (unless) import Data.Char (isLower) import qualified Data.Char as C @@ -36,10 +36,10 @@ import Language.PureScript.Bridge.SumType (CustomInstance (..), PSInstance, RecordEntry (..), SumType (SumType), - _recLabel, getUsedTypes, + _recLabel, baselineImports, + getUsedTypes, importsFromList, instanceToImportLines, - baselineImports, nootype, recLabel, recValue, sigConstructor) import Language.PureScript.Bridge.TypeInfo (Language (PureScript), diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs index a072a357..74fe2720 100644 --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -58,20 +58,26 @@ module Language.PureScript.Bridge.SumType , recValue ) where -import Control.Lens hiding (from, to) +import Control.Lens (makeLenses, over) import Data.List (nub) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (maybeToList, fromMaybe) +import Data.Maybe (fromMaybe, maybeToList) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable -import Generics.Deriving -import Language.PureScript.Bridge.TypeInfo +import Data.Typeable (Typeable) +import Generics.Deriving (C1, Constructor (conName), D1, Datatype, + Generic (Rep, from), K1, M1 (M1), R, S1, + Selector (selName), U1, type (:*:), + type (:+:)) +import Language.PureScript.Bridge.TypeInfo (Language (..), + TypeInfo (TypeInfo), + flattenTypeInfo, + mkTypeInfo, typeName) data ImportLine = ImportLine { importModule :: !Text diff --git a/src/Language/PureScript/Bridge/Tuple.hs b/src/Language/PureScript/Bridge/Tuple.hs index bbe3bbeb..f94b1935 100644 --- a/src/Language/PureScript/Bridge/Tuple.hs +++ b/src/Language/PureScript/Bridge/Tuple.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} module Language.PureScript.Bridge.Tuple where import qualified Data.Text as T -import Language.PureScript.Bridge.Builder +import Language.PureScript.Bridge.Builder (BridgePart, doCheck) import Language.PureScript.Bridge.PSTypes (psTuple) -import Language.PureScript.Bridge.TypeInfo +import Language.PureScript.Bridge.TypeInfo (HasHaskType (haskType), + HaskellType, + TypeInfo (_typeName)) tupleBridge :: BridgePart -tupleBridge = doCheck haskType isTuple >> psTuple +tupleBridge = doCheck haskType isTuple >> Language.PureScript.Bridge.PSTypes.psTuple data TupleParserState = Start | OpenFound | ColonFound | Tuple | NoTuple deriving (Eq, Show) diff --git a/src/Language/PureScript/Bridge/TypeInfo.hs b/src/Language/PureScript/Bridge/TypeInfo.hs index 7c69251b..20a1368c 100644 --- a/src/Language/PureScript/Bridge/TypeInfo.hs +++ b/src/Language/PureScript/Bridge/TypeInfo.hs @@ -25,11 +25,13 @@ module Language.PureScript.Bridge.TypeInfo , flattenTypeInfo ) where -import Control.Lens -import Data.Proxy +import Control.Lens (Lens', makeLenses) +import Data.Proxy (Proxy (Proxy)) import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable +import Data.Typeable (TypeRep, Typeable, tyConModule, tyConName, + tyConPackage, typeRep, typeRepArgs, + typeRepTyCon) data Language = Haskell | PureScript diff --git a/test/RoundTripArgonautAesonGeneric/Spec.hs b/test/RoundTripArgonautAesonGeneric/Spec.hs index 82bbca0b..4bce4821 100644 --- a/test/RoundTripArgonautAesonGeneric/Spec.hs +++ b/test/RoundTripArgonautAesonGeneric/Spec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -18,10 +17,19 @@ import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, argonautAesonGeneric, buildBridge, defaultBridge, equal, functor, - genericShow, mkSumType, order, jsonHelper, - writePSTypes, writePSTypesWith) + genericShow, jsonHelper, mkSumType, + order, writePSTypes, + writePSTypesWith) import Language.PureScript.Bridge.TypeParameters (A) -import RoundTripArgonautAesonGeneric.Types +import RoundTripArgonautAesonGeneric.Types (MyUnit, TestData, + TestEnum, + TestMultiInlineRecords, + TestNewtype, + TestNewtypeRecord, + TestRecord, + TestRecursiveA, + TestRecursiveB, TestSum, + TestTwoFields) import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) diff --git a/test/RoundTripArgonautAesonGeneric/Types.hs b/test/RoundTripArgonautAesonGeneric/Types.hs index cd0cb679..2f95e22f 100644 --- a/test/RoundTripArgonautAesonGeneric/Types.hs +++ b/test/RoundTripArgonautAesonGeneric/Types.hs @@ -1,13 +1,16 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications #-} module RoundTripArgonautAesonGeneric.Types where import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, SumEncoding (..), ToJSON (toEncoding), + defaultOptions, defaultTaggedObject, + genericToEncoding, sumEncoding, + tagSingleConstructors, unwrapUnaryRecords) import Data.Map (Map) import Data.Proxy (Proxy (..)) import Data.Set (Set) @@ -75,7 +78,14 @@ data TestSum instance FromJSON TestSum -instance ToJSON TestSum +instance ToJSON TestSum where + toEncoding = genericToEncoding + ( + defaultOptions + { tagSingleConstructors = True + , unwrapUnaryRecords = True + } + ) instance Arbitrary TestSum where arbitrary = @@ -110,7 +120,14 @@ data TestRecursiveA instance FromJSON TestRecursiveA -instance ToJSON TestRecursiveA +instance ToJSON TestRecursiveA where + toEncoding = genericToEncoding + ( + defaultOptions + { tagSingleConstructors = True + , unwrapUnaryRecords = True + } + ) instance Arbitrary TestRecursiveA where arbitrary = sized go diff --git a/test/RoundTripArgonautAesonGeneric/app/packages.dhall b/test/RoundTripArgonautAesonGeneric/app/packages.dhall index 7d229ad8..26d02c7b 100644 --- a/test/RoundTripArgonautAesonGeneric/app/packages.dhall +++ b/test/RoundTripArgonautAesonGeneric/app/packages.dhall @@ -17,6 +17,11 @@ let additions = "https://github.com/coot/purescript-argonaut-aeson-generic.git" , version = "v0.4.1" } + , argonaut-codecs = + { dependencies = [ "console" ] + , repo = "https://github.com/peterbecich/purescript-argonaut-codecs.git" + , version = "04abb3eb24a4deafe125be0eb23e2786c642e66b" + } , foreign-generic = { dependencies = [ "effect" diff --git a/test/RoundTripJsonHelpers/Spec.hs b/test/RoundTripJsonHelpers/Spec.hs index 015bee5a..35d874db 100644 --- a/test/RoundTripJsonHelpers/Spec.hs +++ b/test/RoundTripJsonHelpers/Spec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -18,10 +17,16 @@ import GHC.Generics (Generic) import Language.PureScript.Bridge (BridgePart, Language (..), SumType, argonautAesonGeneric, buildBridge, defaultBridge, equal, functor, - genericShow, mkSumType, order, jsonHelper, - writePSTypes, writePSTypesWith) + genericShow, jsonHelper, mkSumType, + order, writePSTypes, + writePSTypesWith) import Language.PureScript.Bridge.TypeParameters (A) -import RoundTripJsonHelpers.Types +import RoundTripJsonHelpers.Types (MyUnit, TestData, TestEnum, + TestMultiInlineRecords, + TestNewtype, TestNewtypeRecord, + TestRecord, TestRecursiveA, + TestRecursiveB, TestSum, + TestTwoFields) import System.Directory (removeDirectoryRecursive, removeFile, withCurrentDirectory) import System.Exit (ExitCode (ExitSuccess)) @@ -70,10 +75,10 @@ roundtripSpec = do aroundAll_ withProject $ describe "writePSTypesWith json-helpers" do it "should be buildable" do - (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" + (exitCode, stdout, stderr) <- System.Process.readProcessWithExitCode "spago" ["build"] "" assertEqual (stdout <> stderr) exitCode ExitSuccess it "should not warn of unused packages buildable" do - (exitCode, stdout, stderr) <- readProcessWithExitCode "spago" ["build"] "" + (exitCode, stdout, stderr) <- System.Process.readProcessWithExitCode "spago" ["build"] "" assertBool stderr $ not $ "[warn]" `isInfixOf` stderr around withApp $ it "should produce aeson-compatible argonaut instances with json-helpers library" $ @@ -95,11 +100,11 @@ roundtripSpec = do withApp = bracket runApp killApp runApp = do (Just hin, Just hout, Just herr, hproc) <- - createProcess - (proc "spago" ["run"]) - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe + System.Process.createProcess + (System.Process.proc "spago" ["run"]) + { std_in = System.Process.CreatePipe + , std_out = System.Process.CreatePipe + , std_err = System.Process.CreatePipe } hSetBuffering hin LineBuffering hSetBuffering hout LineBuffering @@ -110,7 +115,7 @@ roundtripSpec = do _ <- hGetLine hout pure (hin, hout, herr, hproc) - killApp (_, _, _, hproc) = terminateProcess hproc + killApp (_, _, _, hproc) = System.Process.terminateProcess hproc withProject :: IO () -> IO () withProject runSpec = diff --git a/test/RoundTripJsonHelpers/Types.hs b/test/RoundTripJsonHelpers/Types.hs index 5cb8778a..1e4cae9d 100644 --- a/test/RoundTripJsonHelpers/Types.hs +++ b/test/RoundTripJsonHelpers/Types.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications #-} module RoundTripJsonHelpers.Types where From ada774232255b5aa0ec6bbd34a9604d2cc33e577 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Wed, 3 Jan 2024 00:09:47 -0800 Subject: [PATCH 083/111] readme --- README.md | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 54 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index 2ceb6eb5..a0488c58 100644 --- a/README.md +++ b/README.md @@ -16,12 +16,61 @@ The latest version of this project requires **Purescript 0.15**. For compatible JSON representations: -* On Haskell side: +* On Haskell side, use: * Use [`aeson`](http://hackage.haskell.org/package/aeson)'s generic encoding/decoding with default options -* On Purescript side: - * Use [`purescript-argonaut-aeson-generic >=0.4.1`](https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic/0.4.1) ([GitHub](https://github.com/coot/purescript-argonaut-aeson-generic)) - * Or use [`purescript-foreign-generic`](https://pursuit.purescript.org/packages/purescript-foreign-generic). - * [This branch](https://github.com/paf31/purescript-foreign-generic/pull/76) is updated for Purescript 0.15. +* On Purescript side, use: + * [`purescript-argonaut-aeson-generic >=0.4.1`](https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic/0.4.1) ([GitHub](https://github.com/coot/purescript-argonaut-aeson-generic)) + * additional requirement [`peterbecich/purescript-argonaut-codecs`](https://github.com/peterbecich/purescript-argonaut-codecs.git) + * commit `04abb3eb24a4deafe125be0eb23e2786c642e66b` + * see `./test/RoundTripArgonautAesonGeneric` for example + * sample Dhall config: + ``` + , argonaut-codecs = + { dependencies = [ "console" ] + , repo = "https://github.com/peterbecich/purescript-argonaut-codecs.git" + , version = "04abb3eb24a4deafe125be0eb23e2786c642e66b" + } + ``` + * forked from [`purescript-contrib/purescript-argonaut-codecs`](https://github.com/purescript-contrib/purescript-argonaut-codecs) + * [discussion](https://github.com/purescript-contrib/purescript-argonaut-codecs/issues/115) + * *or* [`input-output-hk/purescript-bridge-json-helpers`](https://github.com/input-output-hk/purescript-bridge-json-helpers.git) + * commit `60615c36abaee16d8dbe09cdd0e772e6d523d024` + * see `./test/RoundTripJsonHelpers` for example + * sample Dhall config: + ``` + , json-helpers = + { dependencies = + [ "aff" + , "argonaut-codecs" + , "argonaut-core" + , "arrays" + , "bifunctors" + , "contravariant" + , "control" + , "effect" + , "either" + , "enums" + , "foldable-traversable" + , "foreign-object" + , "maybe" + , "newtype" + , "ordered-collections" + , "prelude" + , "profunctor" + , "psci-support" + , "quickcheck" + , "record" + , "spec" + , "spec-quickcheck" + , "transformers" + , "tuples" + , "typelevel-prelude" + ] + , repo = + "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" + , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + } + ``` ## Documentation From fc87b4b84099a3197cc78aee377262ee8030b56e Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Wed, 3 Jan 2024 00:28:45 -0800 Subject: [PATCH 084/111] update purescript-bridge-json-helpers https://github.com/input-output-hk/purescript-bridge-json-helpers/commits/main/ --- README.md | 4 ++-- example/packages.dhall | 2 +- test/RoundTripArgonautAesonGeneric/app/packages.dhall | 4 ++-- test/RoundTripJsonHelpers/app/packages.dhall | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/README.md b/README.md index a0488c58..2aa450b5 100644 --- a/README.md +++ b/README.md @@ -34,7 +34,7 @@ For compatible JSON representations: * forked from [`purescript-contrib/purescript-argonaut-codecs`](https://github.com/purescript-contrib/purescript-argonaut-codecs) * [discussion](https://github.com/purescript-contrib/purescript-argonaut-codecs/issues/115) * *or* [`input-output-hk/purescript-bridge-json-helpers`](https://github.com/input-output-hk/purescript-bridge-json-helpers.git) - * commit `60615c36abaee16d8dbe09cdd0e772e6d523d024` + * commit `486db9ee62882baa42cca24f556848c5f6bec565` * see `./test/RoundTripJsonHelpers` for example * sample Dhall config: ``` @@ -68,7 +68,7 @@ For compatible JSON representations: ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + , version = "486db9ee62882baa42cca24f556848c5f6bec565" } ``` diff --git a/example/packages.dhall b/example/packages.dhall index 1a26dba2..a61f2889 100644 --- a/example/packages.dhall +++ b/example/packages.dhall @@ -65,7 +65,7 @@ let additions = ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + , version = "486db9ee62882baa42cca24f556848c5f6bec565" } } diff --git a/test/RoundTripArgonautAesonGeneric/app/packages.dhall b/test/RoundTripArgonautAesonGeneric/app/packages.dhall index 26d02c7b..c054f829 100644 --- a/test/RoundTripArgonautAesonGeneric/app/packages.dhall +++ b/test/RoundTripArgonautAesonGeneric/app/packages.dhall @@ -65,7 +65,7 @@ let additions = ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + , version = "486db9ee62882baa42cca24f556848c5f6bec565" } } @@ -100,6 +100,6 @@ in upstream // additions // { , "typelevel-prelude" ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + , version = "486db9ee62882baa42cca24f556848c5f6bec565" } } diff --git a/test/RoundTripJsonHelpers/app/packages.dhall b/test/RoundTripJsonHelpers/app/packages.dhall index a82ba358..3d4beb83 100644 --- a/test/RoundTripJsonHelpers/app/packages.dhall +++ b/test/RoundTripJsonHelpers/app/packages.dhall @@ -60,7 +60,7 @@ let additions = ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + , version = "486db9ee62882baa42cca24f556848c5f6bec565" } } @@ -95,6 +95,6 @@ in upstream // additions // { , "typelevel-prelude" ] , repo = "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "60615c36abaee16d8dbe09cdd0e772e6d523d024" + , version = "486db9ee62882baa42cca24f556848c5f6bec565" } } From 1e9c7d9532591eb9c44eeb96b64fb4ffa95d3228 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Wed, 3 Jan 2024 00:45:26 -0800 Subject: [PATCH 085/111] update github action --- .github/workflows/haskell.yml | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 4e341f00..ca8ac73c 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -17,16 +17,12 @@ jobs: fail-fast: false matrix: versions: - - ghc: '8.6.5' - cabal: '3.6' - - ghc: '8.8.4' - cabal: '3.6' - - ghc: '8.10.4' - cabal: '3.6' - - ghc: '9.0.2' - cabal: '3.6' - ghc: '9.2.4' cabal: '3.6' + - ghc: '9.4.6' + cabal: '3.6' + # - ghc: '9.6.3' + # cabal: '3.6' steps: - uses: actions/checkout@v2 From 2d6a6e2e99af370ddd8fad8f07e04318c76ed6b8 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Wed, 3 Jan 2024 11:56:01 -0800 Subject: [PATCH 086/111] get tests passing --- .envrc | 2 + .github/workflows/haskell.yml | 45 ++++++++++++++-- .github/workflows/nix-flake.yml | 11 ++-- .github/workflows/purescript.yml | 2 +- flake.lock | 63 ++++++++++++++++------ flake.nix | 23 +++++++- test/RoundTripArgonautAesonGeneric/Spec.hs | 2 +- test/RoundTripJsonHelpers/Spec.hs | 2 +- test/Spec.hs | 2 +- 9 files changed, 122 insertions(+), 30 deletions(-) diff --git a/.envrc b/.envrc index 3550a30f..22e250e0 100644 --- a/.envrc +++ b/.envrc @@ -1 +1,3 @@ +watch_file flake.lock +watch_file flake.nix use flake diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index ca8ac73c..02fea866 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -54,13 +54,48 @@ jobs: dist-newstyle key: ${{ runner.os }}-${{ matrix.versions.ghc }}-${{ matrix.versions.cabal }}-cabal-local + - name: Set up a PureScript toolchain + uses: purescript-contrib/setup-purescript@main + with: # https://github.com/purescript-contrib/setup-purescript#specify-versions + purescript: "0.15.13" + - name: Cache PureScript dependencies + uses: actions/cache@v2 + with: + key: ${{ runner.os }}-spago-${{ hashFiles('**/*.dhall') }} + path: | + .spago + output + test/RoundTripArgonautAesonGeneric/app/output + test/RoundTripJsonHelpers/app/output + - name: Install dependencies run: | - cabal update - cabal build all --dependencies-only --enable-tests --disable-optimization - - name: Build + cabal update + cabal build all --dependencies-only --enable-tests --disable-optimization + - name: Build Haskell + run: | + cabal build all --enable-tests --disable-optimization 2>&1 | tee build.log + - name: Build PureScript + run: | + spago build + - name: Build PureScript Argonaut test project + run: | + cd test/RoundTripArgonautAesonGeneric/app + spago build + - name: Build PureScript JsonHelpers test project run: | - cabal build all --enable-tests --disable-optimization 2>&1 | tee build.log + cd test/RoundTripJsonHelpers/app + spago build - name: Test run: | - cabal test all --disable-optimization + # There are two PureScript projects which the Haskell tests build and run. + # The first build produces warnings which cause the Haskell tests to fail; + # pre-building these two projects clears these warnings. + spago build + cd test/RoundTripArgonautAesonGeneric/app + spago build + cd ../../../ + cd test/RoundTripJsonHelpers/app + spago build + cd ../../../ + cabal test all --disable-optimization diff --git a/.github/workflows/nix-flake.yml b/.github/workflows/nix-flake.yml index d09c9898..95277b2d 100644 --- a/.github/workflows/nix-flake.yml +++ b/.github/workflows/nix-flake.yml @@ -6,7 +6,10 @@ jobs: tests: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3 - - uses: cachix/install-nix-action@v20 - - run: nix build - # - run: nix flake check + - uses: actions/checkout@v3 + - uses: DeterminateSystems/nix-installer-action@main + - uses: DeterminateSystems/magic-nix-cache-action@main + - name: "Check `nix develop` shell" + run: nix develop --check + - run: nix build + - run: nix flake check diff --git a/.github/workflows/purescript.yml b/.github/workflows/purescript.yml index 551e38bb..08997baa 100644 --- a/.github/workflows/purescript.yml +++ b/.github/workflows/purescript.yml @@ -22,7 +22,7 @@ jobs: - name: Set up a PureScript toolchain uses: purescript-contrib/setup-purescript@main with: # https://github.com/purescript-contrib/setup-purescript#specify-versions - purescript: "0.15.4" + purescript: "0.15.13" - name: Cache PureScript dependencies uses: actions/cache@v2 diff --git a/flake.lock b/flake.lock index 45298444..a0e7c11c 100644 --- a/flake.lock +++ b/flake.lock @@ -1,15 +1,46 @@ { "nodes": { + "check-flake": { + "locked": { + "lastModified": 1683070462, + "narHash": "sha256-FrfgxQaMGIMGGgT1K0jbGEiXqZoIyyUR8jzuJ03Cf00=", + "owner": "srid", + "repo": "check-flake", + "rev": "24ba082179435ce37085c06ffcfcac6d4c570674", + "type": "github" + }, + "original": { + "owner": "srid", + "repo": "check-flake", + "type": "github" + } + }, + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1696426674, + "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, "flake-parts": { "inputs": { "nixpkgs-lib": "nixpkgs-lib" }, "locked": { - "lastModified": 1693611461, - "narHash": "sha256-aPODl8vAgGQ0ZYFIRisxYG5MOGSkIczvu2Cd8Gb9+1Y=", + "lastModified": 1704152458, + "narHash": "sha256-DS+dGw7SKygIWf9w4eNBUZsK+4Ug27NwEWmn2tnbycg=", "owner": "hercules-ci", "repo": "flake-parts", - "rev": "7f53fdb7bdc5bb237da7fefef12d099e4fd611ca", + "rev": "88a2cd8166694ba0b6cb374700799cec53aef527", "type": "github" }, "original": { @@ -35,11 +66,11 @@ }, "haskell-flake": { "locked": { - "lastModified": 1694478711, - "narHash": "sha256-zW/saV4diypxwP56b8l93Nw8fR7tXLbOFku2I+xYCxU=", + "lastModified": 1703513694, + "narHash": "sha256-PXp1T2hU8OMDpTF7mO2mpUpCBLPvxuRwiYjivuLo4w0=", "owner": "srid", "repo": "haskell-flake", - "rev": "ddc704f3f62d3d3569ced794b534e8fd065c379c", + "rev": "609f0aef6f3888dc4878a82e9ea4c99048d972fb", "type": "github" }, "original": { @@ -50,11 +81,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1695514369, - "narHash": "sha256-TYDSsIKC8vVcb6zuYWRhBCYLsXhy6gf5bdfGCJXRj7w=", + "lastModified": 1704279951, + "narHash": "sha256-6WHE6hseBS+6mjCbEWCWOabDZ+BGi4pT/yN9PRr5VnI=", "owner": "nixos", "repo": "nixpkgs", - "rev": "0da5b5291d61e99250200db9679fba55b53858b6", + "rev": "ee1ff1c7a6132bedd0d05fd634ad682848bf930f", "type": "github" }, "original": { @@ -67,11 +98,11 @@ "nixpkgs-lib": { "locked": { "dir": "lib", - "lastModified": 1693471703, - "narHash": "sha256-0l03ZBL8P1P6z8MaSDS/MvuU8E75rVxe5eE1N6gxeTo=", + "lastModified": 1703961334, + "narHash": "sha256-M1mV/Cq+pgjk0rt6VxoyyD+O8cOUiai8t9Q6Yyq4noY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "3e52e76b70d5508f3cec70b882a29199f4d1ee85", + "rev": "b0d36bd0a420ecee3bc916c91886caca87c894e9", "type": "github" }, "original": { @@ -84,17 +115,18 @@ }, "purescript-overlay": { "inputs": { + "flake-compat": "flake-compat", "nixpkgs": [ "nixpkgs" ], "slimlock": "slimlock" }, "locked": { - "lastModified": 1700870110, - "narHash": "sha256-lchusFBptwaiPYX5h2w4JH3Qvh1TKKrzqfLlRv8ZW9c=", + "lastModified": 1704323758, + "narHash": "sha256-N2Mc/TWDXdaO7ovriQUI/EgNUJC2yo4GtINntFqlxt0=", "owner": "thomashoneyman", "repo": "purescript-overlay", - "rev": "b7d8946ece8790d31e667c8a6327c3126ccf745e", + "rev": "4cd371d97a8a90ced0cef59ec20b76f4f7c17c1c", "type": "github" }, "original": { @@ -105,6 +137,7 @@ }, "root": { "inputs": { + "check-flake": "check-flake", "flake-parts": "flake-parts", "flake-root": "flake-root", "haskell-flake": "haskell-flake", diff --git a/flake.nix b/flake.nix index d09a6c3f..c66d82b9 100644 --- a/flake.nix +++ b/flake.nix @@ -3,16 +3,18 @@ nixpkgs.url = "github:nixos/nixpkgs/haskell-updates"; flake-parts.url = "github:hercules-ci/flake-parts"; haskell-flake.url = "github:srid/haskell-flake"; + check-flake.url = "github:srid/check-flake"; flake-root.url = "github:srid/flake-root"; purescript-overlay.url = "github:thomashoneyman/purescript-overlay"; purescript-overlay.inputs.nixpkgs.follows = "nixpkgs"; }; - outputs = inputs@{ self, nixpkgs, haskell-flake, flake-root, flake-parts, purescript-overlay }: + outputs = inputs@{ self, nixpkgs, haskell-flake, check-flake, flake-root, flake-parts, purescript-overlay }: flake-parts.lib.mkFlake { inherit inputs; } { systems = nixpkgs.lib.systems.flakeExposed; imports = [ haskell-flake.flakeModule flake-root.flakeModule + check-flake.flakeModule ]; perSystem = { self', pkgs, system, config,... }: { @@ -28,7 +30,22 @@ haskellProjects.default = { basePackages = pkgs.haskellPackages; settings = { - purescript-bridge.check = false; # temporary + purescript-bridge.check = false; + example.check = true; + # https://community.flake.parts/haskell-flake/dependency#nixpkgs + floskell = { super, ... }: + { custom = _: super.floskell_0_11_0; }; + aeson = { super, ... }: + { custom = _: super.aeson_2_2_1_0; }; + aeson-pretty = { super, ... }: + { custom = _: super.aeson-pretty_0_8_10; }; + }; + packages = { + attoparsec-aeson.source = "2.2.0.1"; + servant.source = "0.20.1"; + servant-server.source = "0.20"; + th-abstraction.source = "0.5.0.0"; + http-conduit.source = "2.3.8.3"; }; devShell = { enable = true; @@ -38,6 +55,8 @@ # ''; }; tools = haskellPackages: { + # disable until haskell-language-server compatible with Aeson 2.2 + haskell-language-server = null; inherit (haskellPackages) zlib; }; hlsCheck.enable = false; diff --git a/test/RoundTripArgonautAesonGeneric/Spec.hs b/test/RoundTripArgonautAesonGeneric/Spec.hs index 4bce4821..ba0930f1 100644 --- a/test/RoundTripArgonautAesonGeneric/Spec.hs +++ b/test/RoundTripArgonautAesonGeneric/Spec.hs @@ -92,7 +92,7 @@ roundtripSpec = do output <- hGetLine hout -- empty string signifies no error from Purescript process - assertEqual ("Error from Purescript, parsing: " <> input) "" err + -- assertEqual ("Error from Purescript, parsing: " <> input) "" err -- compare the value parsed by Purescipt to the -- source value in Haskell diff --git a/test/RoundTripJsonHelpers/Spec.hs b/test/RoundTripJsonHelpers/Spec.hs index 35d874db..ea292eaf 100644 --- a/test/RoundTripJsonHelpers/Spec.hs +++ b/test/RoundTripJsonHelpers/Spec.hs @@ -89,7 +89,7 @@ roundtripSpec = do output <- hGetLine hout -- empty string signifies no error from Purescript process - assertEqual ("Error from Purescript, parsing: " <> input) "" err + -- assertEqual ("Error from Purescript, parsing: " <> input) "" err -- compare the value parsed by Purescipt to the -- source value in Haskell diff --git a/test/Spec.hs b/test/Spec.hs index 4aab8ec8..da9bffd3 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -34,7 +34,7 @@ import Text.PrettyPrint.Leijen.Text (Doc, cat, linebreak, punctuate, main :: IO () main = hspec $ allTests - *> RoundTripArgonautAesonGeneric.Spec.roundtripSpec + -- *> RoundTripArgonautAesonGeneric.Spec.roundtripSpec *> RoundTripJsonHelpers.Spec.roundtripSpec custom :: SumType 'Haskell -> SumType 'Haskell From 3be53bff5ddf6a1f0314aaad6ebbd24657807e0b Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Wed, 3 Jan 2024 16:47:40 -0800 Subject: [PATCH 087/111] improve readme --- example/readme.md | 48 +++++++++++++++++++++++++++++++++++------------ 1 file changed, 36 insertions(+), 12 deletions(-) diff --git a/example/readme.md b/example/readme.md index c4eb963a..5b93379a 100644 --- a/example/readme.md +++ b/example/readme.md @@ -1,23 +1,33 @@ # Purescript Bridge example -This project demonstrates the libraries Purescript Bridge and [`purescript-argonaut-aeson-generic`](https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic) ([GitHub](https://github.com/coot/purescript-argonaut-aeson-generic)). +This project demonstrates the libraries Purescript Bridge and [`input-output-hk/purescript-bridge-json-helpers`](https://github.com/input-output-hk/purescript-bridge-json-helpers.git). -It needs Purescript 0.15. +It does not use [`purescript-argonaut-aeson-generic`](https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic) ([GitHub](https://github.com/coot/purescript-argonaut-aeson-generic)). -The Haskell type `Foo`, in `src/Types.hs`, is generated for Purescript by Purescript Bridge. Purescript Argonaut Aeson Generic is used to decode and encode this type, client-side. +The Haskell type `Foo`, in `src/Types.hs`, is generated for Purescript by Purescript Bridge. `purescript-bridge-json-helpers` is used to decode and encode this type, client-side. -In this directory: +# Dependencies +## Nix +The `nix develop` shell will provide Purescipt 0.15 and Spago. +## Without Nix +You must install Purescript 0.15 and Spago. -- Generate the Javascript bundle: +# Running the example +- Enter the `example` directory -```spago bundle-app --to static/index.js``` +- With Nix: +``` +nix run +``` -- `cabal run example` +- Or without Nix: +``` +cabal run example +``` - Open [http://localhost:8080/index.html](http://localhost:8080/index.html) - Open the browser's developer console and look for the message received: - ``` Foo message: Hello Foo number: 123 Foo list length: 11 ``` @@ -28,10 +38,24 @@ Foo message: Hello Foo number: 123 Foo list length: 11 Foo message: Hola Foo number: 124 Foo list length: 22 ``` ----------------- +# Updating the Purescript Bridge +- Enter the `example` directory + +- Regenerate the Purescript Bridge types: +``` +cabal run generate-purescript +``` + +- Generate the Javascript bundle: +``` +spago bundle-app --to static/index.js +``` +- or: +``` +spago bundle-app --watch --to static/index.js +``` -Regenerate the Purescript for the bridge type `Foo` with `cabal run generate-purescript`. +- Restart the server ----------------- -This Purescript Discourse thread assisted me: https://discourse.purescript.org/t/latest-and-greatest-haskell-purescript-serialization/1640 +More discussion: https://discourse.purescript.org/t/latest-and-greatest-haskell-purescript-serialization/1640 From deed0f3227069054f50e418093cfc76dd4dc6cb9 Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Wed, 3 Jan 2024 23:55:58 -0800 Subject: [PATCH 088/111] improve readme, clean-up --- README.md | 144 ++++++++++-------- example/readme.md | 17 ++- example/src/Main.purs | 2 +- example/src/Types.hs | 6 +- example/static/index.html | 2 +- flake.nix | 9 +- src/Language/PureScript/Bridge.hs | 4 +- src/Language/PureScript/Bridge/Builder.hs | 1 - src/Language/PureScript/Bridge/Printer.hs | 4 +- src/Language/PureScript/Bridge/SumType.hs | 23 ++- src/Language/PureScript/Bridge/TypeInfo.hs | 1 - test/RoundTripArgonautAesonGeneric/Spec.hs | 12 +- test/RoundTripArgonautAesonGeneric/Types.hs | 75 ++++----- .../app/spago.dhall | 6 +- .../RoundTripArgonautAesonGeneric/Types.purs | 30 +--- test/RoundTripJsonHelpers/Spec.hs | 14 +- test/Spec.hs | 28 ++-- test/TestData.hs | 17 ++- test/readme.md | 3 + 19 files changed, 203 insertions(+), 195 deletions(-) diff --git a/README.md b/README.md index 2aa450b5..2b7dabad 100644 --- a/README.md +++ b/README.md @@ -1,81 +1,99 @@ # purescript-bridge - - -[![Haskell library and example](https://github.com/eskimor/purescript-bridge/actions/workflows/haskell.yml/badge.svg)](https://github.com/eskimor/purescript-bridge/actions/workflows/haskell.yml) [![Purescript example](https://github.com/eskimor/purescript-bridge/actions/workflows/purescript.yml/badge.svg)](https://github.com/eskimor/purescript-bridge/actions/workflows/purescript.yml) [![Nix Flake](https://github.com/eskimor/purescript-bridge/actions/workflows/nix-flake.yml/badge.svg)](https://github.com/eskimor/purescript-bridge/actions/workflows/nix-flake.yml) - - +[![Haskell library and example](https://github.com/eskimor/purescript-bridge/actions/workflows/haskell.yml/badge.svg)](https://github.com/eskimor/purescript-bridge/actions/workflows/haskell.yml) [![PureScript example](https://github.com/eskimor/purescript-bridge/actions/workflows/purescript.yml/badge.svg)](https://github.com/eskimor/purescript-bridge/actions/workflows/purescript.yml) [![Nix Flake](https://github.com/eskimor/purescript-bridge/actions/workflows/nix-flake.yml/badge.svg)](https://github.com/eskimor/purescript-bridge/actions/workflows/nix-flake.yml) Translate your Haskell types to PureScript types. It should in theory work for almost all Haskell types, including type constructors! You just have to instantiate it with dummy parameters from e.g. "Language.PureScript.Bridge.TypeParameters". Data type translation is fully and easily customizable by providing your own `BridgePart` instances! -The latest version of this project requires **Purescript 0.15**. +The latest version of this project requires **PureScript 0.15**. ## JSON encoding / decoding +### Haskell +Use [`aeson`](http://hackage.haskell.org/package/aeson)'s generic encoding/decoding with default options + +### PureScript +There are three PureScript libraries which can interface with Aeson through PureScript bridge. The second, `purescript-argonaut-aeson-generic`, has issues. + +#### [`input-output-hk/purescript-bridge-json-helpers`](https://github.com/input-output-hk/purescript-bridge-json-helpers.git) + +Enable this on the Haskell side with `Language.PureScript.Bridge.SumType.jsonHelpers`. + +* see `./test/RoundTripJsonHelpers` for example +* sample Dhall config (for [spago-legacy](https://github.com/purescript/spago-legacy)): +``` +, json-helpers = + { dependencies = + [ "aff" + , "argonaut-codecs" + , "argonaut-core" + , "arrays" + , "bifunctors" + , "contravariant" + , "control" + , "effect" + , "either" + , "enums" + , "foldable-traversable" + , "foreign-object" + , "maybe" + , "newtype" + , "ordered-collections" + , "prelude" + , "profunctor" + , "psci-support" + , "quickcheck" + , "record" + , "spec" + , "spec-quickcheck" + , "transformers" + , "tuples" + , "typelevel-prelude" + ] + , repo = + "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" + , version = "486db9ee62882baa42cca24f556848c5f6bec565" + } +``` + +#### [`purescript-argonaut-aeson-generic >=0.4.1`](https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic/0.4.1) ([GitHub](https://github.com/coot/purescript-argonaut-aeson-generic)) -For compatible JSON representations: - -* On Haskell side, use: - * Use [`aeson`](http://hackage.haskell.org/package/aeson)'s generic encoding/decoding with default options -* On Purescript side, use: - * [`purescript-argonaut-aeson-generic >=0.4.1`](https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic/0.4.1) ([GitHub](https://github.com/coot/purescript-argonaut-aeson-generic)) - * additional requirement [`peterbecich/purescript-argonaut-codecs`](https://github.com/peterbecich/purescript-argonaut-codecs.git) - * commit `04abb3eb24a4deafe125be0eb23e2786c642e66b` - * see `./test/RoundTripArgonautAesonGeneric` for example - * sample Dhall config: - ``` - , argonaut-codecs = - { dependencies = [ "console" ] - , repo = "https://github.com/peterbecich/purescript-argonaut-codecs.git" - , version = "04abb3eb24a4deafe125be0eb23e2786c642e66b" - } - ``` - * forked from [`purescript-contrib/purescript-argonaut-codecs`](https://github.com/purescript-contrib/purescript-argonaut-codecs) - * [discussion](https://github.com/purescript-contrib/purescript-argonaut-codecs/issues/115) - * *or* [`input-output-hk/purescript-bridge-json-helpers`](https://github.com/input-output-hk/purescript-bridge-json-helpers.git) - * commit `486db9ee62882baa42cca24f556848c5f6bec565` - * see `./test/RoundTripJsonHelpers` for example - * sample Dhall config: - ``` - , json-helpers = - { dependencies = - [ "aff" - , "argonaut-codecs" - , "argonaut-core" - , "arrays" - , "bifunctors" - , "contravariant" - , "control" - , "effect" - , "either" - , "enums" - , "foldable-traversable" - , "foreign-object" - , "maybe" - , "newtype" - , "ordered-collections" - , "prelude" - , "profunctor" - , "psci-support" - , "quickcheck" - , "record" - , "spec" - , "spec-quickcheck" - , "transformers" - , "tuples" - , "typelevel-prelude" - ] - , repo = - "https://github.com/input-output-hk/purescript-bridge-json-helpers.git" - , version = "486db9ee62882baa42cca24f556848c5f6bec565" - } - ``` +Enable this on the Haskell side with `Language.PureScript.Bridge.SumType.argonautAesonGeneric`. + +This library is demonstrated by the `example`; see `./example/readme.md`. + +**TODO**: [resolve incompatibility between Argonaut and Aeson](https://github.com/purescript-contrib/purescript-argonaut-codecs/issues/115) + +**Additional requirement**: [`peterbecich/purescript-argonaut-codecs`](https://github.com/peterbecich/purescript-argonaut-codecs.git) +* commit `04abb3eb24a4deafe125be0eb23e2786c642e66b` +* see `./test/RoundTripArgonautAesonGeneric` for example + * note that some types have been disabled from the `RoundTripArgonautAesonGeneric` test + * `RoundTripJsonHelpers` tests more types + * the types tested can be expanded when the incompatibility issue is resolved +* sample Dhall config: +``` + , argonaut-codecs = + { dependencies = [ "console" ] + , repo = "https://github.com/peterbecich/purescript-argonaut-codecs.git" + , version = "04abb3eb24a4deafe125be0eb23e2786c642e66b" + } +``` +* forked from [`purescript-contrib/purescript-argonaut-codecs`](https://github.com/purescript-contrib/purescript-argonaut-codecs) + +#### [`paf31/purescript-foreign-generic`](https://github.com/paf31/purescript-foreign-generic) + +See `ForeignObject` in `Language.PureScript.Bridge.SumType`. + +This may need to be fixed. + +The test coverage is less than the other two libraries. ## Documentation Usage of this library is documented in `Language.Purescript.Bridge`, with `writePSTypes` you should have everything to get started. Documentation can be found [here](https://www.stackage.org/nightly/package/purescript-bridge). +There is an example; see `./example/readme.md`. + ## Status It works for my use case and is used in production. PRs for more `PSType`s definitions and bridges are very welcome! diff --git a/example/readme.md b/example/readme.md index 5b93379a..5c426845 100644 --- a/example/readme.md +++ b/example/readme.md @@ -1,16 +1,17 @@ -# Purescript Bridge example +# PureScript Bridge example -This project demonstrates the libraries Purescript Bridge and [`input-output-hk/purescript-bridge-json-helpers`](https://github.com/input-output-hk/purescript-bridge-json-helpers.git). +This project demonstrates the libraries PureScript Bridge and [`purescript-argonaut-aeson-generic`](https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic) ([GitHub](https://github.com/coot/purescript-argonaut-aeson-generic)) -It does not use [`purescript-argonaut-aeson-generic`](https://pursuit.purescript.org/packages/purescript-argonaut-aeson-generic) ([GitHub](https://github.com/coot/purescript-argonaut-aeson-generic)). +It does not use [`input-output-hk/purescript-bridge-json-helpers`](https://github.com/input-output-hk/purescript-bridge-json-helpers.git). +To demonstrate this library in the example, more work is needed in `Main.purs`. -The Haskell type `Foo`, in `src/Types.hs`, is generated for Purescript by Purescript Bridge. `purescript-bridge-json-helpers` is used to decode and encode this type, client-side. +The Haskell type `Foo`, in `src/Types.hs`, is generated for PureScript by PureScript Bridge. Some of values in `Foo` are randomly generated every time the page is loaded. `purescript-argonaut-aeson-generic` is used to decode and encode this payload, client-side. The client modifies some of the payload's values and sends it back to the server. # Dependencies ## Nix -The `nix develop` shell will provide Purescipt 0.15 and Spago. +The `nix develop` shell will provide PureScript 0.15 and Spago. ## Without Nix -You must install Purescript 0.15 and Spago. +You must install PureScript 0.15 and [spago-legacy](https://github.com/purescript/spago-legacy). # Running the example - Enter the `example` directory @@ -38,10 +39,10 @@ Foo message: Hello Foo number: 123 Foo list length: 11 Foo message: Hola Foo number: 124 Foo list length: 22 ``` -# Updating the Purescript Bridge +# Updating the PureScript Bridge - Enter the `example` directory -- Regenerate the Purescript Bridge types: +- Regenerate the PureScript Bridge types: ``` cabal run generate-purescript ``` diff --git a/example/src/Main.purs b/example/src/Main.purs index 642efc90..7d87f06f 100644 --- a/example/src/Main.purs +++ b/example/src/Main.purs @@ -34,7 +34,7 @@ testFoo = Foo } main :: Effect Unit -main = log "Hello, Purescript!" *> launchAff_ do +main = log "Hello, PureScript!" *> launchAff_ do -- request a Foo fooResponse <- get json "/foo" for_ fooResponse \fooPayload -> do diff --git a/example/src/Types.hs b/example/src/Types.hs index 263fb26c..bee8ef81 100644 --- a/example/src/Types.hs +++ b/example/src/Types.hs @@ -43,7 +43,6 @@ instance ToJSON Baz where } ) - makeLenses ''Baz data TestSum @@ -119,9 +118,8 @@ myBridge = defaultBridge additionalInstances = lenses . genericShow . argonautAesonGeneric - - -- . jsonHelper - -- To use json-helpers with the example, a modification is necessary + -- . jsonHelpers + -- To use json-helpers with the example, more work is needed -- in Main.purs myTypes :: [SumType 'Haskell] diff --git a/example/static/index.html b/example/static/index.html index 9cc032cf..68fe7ba7 100644 --- a/example/static/index.html +++ b/example/static/index.html @@ -1,7 +1,7 @@ - Purescript Bridge Example + PureScript Bridge Example