diff --git a/ocaml-export.cabal b/ocaml-export.cabal --- a/ocaml-export.cabal +++ b/ocaml-export.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 8c174c8aea9f9e12c093c4b32df7c7d3734d09caa318020132493d136120bb26 +-- hash: 52500c9ae7641ae8c64abb0416c86e1974040bf8afa8c8d23717b0f60d4a6317 name: ocaml-export -version: 0.9.0.0 +version: 0.13.0 synopsis: Convert Haskell types in OCaml types description: Use GHC.Generics and Typeable to convert Haskell types to OCaml types. Convert aeson serialization to ocaml. category: Web @@ -31,7 +31,7 @@ library hs-source-dirs: src - ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wredundant-constraints -fprint-potential-instances + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wredundant-constraints -fprint-potential-instances build-depends: QuickCheck , aeson @@ -74,7 +74,7 @@ main-is: Spec.hs hs-source-dirs: test - ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints build-depends: QuickCheck , aeson diff --git a/src/OCaml/BuckleScript/Decode.hs b/src/OCaml/BuckleScript/Decode.hs --- a/src/OCaml/BuckleScript/Decode.hs +++ b/src/OCaml/BuckleScript/Decode.hs @@ -23,7 +23,7 @@ import Control.Monad.Reader import qualified Data.List as L import Data.Maybe (catMaybes) -import Data.Monoid +import Data.Monoid ((<>)) import Data.Proxy (Proxy (..)) import Data.Typeable -- aeson @@ -34,7 +34,8 @@ import Data.Text (Text) import qualified Data.Text as T -- wl-pprint -import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) +import Text.PrettyPrint.Leijen.Text + (Doc, (<+>), (<$$>), comma, dquotes, empty, indent, int, line, parens) -- ocaml-export import OCaml.BuckleScript.Types hiding (getOCamlValues) import OCaml.Internal.Common @@ -82,10 +83,10 @@ <$$> "val" <+> fnName <+> ":" <+> typeParameterEncoders <> "Js_json.t ->" <+> "(" <> typeParameters <> (stext . textLowercaseFirst $ typeName) <> ", string)" <+> "Belt.Result.t" - renderInterface datatype@(OCamlDatatype _ typeName constructors) = do - fnName <- renderRef datatype + renderInterface _datatype@(OCamlDatatype _ typeName constructors) = do + -- fnName <- renderRef datatype let (typeParameterEncoders, typeParameters) = renderTypeParameterVals constructors - pure $ "val" <+> fnName <+> ":" <+> typeParameterEncoders <> "Js_json.t ->" <+> "(" <> typeParameters <> (stext . textLowercaseFirst $ typeName) <> ", string)" <+> "Belt.Result.t" + pure $ "val" <+> "decode" <> (stext typeName) <+> ":" <+> typeParameterEncoders <> "Js_json.t ->" <+> "(" <> typeParameters <> (stext . textLowercaseFirst $ typeName) <> ", string)" <+> "Belt.Result.t" renderInterface _ = pure "" @@ -132,8 +133,8 @@ = "| Some err -> Belt.Result.Error (\"" <> fnName <> ": unknown enumeration '\" ^ err ^ \"'.\")" <$$> "| None -> Belt.Result.Error \"" <> fnName <> ": expected a top-level JSON string.\"" - render datatype@(OCamlDatatype _ name constructor) = do - fnName <- renderRef datatype + render (OCamlDatatype _ typeName constructor) = do + let fnName = "decode" <> (stext typeName) fnBody <- render constructor ocamlInterface <- asks (includeOCamlInterface . userOptions) if ocamlInterface @@ -143,14 +144,14 @@ pure $ "let" <+> fnName <+> renderedTypeParameters <+> "json" <+> "=" <$$> fnBody else do let (typeParameterSignatures,typeParameters) = renderTypeParameters constructor - returnType = "(" <> typeParameters <> (stext . textLowercaseFirst $ name) <> ", string) Belt.Result.t =" + returnType = "(" <> typeParameters <> (stext . textLowercaseFirst $ typeName) <> ", string) Belt.Result.t =" pure $ "let" <+> fnName <+> typeParameterSignatures <+> "(json : Js_json.t) :" <> returnType <$$> fnBody render (OCamlPrimitive primitive) = renderRef primitive instance HasDecoderRef OCamlDatatype where - renderRef (OCamlDatatype typeRef _ (OCamlValueConstructor (NamedConstructor _ (OCamlRefApp typRep values)))) = do - let name = "decode" <> (stext $ textUppercaseFirst $ T.pack $ show $ fst $ splitTyConApp typRep) + renderRef (OCamlDatatype typeRef typeName (OCamlValueConstructor (NamedConstructor _ (OCamlRefApp typRep values)))) = do + let name = "decode" <> (stext typeName) dx <- renderRef values mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData @@ -185,6 +186,38 @@ renderRef (OCamlPrimitive primitive) = renderRef primitive instance HasDecoder OCamlConstructor where + render (OCamlValueConstructor (NamedConstructor name value@(OCamlRefApp _ _))) = do + decoder <- render value + let constructorParams = constructorParameters 0 value + v <- mk name 0 $ (Just <$> flattenOCamlValue value) ++ [Nothing] + pure $ + if length constructorParams > 1 + then + indent 2 $ "match Js.Json.decodeArray json with" + <$$> "| Some v ->" + <$$> (indent 2 v) + <$$> "| None -> Belt.Result.Error (\"" <> (stext name) <+> "expected an array.\")" + else + indent 2 $ "match (Aeson.Decode.unwrapResult (" <> decoder <+> "json))" <+> "with" + <$$> "| v -> Belt.Result.Ok" <+> parens (stext name <+> "v") + <$$> "| exception Aeson.Decode.DecodeError msg -> Belt.Result.Error (\"decode" <> (stext . textUppercaseFirst $ name) <> ": \" ^ msg)" + + render (OCamlValueConstructor (NamedConstructor name value@(OCamlRef _ _))) = do + decoder <- render value + let constructorParams = constructorParameters 0 value + v <- mk name 0 $ (Just <$> flattenOCamlValue value) ++ [Nothing] + pure $ + if length constructorParams > 1 + then + indent 2 $ "match Js.Json.decodeArray json with" + <$$> "| Some v ->" + <$$> (indent 2 v) + <$$> "| None -> Belt.Result.Error (\"" <> (stext name) <+> "expected an array.\")" + else + indent 2 $ "match (Aeson.Decode.unwrapResult (" <> decoder <+> "json))" <+> "with" + <$$> "| v -> Belt.Result.Ok" <+> parens (stext name <+> "v") + <$$> "| exception Aeson.Decode.DecodeError msg -> Belt.Result.Error (\"decode" <> (stext . textUppercaseFirst $ name) <> ": \" ^ msg)" + render (OCamlValueConstructor (NamedConstructor name value)) = do decoder <- render value let constructorParams = constructorParameters 0 value @@ -270,6 +303,14 @@ dy <- render y pure $ (wrapIfPrimitive x dx) <+> (wrapIfPrimitive y dy) + renderRef (OCamlRef metadata ref) = do + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> fail $ "OCaml.BuckleScript.Decode (HasDecoder (OCamlRef typeRep name)) mOCamlTypeMetaData is Nothing:\n\n" ++ (show ref) + Just ocamlTypeRef -> do + ds <- asks (dependencies . userOptions) + pure $ stext (appendModule' ds ocamlTypeRef metadata ref) + renderRef (OCamlPrimitiveRef primitive) = renderRef primitive renderRef _ = pure "" @@ -474,10 +515,10 @@ case x of Nothing -> mk name i xs Just x' -> do - renderedVal <- render x' + renderedVal <- unwrapIfTypeParameter x' <$> render x' renderedInternal <- mk name (i+1) xs let iDoc = (stext . T.pack . show $ i) - pure $ indent 1 $ "(match" <+> (if oCamlValueIsFloat x' then "" else "Aeson.Decode.") <> renderedVal <+> ("v." <> parens iDoc) <+> "with" + pure $ indent 1 $ "(match" <+> "Aeson.Decode.(" <> renderedVal <> (") v." <> parens iDoc) <+> "with" <$$> indent 1 ("| v" <> iDoc <+> "->" <$$> (indent 2 renderedInternal) @@ -539,6 +580,16 @@ -- in case of a Haskell sum of products, ocaml-export creates a definition for each product -- within the same file as the sum. These products will not be in the dependencies map. Nothing -> "decode" <> (stext $ textUppercaseFirst name) <+> nxt + +appendModule' :: Map.Map HaskellTypeMetaData OCamlTypeMetaData -> OCamlTypeMetaData -> HaskellTypeMetaData -> Text -> Text +appendModule' m o h name = + case Map.lookup h m of + Just parOCamlTypeMetaData -> + (mkModulePrefix o parOCamlTypeMetaData) <> "decode" <> (textUppercaseFirst name) + -- in case of a Haskell sum of products, ocaml-export creates a definition for each product + -- within the same file as the sum. These products will not be in the dependencies map. + Nothing -> "decode" <> textUppercaseFirst name + wrapIfPrimitive :: OCamlValue -> Doc -> Doc wrapIfPrimitive (OCamlPrimitiveRef _) doc = parens $ "wrapResult" <+> doc diff --git a/src/OCaml/BuckleScript/Encode.hs b/src/OCaml/BuckleScript/Encode.hs --- a/src/OCaml/BuckleScript/Encode.hs +++ b/src/OCaml/BuckleScript/Encode.hs @@ -23,7 +23,7 @@ import Control.Monad.Reader import qualified Data.List as L import Data.Maybe (catMaybes) -import Data.Monoid +import Data.Monoid ((<>)) import Data.Proxy (Proxy (..)) import Data.Typeable @@ -38,7 +38,8 @@ import qualified Data.Text as T -- wl-pprint -import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) +import Text.PrettyPrint.Leijen.Text + (Doc, (<+>), (<$$>), comma, dquotes, empty, indent, int, nest, parens) -- ocaml-export import OCaml.BuckleScript.Types @@ -90,11 +91,11 @@ <$$> "val" <+> fnName <+> ":" <+> typeParameterSignatures <+> typeParameters <> encodeFnName <+> "->" <+> "Js_json.t" -- other data types - renderTypeInterface datatype@(OCamlDatatype _ typeName constructor) = do - fnName <- renderRef datatype + renderTypeInterface _datatype@(OCamlDatatype _ typeName constructor) = do + -- fnName <- renderRef datatype let (typeParameterSignatures,typeParameters) = renderTypeParameterVals constructor encodeFnName = stext . textLowercaseFirst $ typeName - pure $ "val" <+> fnName <+> ":" <+> typeParameterSignatures <+> typeParameters <> encodeFnName <+> "->" <+> "Js_json.t" + pure $ "val" <+> "encode" <> (stext typeName) <+> ":" <+> typeParameterSignatures <+> typeParameters <> encodeFnName <+> "->" <+> "Js_json.t" -- no need to render for primitives renderTypeInterface _ = pure "" @@ -139,9 +140,9 @@ (indent 2 ("match x with" <$$> foldl1 (<$$>) dc)) -- product or record - render datatype@(OCamlDatatype _ typeName constructor) = do + render (OCamlDatatype _ typeName constructor) = do ocamlInterface <- asks (includeOCamlInterface . userOptions) - fnName <- renderRef datatype + let fnName = "encode" <> (stext typeName) renderedConstructor <- render constructor if ocamlInterface then do @@ -160,8 +161,9 @@ -- | produce encode function name for data types and primitives instance HasEncoderRef OCamlDatatype where -- when ocamlrefapp is reference by a primitive - renderRef (OCamlDatatype _ _ (OCamlValueConstructor (NamedConstructor _ (OCamlRefApp typRep values)))) = do - let name = "encode" <> (stext $ textUppercaseFirst $ T.pack $ show $ fst $ splitTyConApp typRep) + renderRef (OCamlDatatype _ typeName (OCamlValueConstructor (NamedConstructor _ (OCamlRefApp typRep values)))) = do + -- let name = "encode" <> (stext $ textUppercaseFirst $ T.pack $ show $ fst $ splitTyConApp typRep) + let name = "encode" <> (stext typeName) dx <- renderRef values mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData @@ -290,6 +292,14 @@ dx <- render x dy <- render y pure $ dx <+> dy + + renderRef (OCamlRef metadata ref) = do + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> fail $ "OCaml.BuckleScript.Encode (HasEncoder (OCamlRef typeRep name)) mOCamlTypeMetaData is Nothing:\n\n" ++ (show ref) + Just ocamlTypeRef -> do + ds <- asks (dependencies . userOptions) + pure $ stext (appendModule ds ocamlTypeRef metadata ref) renderRef (OCamlPrimitiveRef primitive) = renderRef primitive diff --git a/src/OCaml/BuckleScript/Internal/Module.hs b/src/OCaml/BuckleScript/Internal/Module.hs --- a/src/OCaml/BuckleScript/Internal/Module.hs +++ b/src/OCaml/BuckleScript/Internal/Module.hs @@ -71,6 +71,7 @@ -- template-haskell import Language.Haskell.TH +import Language.Haskell.TH.Syntax (addDependentFile) -- text import Data.Text (Text) @@ -256,14 +257,19 @@ mkFiles'' _ includeInterface includeSpec Proxy = do let typeFilePath = symbolVal (Proxy :: Proxy b) let typeName = tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a) + addDependentFile (typeFilePath <.> "ml") ml <- embedFile (typeFilePath <.> "ml") mli <- if includeInterface - then (\f -> AppE (ConE $ mkName "Just") f) <$> embedFile (typeFilePath <.> "mli") + then do + addDependentFile (typeFilePath <.> "mli") + (\f -> AppE (ConE $ mkName "Just") f) <$> embedFile (typeFilePath <.> "mli") else pure $ ConE $ mkName "Nothing" spec <- if includeSpec - then (\f -> AppE (ConE $ mkName "Just") f) <$> embedFile (typeFilePath <> "_spec" <.> "ml") + then do + addDependentFile (typeFilePath <> "_spec" <.> "ml") + (\f -> AppE (ConE $ mkName "Just") f) <$> embedFile (typeFilePath <> "_spec" <.> "ml") else pure $ ConE $ mkName "Nothing" pure [TupE [LitE $ StringL typeName, AppE (AppE (AppE (ConE $ mkName "EmbeddedOCamlFiles") ml) mli) spec]] diff --git a/src/OCaml/BuckleScript/Record.hs b/src/OCaml/BuckleScript/Record.hs --- a/src/OCaml/BuckleScript/Record.hs +++ b/src/OCaml/BuckleScript/Record.hs @@ -21,7 +21,7 @@ import Control.Monad.Reader import Data.List (nub, sort) import Data.Maybe (catMaybes) -import Data.Monoid +import Data.Monoid ((<>)) import Data.Proxy (Proxy (..)) import Data.Typeable @@ -37,7 +37,8 @@ import qualified Data.Text as T -- wl-pprint -import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) +import Text.PrettyPrint.Leijen.Text + (Doc, (<+>), (<$$>), comma, indent, line, parens, space) -- | Convert a 'Proxy a' into OCaml type source code. toOCamlTypeSourceWith :: forall a. OCamlType a => Options -> a -> T.Text @@ -81,9 +82,9 @@ fnBody <- render constructor pure $ "type" <+> typeParameters <+> fnName <+> "=" <$$> indent 2 fnBody - render datatype@(OCamlDatatype _ _ constructor) = do + render (OCamlDatatype _ typeName constructor) = do let typeParameters = renderTypeParameters constructor - fnName <- renderRef datatype + let fnName = stext . textLowercaseFirst $ typeName fnBody <- render constructor pure $ "type" <+> typeParameters <+> fnName <+> "=" <$$> indent 2 ("|" <+> fnBody) @@ -129,6 +130,7 @@ dy <- render y pure $ dx <> comma <+> dy + renderRef (OCamlRef _metaData primitive) = pure $ stext primitive renderRef (OCamlPrimitiveRef primitive) = renderRef primitive renderRef _ = pure "" @@ -175,7 +177,7 @@ Nothing -> fail $ "OCaml.BuckleScript.Record (HasType (OCamlDatatype typeRep name)) mOCamlTypeMetaData is Nothing:\n\n" Just ocamlTypeRef -> do ds <- asks (dependencies . userOptions) - dx <- renderRef values + dx <- render values pure $ (parensIfNotBlank dx) <+> (stext $ appendModule ds ocamlTypeRef (typeRepToHaskellTypeMetaData typRep) (T.pack . show $ typeRepTyCon typRep)) render (OCamlTypeParameterRef name) = pure $ stext ("'" <> name) diff --git a/src/OCaml/BuckleScript/Spec.hs b/src/OCaml/BuckleScript/Spec.hs --- a/src/OCaml/BuckleScript/Spec.hs +++ b/src/OCaml/BuckleScript/Spec.hs @@ -9,7 +9,7 @@ ) where -- base -import Data.Monoid +import Data.Monoid ((<>)) -- text import Data.Text (Text) import qualified Data.Text as T @@ -17,7 +17,7 @@ import OCaml.BuckleScript.Types hiding (getOCamlValues) import OCaml.Internal.Common -- wl-pprint -import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>), ()) +import Text.PrettyPrint.Leijen.Text (Doc, (<+>), (<$$>), dquotes, indent) mkSampleServerAndGoldenSpec :: OCamlDatatype -> Maybe Int -> [Text] -> Text -> Text -> Doc mkSampleServerAndGoldenSpec (OCamlDatatype _ typeName constructors) mParameterRefCount modules url goldenDir = diff --git a/src/OCaml/BuckleScript/Types.hs b/src/OCaml/BuckleScript/Types.hs --- a/src/OCaml/BuckleScript/Types.hs +++ b/src/OCaml/BuckleScript/Types.hs @@ -37,12 +37,12 @@ -- fill type parameters of a proxy when calling toOCamlType -- so the kind is * -- e.g. `toOCamlType (Proxy :: Proxy (Either TypeParameterRef0 TypeParameterRef1))` - , TypeParameterRef0 - , TypeParameterRef1 - , TypeParameterRef2 - , TypeParameterRef3 - , TypeParameterRef4 - , TypeParameterRef5 + , TypeParameterRef0(..) + , TypeParameterRef1(..) + , TypeParameterRef2(..) + , TypeParameterRef3(..) + , TypeParameterRef4(..) + , TypeParameterRef5(..) -- functions for manipulating and querying the data type tree , getTypeParameterRefNames diff --git a/src/OCaml/Export.hs b/src/OCaml/Export.hs --- a/src/OCaml/Export.hs +++ b/src/OCaml/Export.hs @@ -30,12 +30,12 @@ -- OCaml.BuckleScript.Types , OCamlType (..) , typeableToOCamlType - , TypeParameterRef0 - , TypeParameterRef1 - , TypeParameterRef2 - , TypeParameterRef3 - , TypeParameterRef4 - , TypeParameterRef5 + , TypeParameterRef0(..) + , TypeParameterRef1(..) + , TypeParameterRef2(..) + , TypeParameterRef3(..) + , TypeParameterRef4(..) + , TypeParameterRef5(..) -- servant spec , mkOCamlSpecServer diff --git a/src/OCaml/Internal/Common.hs b/src/OCaml/Internal/Common.hs --- a/src/OCaml/Internal/Common.hs +++ b/src/OCaml/Internal/Common.hs @@ -15,7 +15,7 @@ -- base import Data.Char (toLower,toUpper) import qualified Data.List as L -import Data.Monoid +import Data.Monoid ((<>)) -- aeson import qualified Data.Aeson.Types as Aeson (Options(..), defaultOptions) @@ -35,7 +35,8 @@ import qualified Data.Text.Lazy as LT -- wl-pprint -import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) +import Text.PrettyPrint.Leijen.Text + (Doc, (<+>), (<$$>), comma, line, linebreak, nest, text, displayT, renderPretty) -- | For URLs and POSIX systems. diff --git a/test/Product.hs b/test/Product.hs --- a/test/Product.hs +++ b/test/Product.hs @@ -55,7 +55,9 @@ :> WrapThreeFilled :> WrapThreePartiallyFilled TypeParameterRef0 -- :> TypeSynonymKey TypeParameterRef0 --- :> NewTypeKey TypeParameterRef0 +-- :> NewTypeKey TypeParameterRef0 + :<|> OCamlModule '["Box"] :> InnerBox TypeParameterRef0 :> OuterBox :> AuditAction :> AuditModel TypeParameterRef0 :> User :> UserAudit + :<|> OCamlModule '["Key"] :> SqlKey :> UserId ) compareInterfaceFiles :: FilePath -> SpecWith () @@ -422,7 +424,239 @@ instance (Typeable a, OCamlType a) => OCamlType (NewTypeKey a) +-- abc + +data InnerBox a = + InnerBox + { ibA :: a + , ibS :: String + , ibX :: Int + } deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance (ToADTArbitrary a, Arbitrary a) => ToADTArbitrary (InnerBox a) +instance Arbitrary a => Arbitrary (InnerBox a) where + arbitrary = InnerBox <$> arbitrary <*> arbitrary <*> arbitrary +instance (Typeable a, OCamlType a) => OCamlType (InnerBox a) + +data OuterBox = + OuterBox (InnerBox Person) + deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance ToADTArbitrary OuterBox +instance Arbitrary OuterBox where + arbitrary = OuterBox <$> arbitrary +instance OCamlType OuterBox + +data AuditAction = Create | Delete | Update + deriving (Show, Read, Eq, Ord, Generic, Typeable, ToJSON, FromJSON) + +instance ToADTArbitrary AuditAction +instance Arbitrary AuditAction where + arbitrary = elements [Create, Delete, Update] +instance OCamlType AuditAction + +data AuditModel a = + AuditModel + { auditModel :: a + , originalId :: String + , auditAction :: AuditAction + , editedBy :: String + , editedOn :: String + } deriving (Read, Show, Eq, Generic, Typeable, ToJSON, FromJSON) + +instance (ToADTArbitrary a, Arbitrary a) => ToADTArbitrary (AuditModel a) +instance (Arbitrary a) => Arbitrary (AuditModel a) where + arbitrary = AuditModel <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +instance OCamlType (AuditModel TypeParameterRef0) + +data User = + User + { userIdent :: String + , userPassword :: Maybe (String) + , userTimezone :: String + } deriving (Eq, Generic, Ord, Read, Show, Typeable, ToJSON, FromJSON) + +instance ToADTArbitrary User +instance Arbitrary User where + arbitrary = User <$> arbitrary <*> arbitrary <*> arbitrary +instance OCamlType User + +newtype UserAudit = UserAudit (AuditModel User) + deriving (Read, Show, Eq, Generic, Typeable, ToJSON, FromJSON) + +instance ToADTArbitrary UserAudit +instance Arbitrary UserAudit where + arbitrary = UserAudit <$> arbitrary +instance OCamlType UserAudit + + +newtype SqlKey = SqlKey Int deriving (Eq, Generic, Ord, Read, Show, Typeable, ToJSON, FromJSON, OCamlType) + +instance ToADTArbitrary SqlKey +instance Arbitrary SqlKey where + arbitrary = SqlKey <$> arbitrary + +newtype UserId = + UserId SqlKey + deriving (Eq, Generic, Ord, Show, ToJSON, FromJSON, OCamlType) + +instance ToADTArbitrary UserId +instance Arbitrary UserId where + arbitrary = UserId <$> arbitrary + +-- def + {- +λ> toOCamlType (Proxy :: Proxy SqlKey) +OCamlDatatype + (HaskellTypeMetaData "SqlKey" "Ghci1" "interactive") + "SqlKey" + (OCamlValueConstructor (NamedConstructor "SqlKey" (OCamlPrimitiveRef OInt))) + +λ> toOCamlType (Proxy :: Proxy UserId) +OCamlDatatype + (HaskellTypeMetaData "UserId" "Ghci2" "interactive") + "UserId" + (OCamlValueConstructor (NamedConstructor "UserId" (OCamlRef (HaskellTypeMetaData "SqlKey" "Ghci1" "interactive") "SqlKey"))) + + + +:set -XDeriveGeneric +:set -XDeriveAnyClass +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable) +import OCaml.Export +import Data.Time (UTCTime) + +data AuditAction = Create | Delete | Update + deriving (Show, Read, Eq, Ord, Generic, Typeable, OCamlType) + +data AuditModel a = + AuditModel + { auditModel :: a + , originalId :: ByteString + , auditAction :: AuditAction + , editedBy :: Text + , editedOn :: UTCTime + } deriving (Read, Show, Eq, Generic, Typeable, OCamlType) + +re-react-onping-frontend/src/PlowtechAuthenticationTypes.ml +data Wrapper a = + Wrapper + { wpa :: a + } deriving (Eq,Show,Generic,OCamlType) + +data SumWrapped + = SW1 + | SW2 (Wrapper Int) + | SW3 (Wrapper (Maybe String)) + | SW4 (Wrapper (Either Int String)) + deriving (Eq,Show,Generic,OCamlType) + +toOCamlType (Proxy :: Proxy SumWrapped) + +OCamlDatatype (HaskellTypeMetaData "SumWrapped" "Ghci1" "interactive") "SumWrapped" (OCamlValueConstructor (MultipleConstructors [MultipleConstructors [NamedConstructor "SW1" OCamlEmpty,NamedConstructor "SW2" (OCamlRefApp (Wrapper Int) (OCamlPrimitiveRef OInt))],MultipleConstructors [NamedConstructor "SW3" (OCamlRefApp (Wrapper (Maybe [Char])) (OCamlPrimitiveRef (OOption (OCamlPrimitive (OList (OCamlPrimitive OChar)))))),NamedConstructor "SW4" (OCamlRefApp (Wrapper (Either Int [Char])) (OCamlPrimitiveRef (OEither (OCamlPrimitive OInt) (OCamlPrimitive (OList (OCamlPrimitive OChar))))))]])) + + +data InnerBox a = + InnerBox + { ibA :: a + , ibS :: String + , ibX :: Int + } deriving (Eq,Show,Generic) + +instance (Typeable a, OCamlType a) => OCamlType (InnerBox a) + +data Person = Person + { id :: Int + , name :: Maybe String + , created :: String + } deriving (Show, Eq, Generic,OCamlType) + + +data OuterBox = + OuterBox (InnerBox Person) + deriving (Eq,Show,Generic,OCamlType) + +toOCamlType (Proxy :: Proxy OuterBox) + +OCamlDatatype + (HaskellTypeMetaData "OuterBox" "Ghci4" "interactive") + "OuterBox" + (OCamlValueConstructor + (NamedConstructor + "OuterBox" + (OCamlRefApp + (InnerBox Person) + (OCamlRef (HaskellTypeMetaData "Person" "Ghci3" "interactive") "Person")))) + +OCamlDatatype + (HaskellTypeMetaData "NewType" "Ghci1" "interactive") + "NewType" + (OCamlValueConstructor + (NamedConstructor + "NewType" + (OCamlPrimitiveRef OInt))) + +newtype NewType + = NewType Int + deriving (Show,Eq,Generic,OCamlType) + + +OCamlDatatype + (HaskellTypeMetaData "SumWrapped" "Ghci1" "interactive") + "SumWrapped" + (OCamlValueConstructor + (MultipleConstructors + [MultipleConstructors + [NamedConstructor "SW1" OCamlEmpty + ,NamedConstructor + "SW2" + (OCamlRefApp + (Wrapper Int) + (OCamlPrimitiveRef OInt))] + ,MultipleConstructors + [NamedConstructor "SW3" (OCamlRefApp (Wrapper (Maybe [Char])) (OCamlPrimitiveRef (OOption (OCamlPrimitive (OList (OCamlPrimitive OChar)))))) + ,NamedConstructor "SW4" (OCamlRefApp (Wrapper (Either Int [Char])) (OCamlPrimitiveRef (OEither (OCamlPrimitive OInt) (OCamlPrimitive (OList (OCamlPrimitive OChar))))))]])) + + +data UnnamedProduct = UnnamedProduct String Int + deriving (Eq, Read, Show, Generic, OCamlType) + +toOCamlType (Proxy :: Proxy UnnamedProduct) + +OCamlDatatype + (HaskellTypeMetaData "UnnamedProduct" "Ghci7" "interactive") + "UnnamedProduct" + (OCamlValueConstructor + (NamedConstructor + "UnnamedProduct" + (Values + (OCamlPrimitiveRef + (OList (OCamlPrimitive OChar))) + (OCamlPrimitiveRef OInt)))) + + +{- +data OCamlConstructor + = OCamlValueConstructor ValueConstructor -- ^ Sum, record (product with named fields) or product without named fields + +data ValueConstructor + = NamedConstructor Text OCamlValue -- ^ Product without named fields + | RecordConstructor Text OCamlValue -- ^ Product with named fields + | MultipleConstructors [ValueConstructor] -- ^ Sum type + +data OCamlValue + = OCamlRef HaskellTypeMetaData Text -- ^ The name of a non-primitive data type + | OCamlRefApp TypeRep OCamlValue -- ^ A type constructor that has at least one type parameter filled + | OCamlTypeParameterRef Text -- ^ Type parameters like `a` in `Maybe a` + | OCamlEmpty -- ^ a place holder for OCaml value. It can represent the end of a list or an Enumerator in a mixed sum + | OCamlPrimitiveRef OCamlPrimitive -- ^ A primitive OCaml type like `int`, `string`, etc. + | OCamlField Text OCamlValue -- ^ A field name and its type from a record. + | Values OCamlValue OCamlValue -- ^ Used for multiple types in a NameConstructor or a RecordConstructor. + | OCamlRefAppValues OCamlValue OCamlValue -- ^ User for multiple types in an OCamlRefApp. These are rendered in a different way from V +-} + λ> toOCamlType (Proxy :: Proxy (Key User)) OCamlDatatype (HaskellTypeMetaData "Key" "Database.Persist.Class.PersistEntity" "persistent-2.6-HdpHylIi1gZ4QjAhgpXd6i") "Key" (OCamlValueConstructor (NamedConstructor "Key" OCamlEmpty)) λ diff --git a/test/ProductApp.hs b/test/ProductApp.hs --- a/test/ProductApp.hs +++ b/test/ProductApp.hs @@ -54,3 +54,5 @@ compareInterfaceFiles "UnnamedProduct" compareInterfaceFiles "ComplexProduct" compareInterfaceFiles "Wrapper" + compareInterfaceFiles "Box" + compareInterfaceFiles "Key" diff --git a/test/Sum.hs b/test/Sum.hs --- a/test/Sum.hs +++ b/test/Sum.hs @@ -156,6 +156,7 @@ | HasMultipleInts Int Int | HasMultipleTuples (Int,Int) (Int,Int) | HasMixed Int String Double + | HasNameOrIdNumber NameOrIdNumber Int deriving (Show,Eq,Generic, OCamlType, ToJSON, FromJSON) instance Arbitrary SumVariant where @@ -167,6 +168,7 @@ , HasMultipleInts <$> arbitrary <*> arbitrary , HasMultipleTuples <$> arbitrary <*> arbitrary , HasMixed <$> arbitrary <*> arbitrary <*> arbitrary + , HasNameOrIdNumber <$> arbitrary <*> arbitrary ] instance ToADTArbitrary SumVariant