diff --git a/purescript-bridge.cabal b/purescript-bridge.cabal --- a/purescript-bridge.cabal +++ b/purescript-bridge.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.11.1.2 +version: 0.12.0.0 -- A short (one-line) description of the package. synopsis: Generate PureScript data types from Haskell data types diff --git a/src/Language/PureScript/Bridge.hs b/src/Language/PureScript/Bridge.hs --- a/src/Language/PureScript/Bridge.hs +++ b/src/Language/PureScript/Bridge.hs @@ -22,16 +22,22 @@ 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. +-- 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': -- --- > let myTypes = [ --- > mkSumType (Proxy :: Proxy MyType1) --- > , mkSumType (Proxy :: Proxy MyType2) +-- > 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 = +-- > [ 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. -- > ] -- > -- > writePSTypes "path/to/your/purescript/project" (buildBridge defaultBridge) myTypes @@ -86,7 +92,7 @@ -- -- > bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo)) bridgeSumType :: FullBridge -> SumType 'Haskell -> SumType 'PureScript -bridgeSumType br (SumType t cs) = SumType (br t) $ map (bridgeConstructor br) cs +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/Printer.hs b/src/Language/PureScript/Bridge/Printer.hs --- a/src/Language/PureScript/Bridge/Printer.hs +++ b/src/Language/PureScript/Bridge/Printer.hs @@ -6,14 +6,15 @@ import Control.Lens import Control.Monad -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Monoid -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 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 @@ -96,32 +97,34 @@ sep = T.replicate 80 "-" sumTypeToTypeDecls :: SumType 'PureScript -> Text -sumTypeToTypeDecls st@(SumType t cs) = T.unlines $ +sumTypeToTypeDecls st@(SumType t cs _) = T.unlines $ dataOrNewtype <> " " <> typeInfoToText True t <> " =" : " " <> T.intercalate "\n | " (map (constructorToText 4) cs) <> "\n" - : "derive instance generic" <> _typeName t <> " :: " <> genericConstraints <> genericInstance t <> "\n" - : [ "derive instance newtype" <> _typeName t <> " :: " <> newtypeInstance t <> " _\n" | isNewtype cs] + : instances st where - genericInstance = ("Generic " <>) . typeInfoToText False - newtypeInstance = ("Newtype " <>) . typeInfoToText False - genericConstraints - | stpLength == 0 = mempty - | otherwise = (<> " => ") $ - if stpLength == 1 - then genericConstraintsInner - else bracketWrap genericConstraintsInner - genericConstraintsInner = T.intercalate ", " $ map genericInstance sumTypeParameters - stpLength = length sumTypeParameters - bracketWrap x = "(" <> x <> ")" - sumTypeParameters = filter isTypeParam . Set.toList $ getUsedTypes st - isTypeParam typ = _typeName typ `elem` map _typeName (_typeParameters t) - isNewtype [constr] - | either isSingletonList (const True) (_sigValues constr) = True - isNewtype _ = False - dataOrNewtype = if isNewtype cs then "newtype" else "data" - isSingletonList [_] = True - isSingletonList _ = False + dataOrNewtype = if isJust (nootype cs) then "newtype" else "data" +-- | Given a Purescript type, generate `derive instance` lines for typeclass +-- instances it claims to have. +instances :: SumType 'PureScript -> [Text] +instances st@(SumType t _ is) = map go is + where + go :: Instance -> Text + 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 _ = "" + 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 = ("Generic " <>) . typeInfoToText False + bracketWrap x = "(" <> x <> ")" + sumTypeToOptics :: SumType 'PureScript -> Text sumTypeToOptics st = constructorOptics st <> recordOptics st @@ -134,10 +137,9 @@ where typeInfo = st ^. sumTypeInfo - 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 @@ -259,7 +261,7 @@ 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 diff --git a/src/Language/PureScript/Bridge/SumType.hs b/src/Language/PureScript/Bridge/SumType.hs --- a/src/Language/PureScript/Bridge/SumType.hs +++ b/src/Language/PureScript/Bridge/SumType.hs @@ -6,14 +6,16 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} - - +{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Bridge.SumType ( SumType (..) , mkSumType +, equal, order , DataConstructor (..) , RecordEntry (..) +, Instance(..) +, nootype , getUsedTypes , constructorToTypes , sigConstructor @@ -24,37 +26,60 @@ , recValue ) where -import Control.Lens hiding (from, to) +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] 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) = flip SumType constrs <$> inj info +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) = SumType info <$> inj constrs +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 +mkSumType p = SumType (mkTypeInfo p) constructors (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) + +-- | 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 + +-- | 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 + +-- | 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 + data DataConstructor (lang :: Language) = DataConstructor { _sigConstructor :: !Text -- ^ e.g. `Left`/`Right` for `Either` , _sigValues :: !(Either [TypeInfo lang] [RecordEntry lang]) @@ -109,7 +134,7 @@ -- 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 _) = foldr constructorToTypes Set.empty cs constructorToTypes :: DataConstructor lang -> Set (TypeInfo lang) -> Set (TypeInfo lang) constructorToTypes (DataConstructor _ (Left myTs)) ts = diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -33,7 +33,8 @@ , _typeParameters = []} in bst `shouldBe` ti it "tests with custom type Foo" $ - let bst = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy 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 [] } @@ -48,9 +49,11 @@ ] } ] + [Eq, Ord, Generic] in bst `shouldBe` st it "tests generation of for custom type Foo" $ - let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo)) + let prox = Proxy :: Proxy Foo + recType = bridgeSumType (buildBridge defaultBridge) (order prox $ mkSumType prox) recTypeText = sumTypeToText recType txt = T.stripEnd $ T.unlines [ "data Foo =" @@ -58,9 +61,10 @@ , " | 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" @@ -111,7 +115,6 @@ , "" , "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" @@ -216,10 +219,8 @@ , " }" , "" , "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" @@ -241,10 +242,8 @@ , " SomeNewtype Int" , "" , "derive instance genericSomeNewtype :: Generic SomeNewtype" - , "" , "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _" , "" - , "" , "--------------------------------------------------------------------------------" , "_SomeNewtype :: Iso' SomeNewtype Int" , "_SomeNewtype = _Newtype" @@ -259,10 +258,8 @@ , " SingleValueConstr Int" , "" , "derive instance genericSingleValueConstr :: Generic SingleValueConstr" - , "" , "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _" , "" - , "" , "--------------------------------------------------------------------------------" , "_SingleValueConstr :: Iso' SingleValueConstr Int" , "_SingleValueConstr = _Newtype" @@ -277,7 +274,6 @@ , " SingleProduct String Int" , "" , "derive instance genericSingleProduct :: Generic SingleProduct" - , "" , "" , "--------------------------------------------------------------------------------" , "_SingleProduct :: Prism' SingleProduct { a :: String, b :: Int }" diff --git a/test/TestData.hs b/test/TestData.hs --- a/test/TestData.hs +++ b/test/TestData.hs @@ -33,7 +33,7 @@ data Foo = Foo | Bar Int | FooBar Int Text - deriving (Generic, Typeable, Show) + deriving (Eq, Ord, Generic, Typeable, Show) data Test = TestIntInt Int Int | TestBool {bool :: Bool} @@ -84,5 +84,4 @@ t :: TypeInfo 'PureScript cs :: [DataConstructor 'PureScript] psB :: SumType 'PureScript -psB@(SumType t cs) = bridgeSumType (buildBridge defaultBridge) b - +psB@(SumType t cs _) = bridgeSumType (buildBridge defaultBridge) b