purescript-bridge 0.11.1.2 → 0.12.0.0
raw patch · 6 files changed
+93/−65 lines, 6 files
Files
- purescript-bridge.cabal +1/−1
- src/Language/PureScript/Bridge.hs +12/−6
- src/Language/PureScript/Bridge/Printer.hs +34/−32
- src/Language/PureScript/Bridge/SumType.hs +37/−12
- test/Spec.hs +7/−11
- test/TestData.hs +2/−3
purescript-bridge.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.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
src/Language/PureScript/Bridge.hs view
@@ -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:
src/Language/PureScript/Bridge/Printer.hs view
@@ -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
src/Language/PureScript/Bridge/SumType.hs view
@@ -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 =
test/Spec.hs view
@@ -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 }"
test/TestData.hs view
@@ -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