diff --git a/ocaml-export.cabal b/ocaml-export.cabal --- a/ocaml-export.cabal +++ b/ocaml-export.cabal @@ -2,12 +2,12 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 13797e051898a65e9a1b27f7b146bf99ef415e50fbc55d7b0e5626ad4b6b9f8e +-- hash: 1958ab6ed0c01872336472224fcf702904c8cfb26230a75529ea37b5ab11a6d4 name: ocaml-export -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Convert Haskell types in OCaml types -description: README.md +description: Use GHC.Generics and Typeable to convert Haskell types to OCaml types. Convert aeson serialization to ocaml. category: Web homepage: https://github.com/plow-technologies/ocaml-export#readme bug-reports: https://github.com/plow-technologies/ocaml-export/issues @@ -26,7 +26,7 @@ library hs-source-dirs: src - ghc-options: -Wall + ghc-options: -Wall -Wredundant-constraints -fprint-potential-instances build-depends: QuickCheck , aeson @@ -43,7 +43,7 @@ , servant , servant-server , split - , template-haskell + , template-haskell <2.12.0.0 , text , time , typelits-witnesses @@ -72,20 +72,19 @@ build-depends: QuickCheck , aeson - , base + , base >=4.7 && <5 , bytestring - , constraints , containers , directory , filepath , hspec - , hspec-golden-aeson + , hspec-golden-aeson >=0.4.0.0 , ocaml-export , process , quickcheck-arbitrary-adt , servant , servant-server - , template-haskell + , template-haskell <2.12.0.0 , text , time , typelits-witnesses 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 @@ -25,25 +25,42 @@ import Data.Maybe (catMaybes) import Data.Monoid import Data.Proxy (Proxy (..)) - +import Data.Typeable -- aeson import qualified Data.Aeson.Types as Aeson (Options(..)) - -- containers import qualified Data.Map.Strict as Map - -- text import Data.Text (Text) import qualified Data.Text as T - -- wl-pprint import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) - -- ocaml-export import OCaml.BuckleScript.Types hiding (getOCamlValues) import OCaml.Internal.Common +-- | Convert a 'Proxy a' into OCaml type to decode JSON function source code with an interface file '.mli'. +toOCamlDecoderInterfaceWith :: forall a. OCamlType a => Options -> a -> T.Text +toOCamlDecoderInterfaceWith options a = + case toOCamlType (Proxy :: Proxy a) of + OCamlDatatype haskellTypeMetaData _ _ -> + case Map.lookup haskellTypeMetaData (dependencies options) of + Just ocamlTypeMetaData -> pprinter $ runReader (renderInterface (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) + Nothing -> "" + _ -> pprinter $ runReader (renderInterface (toOCamlType a)) (TypeMetaData Nothing options) +-- | Convert a 'Proxy a' into OCaml type to decode JSON function source code without an interface file '.mli'. +toOCamlDecoderSourceWith :: forall a. OCamlType a => Options -> a -> T.Text +toOCamlDecoderSourceWith options a = + case toOCamlType (Proxy :: Proxy a) of + OCamlDatatype haskellTypeMetaData _ _ -> + case Map.lookup haskellTypeMetaData (dependencies options) of + Just ocamlTypeMetaData -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) + Nothing -> "" + _ -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData Nothing options) + +-- Internal + -- | Render OCamlDatatype into an OCaml declaration class HasDecoder a where render :: a -> Reader TypeMetaData Doc @@ -72,21 +89,6 @@ renderInterface _ = pure "" - -renderSumRecord :: Text -> OCamlConstructor -> Reader TypeMetaData (Maybe Doc) -renderSumRecord typeName (OCamlValueConstructor (RecordConstructor name value)) = do - let sumRecordName = typeName <> name - fnBody <- render (OCamlValueConstructor $ RecordConstructor (typeName <> name) value) - ocamlInterface <- asks (includeOCamlInterface . userOptions) - if ocamlInterface - then - pure $ Just $ "let decode" <> stext sumRecordName <+> "json =" <$$> fnBody - else - pure $ Just $ "let decode" <> stext sumRecordName <+> "(json : Js_json.t)" <+> ":(" <> (stext $ textLowercaseFirst sumRecordName) <> ", string)" <+> "Js_result.t =" <$$> fnBody - -renderSumRecord _ _ = return Nothing - - instance HasDecoder OCamlDatatype where -- Sum with records render datatype@(OCamlDatatype _ typeName constructor@(OCamlSumOfRecordConstructor _ (MultipleConstructors constructors))) = do @@ -137,7 +139,7 @@ if ocamlInterface then do let typeParameters = getTypeParameters constructor - renderedTypeParameters = foldl (<>) "" $ stext <$> L.intersperse " " ((\t -> "decode" <> (textUppercaseFirst t)) <$> typeParameters) + renderedTypeParameters = foldl (<>) "" $ stext <$> L.intersperse " " ((\t -> "decode" <> (textUppercaseFirst t)) <$> (L.sort typeParameters)) pure $ "let" <+> fnName <+> renderedTypeParameters <+> "json" <+> "=" <$$> fnBody else do let (typeParameterSignatures,typeParameters) = renderTypeParameters constructor @@ -147,6 +149,21 @@ 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) + dx <- renderRef values + + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> pure $ parens $ name <+> dx + Just decOCamlTypeMetaData -> do + ds <- asks (dependencies . userOptions) + case Map.lookup (typeRepToHaskellTypeMetaData typRep) ds of + Just parOCamlTypeMetaData -> do + let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData + pure $ parens $ prefix <> name <+> dx + Nothing -> fail ("OCaml.BuckleScript.Decode (HasDecoderRef OCamlDataType) expected to find dependency:\n\n" ++ show typeRef ++ "\n\nin\n\n" ++ show ds) + -- this should only catch type parameters renderRef datatype@(OCamlDatatype typeRef name _) = if isTypeParameterRef datatype @@ -167,18 +184,6 @@ renderRef (OCamlPrimitive primitive) = renderRef primitive - --- | Variable names for the members of constructors --- Used in pattern matches -constructorParameters :: Int -> OCamlValue -> [Doc] -constructorParameters _ OCamlEmpty = [ empty ] -constructorParameters i (Values l r) = - left ++ right - where - left = constructorParameters i l - right = constructorParameters (length left + i) r -constructorParameters i _ = [ "y" <> int i ] - instance HasDecoder OCamlConstructor where render (OCamlValueConstructor (NamedConstructor name value)) = do decoder <- render value @@ -215,74 +220,77 @@ <$$> "| exception Aeson.Decode.DecodeError message -> Js_result.Error message" render _ = pure "" - -renderResult :: Text -> OCamlDatatype -> Reader TypeMetaData Doc -renderResult jsonFieldname (OCamlDatatype _ datatypeName _constructor) = - pure - $ "(field" <+> dquotes (stext jsonFieldname) - <+> "(fun a -> unwrapResult (decode" <> (stext . textUppercaseFirst $ datatypeName) <+> "a)))" -renderResult jsonFieldname datatype@(OCamlPrimitive _primitive) = do - dv <- renderRef datatype - pure $ "(field" <+> dquotes (stext jsonFieldname) <+> dv <> ")" - + instance HasDecoder OCamlValue where render ref@(OCamlRef typeRef name) = do mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData case mOCamlTypeMetaData of Nothing -> fail $ "OCaml.BuckleScript.Decode (HasDecoder (OCamlRef typeRep name )) mOCamlTypeMetaData is Nothing:\n\n" ++ (show ref) - Just decOCamlTypeMetaData -> do + Just ocamlTypeRef -> do ds <- asks (dependencies . userOptions) - case Map.lookup typeRef ds of - Just parOCamlTypeMetaData -> do - let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData - pure $ "(fun a -> unwrapResult (" <> prefix <> "decode" <> (stext . textUppercaseFirst $ name) <+> "a))" + pure $ appendModule ds ocamlTypeRef typeRef 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 -> pure $ "(fun a -> unwrapResult (decode" <> (stext . textUppercaseFirst $ name) <+> "a))" + render ref@(OCamlRefApp typRep values) = do + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> fail $ "OCaml.BuckleScript.Record (HasType (OCamlDatatype typeRep name)) mOCamlTypeMetaData is Nothing:\n\n" ++ (show ref) + Just ocamlTypeRef -> do + ds <- asks (dependencies . userOptions) + dx <- renderRef values + pure $ appendModule ds ocamlTypeRef (typeRepToHaskellTypeMetaData typRep) (T.pack $ show $ fst $ splitTyConApp typRep) (wrapIfPrimitive values dx) render (OCamlPrimitiveRef primitive) = renderRef primitive - render (OCamlTypeParameterRef name) = - pure $ "(fun a -> unwrapResult (decode" <> (stext . textUppercaseFirst $ name) <+> "a))" + render (OCamlTypeParameterRef name) = pure $ "decode" <> (stext . textUppercaseFirst $ name) render (Values x y) = do dx <- render x dy <- render y - return $ dx <$$> ";" <+> dy + pure $ dx <$$> ";" <+> dy - render (OCamlField name (OCamlPrimitiveRef (OOption datatype))) = do - ao <- asks (aesonOptions . userOptions) - let jsonFieldname = T.pack . Aeson.fieldLabelModifier ao . T.unpack $ name - optional <- renderResult jsonFieldname datatype - return $ (stext name) <+> "=" <+> "optional" <+> optional <+> "json" + render (OCamlRefAppValues x y) = do + dx <- render x + dy <- render y + pure $ (wrapIfPrimitive x dx) <+> (wrapIfPrimitive y dy) render (OCamlField name value) = do ao <- asks (aesonOptions . userOptions) let jsonFieldname = T.pack . Aeson.fieldLabelModifier ao . T.unpack $ name dv <- render value - return $ (stext name) <+> "=" <+> "field" <+> dquotes (stext jsonFieldname) <+> dv <+> "json" + pure $ (stext name) <+> "=" <+> "field" <+> dquotes (stext jsonFieldname) <+> (unwrapIfTypeParameter value dv) <+> "json" - render OCamlEmpty = pure (stext "") + render OCamlEmpty = pure "" instance HasDecoder EnumeratorConstructor where render (EnumeratorConstructor name) = pure $ "| Some \"" <> stext name <> "\" -> Js_result.Ok" <+> stext name +instance HasDecoderRef OCamlValue where + renderRef (OCamlRefAppValues x y) = do + dx <- render x + dy <- render y + pure $ (wrapIfPrimitive x dx) <+> (wrapIfPrimitive y dy) + + renderRef (OCamlPrimitiveRef primitive) = renderRef primitive + + renderRef _ = pure "" + instance HasDecoderRef OCamlPrimitive where - renderRef OUnit = pure $ parens "()" - renderRef ODate = pure "date" - renderRef OInt = pure "int" renderRef OBool = pure "bool" - renderRef OChar = pure "char" + renderRef OChar = pure "string" + renderRef ODate = pure "date" renderRef OFloat = pure "Aeson.Decode.float" -- this is to prevent overshadowing warning + renderRef OInt = pure "int" renderRef OString = pure "string" + renderRef OUnit = pure $ parens "()" renderRef (OList (OCamlPrimitive OChar)) = pure "string" - renderRef (OList datatype) = do - dt <- renderRefWithUnwrapResult datatype - pure . parens $ "list" <+> dt + renderRef (OList v0) = do + dv0 <- renderRefWithUnwrapResult v0 + pure . parens $ "list" <+> dv0 - renderRef (OOption _) = pure "" + renderRef (OOption v0) = do + dv0 <- renderRefWithUnwrapResult v0 + pure . parens $ "optional" <+> dv0 renderRef (OEither v0 v1) = do dv0 <- renderRefWithUnwrapResult v0 @@ -325,8 +333,46 @@ pure $ parens $ "tuple6" <+> dv0 <+> dv1 <+> dv2 <+> dv3 <+> dv4 <+> dv5 -- Util +renderSumRecord :: Text -> OCamlConstructor -> Reader TypeMetaData (Maybe Doc) +renderSumRecord typeName (OCamlValueConstructor (RecordConstructor name value)) = do + let sumRecordName = typeName <> name + fnBody <- render (OCamlValueConstructor $ RecordConstructor (typeName <> name) value) + ocamlInterface <- asks (includeOCamlInterface . userOptions) + if ocamlInterface + then + pure $ Just $ "let decode" <> stext sumRecordName <+> "json =" <$$> fnBody + else + pure $ Just $ "let decode" <> stext sumRecordName <+> "(json : Js_json.t)" <+> ":(" <> (stext $ textLowercaseFirst sumRecordName) <> ", string)" <+> "Js_result.t =" <$$> fnBody +renderSumRecord _ _ = return Nothing + +-- | Variable names for the members of constructors +-- Used in pattern matches +constructorParameters :: Int -> OCamlValue -> [Doc] +constructorParameters _ OCamlEmpty = [ empty ] +constructorParameters i (Values l r) = + left ++ right + where + left = constructorParameters i l + right = constructorParameters (length left + i) r +constructorParameters i _ = [ "y" <> int i ] + renderRefWithUnwrapResult :: OCamlDatatype -> Reader TypeMetaData Doc +renderRefWithUnwrapResult (OCamlDatatype typeRef _ (OCamlValueConstructor (NamedConstructor _ (OCamlRefApp typRep values)))) = do + let name = "decode" <> (stext $ textUppercaseFirst $ T.pack $ show $ fst $ splitTyConApp typRep) + dx <- renderRef values + + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> pure $ parens $ name <+> (wrapIfPrimitive values dx) + Just decOCamlTypeMetaData -> do + ds <- asks (dependencies . userOptions) + case Map.lookup (typeRepToHaskellTypeMetaData typRep) ds of + Just parOCamlTypeMetaData -> do + let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData + pure $ parens $ "fun a -> unwrapResult (" <> prefix <> name <+> (wrapIfPrimitive values dx) <+> "a)" + Nothing -> fail ("OCaml.BuckleScript.Decode (HasDecoderRef OCamlDataType) expected to find dependency:\n\n" ++ show typeRef ++ "\n\nin\n\n" ++ show ds) + renderRefWithUnwrapResult datatype@(OCamlDatatype typeRef name _) = do if isTypeParameterRef datatype then @@ -366,7 +412,7 @@ let jsonConstructorName = T.pack . Aeson.constructorTagModifier ao . T.unpack $ name val <- render value renderSumCondition name $ parens - ("match Aeson.Decode." <> parens ("field \"contents\"" <+> val <+> "json") <+> "with" + ("match Aeson.Decode." <> parens ("field \"contents\"" <+> (unwrapIfTypeParameter value val) <+> "json") <+> "with" <$$> indent 1 ( "| v -> Js_result.Ok (" <> (stext name) <+> "v)" @@ -405,8 +451,8 @@ flattenOCamlValue val = [val] -- | Render the decoding of a constructor's arguments. Note the constructor must --- be from a data type with multiple constructors and that it has multiple --- constructors itself. +-- be from a data type with multiple constructors and that it has multiple +-- constructors itself. rArgs :: Text -> OCamlValue -> Reader TypeMetaData Doc rArgs name vals = do v <- mk name 0 $ (Just <$> flattenOCamlValue vals) ++ [Nothing] @@ -442,7 +488,7 @@ renderTypeParameterValsAux :: [OCamlValue] -> (Doc,Doc) renderTypeParameterValsAux ocamlValues = - let typeParameterNames = (<>) "'" <$> getTypeParameterRefNames ocamlValues + let typeParameterNames = (<>) "'" <$> (L.sort $ getTypeParameterRefNames ocamlValues) typeDecs = (foldl (<>) "" $ L.intersperse " -> " $ (\t -> "(Js_json.t -> (" <> (stext t) <> ", string) Js_result.t)") <$> typeParameterNames) <> " -> " in if length typeParameterNames > 0 @@ -482,25 +528,23 @@ Just $ "val decode" <> (stext $ typeName <> name) <+> ":" <+> "Js_json.t" <+> "->" <+> parens (stext (textLowercaseFirst $ typeName <> name) <> comma <+> "string") <+> "Js_result.t" renderSumRecordInterface _ _ = Nothing - --- Exported +-- | If this type comes from a different OCaml module, then add the appropriate module prefix and add unwrapResult to make the +-- types match +appendModule :: Map.Map HaskellTypeMetaData OCamlTypeMetaData -> OCamlTypeMetaData -> HaskellTypeMetaData -> Text -> Doc -> Doc +appendModule m o h name nxt = + case Map.lookup h m of + Just parOCamlTypeMetaData -> + (stext $ mkModulePrefix o parOCamlTypeMetaData) <> "decode" <> (stext $ textUppercaseFirst name) <+> nxt + -- 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 --- | Convert a 'Proxy a' into OCaml type to decode JSON function source code with an interface file '.mli'. -toOCamlDecoderInterfaceWith :: forall a. OCamlType a => Options -> a -> T.Text -toOCamlDecoderInterfaceWith options a = - case toOCamlType (Proxy :: Proxy a) of - OCamlDatatype haskellTypeMetaData _ _ -> - case Map.lookup haskellTypeMetaData (dependencies options) of - Just ocamlTypeMetaData -> pprinter $ runReader (renderInterface (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) - Nothing -> "" - _ -> pprinter $ runReader (renderInterface (toOCamlType a)) (TypeMetaData Nothing options) +wrapIfPrimitive :: OCamlValue -> Doc -> Doc +wrapIfPrimitive (OCamlPrimitiveRef _) doc = parens $ "wrapResult" <+> doc +wrapIfPrimitive _ doc = doc --- | Convert a 'Proxy a' into OCaml type to decode JSON function source code without an interface file '.mli'. -toOCamlDecoderSourceWith :: forall a. OCamlType a => Options -> a -> T.Text -toOCamlDecoderSourceWith options a = - case toOCamlType (Proxy :: Proxy a) of - OCamlDatatype haskellTypeMetaData _ _ -> - case Map.lookup haskellTypeMetaData (dependencies options) of - Just ocamlTypeMetaData -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) - Nothing -> "" - _ -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData Nothing options) +unwrapIfTypeParameter :: OCamlValue -> Doc -> Doc +unwrapIfTypeParameter (OCamlTypeParameterRef _) doc = parens $ "fun a -> unwrapResult" <+> (parens $ doc <+> "a") +unwrapIfTypeParameter (OCamlRef _ _) doc = parens $ "fun a -> unwrapResult" <+> (parens $ doc <+> "a") +unwrapIfTypeParameter (OCamlRefApp _ _) doc = parens $ "fun a -> unwrapResult" <+> (parens $ doc <+> "a") +unwrapIfTypeParameter _ doc = 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 @@ -24,6 +24,7 @@ import Data.Maybe (catMaybes) import Data.Monoid import Data.Proxy (Proxy (..)) +import Data.Typeable -- aeson import qualified Data.Aeson.Types as Aeson (Options(..)) @@ -42,6 +43,28 @@ import OCaml.BuckleScript.Types import OCaml.Internal.Common +-- | Convert a 'Proxy a' into OCaml type to JSON function source code which expects an interface file '.ml'. +toOCamlEncoderInterfaceWith :: forall a. OCamlType a => Options -> a -> T.Text +toOCamlEncoderInterfaceWith options a = + case toOCamlType (Proxy :: Proxy a) of + OCamlDatatype haskellTypeMetaData _ _ -> + case Map.lookup haskellTypeMetaData (dependencies options) of + Just ocamlTypeMetaData -> pprinter $ runReader (renderTypeInterface (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) + Nothing -> "" + _ -> pprinter $ runReader (renderTypeInterface (toOCamlType a)) (TypeMetaData Nothing options) + +-- | Convert a 'Proxy a' into OCaml type to JSON function source code without an interface file '.mli'. +toOCamlEncoderSourceWith :: forall a. OCamlType a => Options -> a -> T.Text +toOCamlEncoderSourceWith options a = + case toOCamlType (Proxy :: Proxy a) of + OCamlDatatype haskellTypeMetaData _ _ -> + case Map.lookup haskellTypeMetaData (dependencies options) of + Just ocamlTypeMetaData -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) + Nothing -> "" + _ -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData Nothing options) + +-- util + -- | Render the encoder function class HasEncoder a where render :: a -> Reader TypeMetaData Doc @@ -135,6 +158,25 @@ -- | 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) + dx <- renderRef values + + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> pure $ parens $ name <+> dx + Just decOCamlTypeMetaData -> do + ds <- asks (dependencies . userOptions) + case Map.lookup (typeRepToHaskellTypeMetaData typRep) ds of + Just parOCamlTypeMetaData -> do + let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData + pure $ parens $ prefix <> name <+> dx + + -- 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 -> pure $ parens $ name <+> dx + renderRef datatype@(OCamlDatatype typeRef name _) = do if isTypeParameterRef datatype then @@ -196,7 +238,121 @@ render _ = return "" +instance HasEncoder OCamlValue where + render (OCamlField name value) = do + valueBody <- render value + ao <- asks (aesonOptions . userOptions) + let jsonFieldname = T.pack . Aeson.fieldLabelModifier ao . T.unpack $ name + return . spaceparens $ + dquotes (stext jsonFieldname) <> comma <+> + (valueBody <+> "x." <> stext name) + render (OCamlTypeParameterRef name) = + pure $ "encode" <> (stext . textUppercaseFirst $ name) + + render (OCamlPrimitiveRef primitive) = renderRef primitive + + render ref@(OCamlRef typeRef name) = 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 typeRef name + + render ref@(OCamlRefApp typRep values) = 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) + dx <- renderRef values + pure $ parens $ + (stext $ appendModule ds ocamlTypeRef (typeRepToHaskellTypeMetaData typRep) + (T.pack $ show $ fst $ splitTyConApp typRep)) + <+> dx + + render (Values x y) = do + dx <- render x + dy <- render y + pure $ dx <$$> ";" <+> dy + + render (OCamlRefAppValues x y) = do + dx <- render x + dy <- render y + return $ dx <+> dy + + render OCamlEmpty = pure "" + +instance HasEncoderRef OCamlValue where + renderRef (OCamlRefAppValues x y) = do + dx <- render x + dy <- render y + pure $ dx <+> dy + + renderRef (OCamlPrimitiveRef primitive) = renderRef primitive + + renderRef _ = pure "" + +instance HasEncoderRef OCamlPrimitive where + renderRef OBool = pure "Aeson.Encode.bool" + renderRef OChar = pure "Aeson.Encode.string" + renderRef ODate = pure "Aeson.Encode.date" + renderRef OFloat = pure "Aeson.Encode.float" + renderRef OInt = pure "Aeson.Encode.int" + renderRef OString = pure "Aeson.Encode.string" + renderRef OUnit = pure "Aeson.Encode.null" + + renderRef (OList (OCamlPrimitive OChar)) = pure "Aeson.Encode.string" + + renderRef (OList datatype) = do + dd <- renderRef datatype + pure . parens $ "Aeson.Encode.list" <+> dd + + renderRef (OOption datatype) = do + dd <- renderRef datatype + pure . parens $ "Aeson.Encode.optional" <+> dd + + renderRef (OEither t0 t1) = do + dt0 <- renderRef t0 + dt1 <- renderRef t1 + pure . parens $ "Aeson.Encode.either" <+> dt0 <+> dt1 + + renderRef (OTuple2 t0 t1) = do + dt0 <- renderRef t0 + dt1 <- renderRef t1 + pure . parens $ "Aeson.Encode.pair" <+> dt0 <+> dt1 + + renderRef (OTuple3 t0 t1 t2) = do + dt0 <- renderRef t0 + dt1 <- renderRef t1 + dt2 <- renderRef t2 + pure . parens $ "Aeson.Encode.tuple3" <+> dt0 <+> dt1 <+> dt2 + + renderRef (OTuple4 t0 t1 t2 t3) = do + dt0 <- renderRef t0 + dt1 <- renderRef t1 + dt2 <- renderRef t2 + dt3 <- renderRef t3 + pure . parens $ "Aeson.Encode.tuple4" <+> dt0 <+> dt1 <+> dt2 <+> dt3 + + renderRef (OTuple5 t0 t1 t2 t3 t4) = do + dt0 <- renderRef t0 + dt1 <- renderRef t1 + dt2 <- renderRef t2 + dt3 <- renderRef t3 + dt4 <- renderRef t4 + pure . parens $ "Aeson.Encode.tuple5" <+> dt0 <+> dt1 <+> dt2 <+> dt3 <+> dt4 + + renderRef (OTuple6 t0 t1 t2 t3 t4 t5) = do + dt0 <- renderRef t0 + dt1 <- renderRef t1 + dt2 <- renderRef t2 + dt3 <- renderRef t3 + dt4 <- renderRef t4 + dt5 <- renderRef t5 + pure . parens $ "Aeson.Encode.tuple6" <+> dt0 <+> dt1 <+> dt2 <+> dt3 <+> dt4 <+> dt5 + -- | special rendering function for sum with record types renderSumRecord :: Text -> OCamlConstructor -> Reader TypeMetaData (Maybe Doc) renderSumRecord typeName (OCamlValueConstructor (RecordConstructor name value)) = do @@ -295,96 +451,6 @@ renderSum _ = return "" -instance HasEncoder OCamlValue where - render (OCamlField name value) = do - valueBody <- render value - ao <- asks (aesonOptions . userOptions) - let jsonFieldname = T.pack . Aeson.fieldLabelModifier ao . T.unpack $ name - return . spaceparens $ - dquotes (stext jsonFieldname) <> comma <+> - (valueBody <+> "x." <> stext name) - render (OCamlTypeParameterRef name) = - pure $ "encode" <> (stext . textUppercaseFirst $ name) - render (OCamlPrimitiveRef primitive) = renderRef primitive - render ref@(OCamlRef typeRef name) = do - mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData - case mOCamlTypeMetaData of - Nothing -> fail $ "OCaml.BuckleScript.Encode (HasEncoder (OCamlRef typeRep name)) mOCamlTypeMetaData is Nothing:\n\n" ++ (show ref) - Just decOCamlTypeMetaData -> do - ds <- asks (dependencies . userOptions) - case Map.lookup typeRef ds of - Just parOCamlTypeMetaData -> do - let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData - pure $ prefix <> "encode" <> (stext . 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 -> pure $ "encode" <> (stext . textUppercaseFirst $ name) - - render (Values x y) = do - dx <- render x - dy <- render y - return $ dx <$$> ";" <+> dy - render _ = error "HasEncoderRef OCamlValue: should not happen" - -instance HasEncoderRef OCamlPrimitive where - renderRef ODate = pure "Aeson.Encode.date" - renderRef OUnit = pure "Aeson.Encode.null" - renderRef OInt = pure "Aeson.Encode.int" - renderRef OChar = pure "Aeson.Encode.string" - renderRef OBool = pure "Aeson.Encode.bool" - renderRef OFloat = pure "Aeson.Encode.float" - renderRef OString = pure "Aeson.Encode.string" - renderRef (OList (OCamlPrimitive OChar)) = pure "Aeson.Encode.string" - - renderRef (OList datatype) = do - dd <- renderRef datatype - pure . parens $ "Aeson.Encode.list" <+> dd - - renderRef (OOption datatype) = do - dd <- renderRef datatype - pure . parens $ "Aeson.Encode.optional" <+> dd - - renderRef (OEither t0 t1) = do - dt0 <- renderRef t0 - dt1 <- renderRef t1 - pure . parens $ "Aeson.Encode.either" <+> dt0 <+> dt1 - - renderRef (OTuple2 t0 t1) = do - dt0 <- renderRef t0 - dt1 <- renderRef t1 - pure . parens $ "Aeson.Encode.pair" <+> dt0 <+> dt1 - - renderRef (OTuple3 t0 t1 t2) = do - dt0 <- renderRef t0 - dt1 <- renderRef t1 - dt2 <- renderRef t2 - pure . parens $ "Aeson.Encode.tuple3" <+> dt0 <+> dt1 <+> dt2 - - renderRef (OTuple4 t0 t1 t2 t3) = do - dt0 <- renderRef t0 - dt1 <- renderRef t1 - dt2 <- renderRef t2 - dt3 <- renderRef t3 - pure . parens $ "Aeson.Encode.tuple4" <+> dt0 <+> dt1 <+> dt2 <+> dt3 - - renderRef (OTuple5 t0 t1 t2 t3 t4) = do - dt0 <- renderRef t0 - dt1 <- renderRef t1 - dt2 <- renderRef t2 - dt3 <- renderRef t3 - dt4 <- renderRef t4 - pure . parens $ "Aeson.Encode.tuple5" <+> dt0 <+> dt1 <+> dt2 <+> dt3 <+> dt4 - - renderRef (OTuple6 t0 t1 t2 t3 t4 t5) = do - dt0 <- renderRef t0 - dt1 <- renderRef t1 - dt2 <- renderRef t2 - dt3 <- renderRef t3 - dt4 <- renderRef t4 - dt5 <- renderRef t5 - pure . parens $ "Aeson.Encode.tuple6" <+> dt0 <+> dt1 <+> dt2 <+> dt3 <+> dt4 <+> dt5 - -- | Variable names for the members of constructors -- Used in pattern matches constructorParameters :: Int -> OCamlValue -> [Doc] @@ -396,7 +462,6 @@ right = constructorParameters (length left + i) r constructorParameters i _ = [ "y" <> int i ] - -- | render JSON encoders for OCamlValues. It runs recersively on Values. -- [Doc] helps build encoders for arrays and tuples -- should only use fst of return type, snd [Doc] is to help with recursion @@ -404,6 +469,9 @@ renderVariable (d : ds) v@(OCamlRef {}) = do v' <- render v return (v' <+> d, ds) +renderVariable (d : ds) v@(OCamlRefApp {}) = do + v' <- render v + return (v' <+> d, ds) renderVariable ds OCamlEmpty = return (empty, ds) renderVariable (_ : ds) (OCamlPrimitiveRef OUnit) = return ("Aeson.Encode.null", ds) @@ -417,9 +485,14 @@ (left, dsl) <- renderVariable ds l (right, dsr) <- renderVariable dsl r return (left <+> ";" <+> right, dsr) +renderVariable ds (OCamlRefAppValues l r) = do + (left, dsl) <- renderVariable ds l + (right, dsr) <- renderVariable dsl r + return (left <+> ";" <+> right, dsr) renderVariable ds f@(OCamlField _ _) = do f' <- render f return (f', ds) + renderVariable [] _ = error "Amount of variables does not match variables." -- Util @@ -439,7 +512,7 @@ -- | Helper function for renderTypeParameterVals renderTypeParameterValsAux :: [OCamlValue] -> (Doc,Doc) renderTypeParameterValsAux ocamlValues = - let typeParameterNames = (<>) "'" <$> getTypeParameterRefNames ocamlValues + let typeParameterNames = (<>) "'" <$> (L.sort $ getTypeParameterRefNames ocamlValues) typeDecs = (\t -> "(" <> (stext t) <+> "-> Js_json.t)") <$> typeParameterNames in if length typeDecs > 0 @@ -475,25 +548,14 @@ -- `Either a b`: `"encodeA0 encodeA1"` renderEncodeTypeParameters :: OCamlConstructor -> Doc renderEncodeTypeParameters constructor = - foldl (<>) "" $ stext <$> L.intersperse " " ((\t -> "encode" <> (textUppercaseFirst t)) <$> getTypeParameters constructor) - - --- | Convert a 'Proxy a' into OCaml type to JSON function source code which expects an interface file '.ml'. -toOCamlEncoderInterfaceWith :: forall a. OCamlType a => Options -> a -> T.Text -toOCamlEncoderInterfaceWith options a = - case toOCamlType (Proxy :: Proxy a) of - OCamlDatatype haskellTypeMetaData _ _ -> - case Map.lookup haskellTypeMetaData (dependencies options) of - Just ocamlTypeMetaData -> pprinter $ runReader (renderTypeInterface (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) - Nothing -> "" - _ -> pprinter $ runReader (renderTypeInterface (toOCamlType a)) (TypeMetaData Nothing options) + foldl (<>) "" $ stext <$> L.intersperse " " ((\t -> "encode" <> (textUppercaseFirst t)) <$> (L.sort (getTypeParameters constructor))) --- | Convert a 'Proxy a' into OCaml type to JSON function source code without an interface file '.mli'. -toOCamlEncoderSourceWith :: forall a. OCamlType a => Options -> a -> T.Text -toOCamlEncoderSourceWith options a = - case toOCamlType (Proxy :: Proxy a) of - OCamlDatatype haskellTypeMetaData _ _ -> - case Map.lookup haskellTypeMetaData (dependencies options) of - Just ocamlTypeMetaData -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) - Nothing -> "" - _ -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData Nothing options) +-- | If this type comes from a different OCaml module, then add the appropriate module prefix +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) <> "encode" <> (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 -> "encode" <> textUppercaseFirst name 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 @@ -19,10 +19,11 @@ -- base import Control.Monad.Reader -import Data.List (nub) +import Data.List (nub, sort) import Data.Maybe (catMaybes) import Data.Monoid import Data.Proxy (Proxy (..)) +import Data.Typeable -- containers import qualified Data.Map.Strict as Map @@ -38,20 +39,34 @@ -- wl-pprint import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) +-- | Convert a 'Proxy a' into OCaml type source code. +toOCamlTypeSourceWith :: forall a. OCamlType a => Options -> a -> T.Text +toOCamlTypeSourceWith options a = + case toOCamlType (Proxy :: Proxy a) of + OCamlDatatype haskellTypeMetaData _ _ -> + case Map.lookup haskellTypeMetaData (dependencies options) of + Just ocamlTypeMetaData -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) + Nothing -> "" + _ -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData Nothing options) + +-- Internal functions to convert OCamlDatatype into BuckleScript source code. + -- | render a Haskell data type in OCaml class HasType a where render :: a -> Reader TypeMetaData Doc +-- | render the rows of a record type class HasRecordType a where renderRecord :: a -> Reader TypeMetaData Doc +-- | render a type as a reference, not its implementation details class HasTypeRef a where renderRef :: a -> Reader TypeMetaData Doc instance HasType OCamlDatatype where render datatype@(OCamlDatatype _mOCamlTypeDataType typeName constructor@(OCamlSumOfRecordConstructor _ (MultipleConstructors constructors))) = do -- For each constructor, if it is a record constructor, declare a type for that record - -- before and separate form the main sum type. + -- before and separate from the main sum type. sumRecordsData <- catMaybes <$> sequence (renderSumRecord typeName <$> constructors) let sumRecords = msuffix (line <> line) (fst <$> sumRecordsData) newConstructors = replaceRecordConstructors (snd <$> sumRecordsData) <$> constructors @@ -75,6 +90,20 @@ render (OCamlPrimitive primitive) = renderRef primitive instance HasTypeRef OCamlDatatype where + renderRef (OCamlDatatype _ _ (OCamlValueConstructor (NamedConstructor _ (OCamlRefApp typRep values)))) = do + dx <- renderRef values + let name = stext . textLowercaseFirst . T.pack . show $ typeRepTyCon typRep + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> pure $ (parensIfNotBlank dx) <+> name + Just decOCamlTypeMetaData -> do + ds <- asks (dependencies . userOptions) + case Map.lookup (typeRepToHaskellTypeMetaData typRep) ds of + Just parOCamlTypeMetaData -> do + let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData + pure $ (parensIfNotBlank dx) <+> prefix <> name + Nothing -> fail ("expected to find dependency:\n\n" ++ "\n\nin\n\n" ++ show ds) + renderRef datatype@(OCamlDatatype typeRef typeName _) = do if isTypeParameterRef datatype then @@ -94,95 +123,140 @@ renderRef (OCamlPrimitive primitive) = renderRef primitive +instance HasTypeRef OCamlValue where + renderRef (OCamlRefAppValues x y) = do + dx <- render x + dy <- render y + pure $ dx <> comma <+> dy + + renderRef (OCamlPrimitiveRef primitive) = renderRef primitive + renderRef _ = pure "" + instance HasType OCamlConstructor where render (OCamlValueConstructor value) = render value render (OCamlSumOfRecordConstructor _ value) = render value - render (OCamlEnumeratorConstructor constructors) = do + render (OCamlEnumeratorConstructor constructors) = mintercalate (line <> "|" <> space) <$> sequence (render <$> constructors) instance HasType ValueConstructor where - -- record + -- record constructor render (RecordConstructor _ value) = do fields <- renderRecord value pure $ "{" <+> fields <$$> "}" - -- enumerator + -- enumerator constructor render (NamedConstructor constructorName (OCamlEmpty)) = do pure $ stext constructorName - -- product + -- constructor with one or more values render (NamedConstructor constructorName value) = do types <- render value pure $ stext constructorName <+> "of" <+> types - -- sum + -- multiple constructors (sum type) render (MultipleConstructors constructors) = do mintercalate (line <> "|" <> space) <$> sequence (render <$> constructors) instance HasType EnumeratorConstructor where render (EnumeratorConstructor name) = pure (stext name) - + instance HasType OCamlValue where render ref@(OCamlRef typeRef name) = do mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData case mOCamlTypeMetaData of Nothing -> fail $ "OCaml.BuckleScript.Record (HasType (OCamlDatatype typeRep name)) mOCamlTypeMetaData is Nothing:\n\n" ++ (show ref) - Just decOCamlTypeMetaData -> do + Just ocamlTypeRef -> do ds <- asks (dependencies . userOptions) - case Map.lookup typeRef ds of - Just parOCamlTypeMetaData -> do - let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData - pure $ prefix <> (stext . textLowercaseFirst $ 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 -> pure . stext . textLowercaseFirst $ name + pure . stext $ appendModule ds ocamlTypeRef typeRef name - render (OCamlTypeParameterRef name) = pure (stext ("'" <> name)) + render (OCamlRefApp typRep values) = do + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> fail $ "OCaml.BuckleScript.Record (HasType (OCamlDatatype typeRep name)) mOCamlTypeMetaData is Nothing:\n\n" + Just ocamlTypeRef -> do + ds <- asks (dependencies . userOptions) + dx <- renderRef values + pure $ (parensIfNotBlank dx) <+> (stext $ appendModule ds ocamlTypeRef (typeRepToHaskellTypeMetaData typRep) (T.pack . show $ typeRepTyCon typRep)) + + render (OCamlTypeParameterRef name) = pure $ stext ("'" <> name) + render (OCamlPrimitiveRef primitive) = ocamlRefParens primitive <$> renderRef primitive - render OCamlEmpty = pure (text "") + render (Values x y) = do dx <- render x dy <- render y - return $ dx <+> "*" <+> dy + pure $ dx <+> "*" <+> dy + + render (OCamlRefAppValues x y) = do + dx <- render x + dy <- render y + pure $ dx <> comma <+> dy + render (OCamlField name value) = do dv <- renderRecord value - return $ stext name <+> ":" <+> dv + pure $ stext name <+> ":" <+> dv + render OCamlEmpty = pure "" + instance HasRecordType OCamlValue where - renderRecord (OCamlPrimitiveRef primitive) = renderRef primitive renderRecord (Values x y) = do dx <- renderRecord x dy <- renderRecord y - return $ dx <$$> ";" <+> dy + pure $ dx <$$> ";" <+> dy + + renderRecord (OCamlPrimitiveRef primitive) = renderRef primitive renderRecord value = render value instance HasTypeRef OCamlPrimitive where + renderRef OBool = pure "bool" + renderRef OChar = pure "string" + renderRef ODate = pure "Js_date.t" + renderRef OFloat = pure "float" + renderRef OInt = pure "int" + renderRef OString = pure "string" + renderRef OUnit = pure "unit" + renderRef (OList (OCamlPrimitive OChar)) = renderRef OString + renderRef (OList datatype) = do dt <- renderRef datatype - return $ parens dt <+> "list" + pure $ parens dt <+> "list" + + renderRef (OOption datatype) = do + dt <- renderRef datatype + pure $ parens dt <+> "option" + + renderRef (OEither k v) = do + dk <- renderRef k + dv <- renderRef v + pure $ (parens $ dk <> comma <+> dv) <+> "Aeson.Compatibility.Either.t" + renderRef (OTuple2 a b) = do da <- renderRef a db <- renderRef b - return . parens $ da <+> "*" <+> db + pure . parens $ da <+> "*" <+> db + renderRef (OTuple3 a b c) = do da <- renderRef a db <- renderRef b dc <- renderRef c - return . parens $ da <+> "*" <+> db <+> "*" <+> dc + pure . parens $ da <+> "*" <+> db <+> "*" <+> dc + renderRef (OTuple4 a b c d) = do da <- renderRef a db <- renderRef b dc <- renderRef c dd <- renderRef d - return . parens $ da <+> "*" <+> db <+> "*" <+> dc <+> "*" <+> dd + pure . parens $ da <+> "*" <+> db <+> "*" <+> dc <+> "*" <+> dd + renderRef (OTuple5 a b c d e) = do da <- renderRef a db <- renderRef b dc <- renderRef c dd <- renderRef d de <- renderRef e - return . parens $ da <+> "*" <+> db <+> "*" <+> dc <+> "*" <+> dd <+> "*" <+> de + pure . parens $ da <+> "*" <+> db <+> "*" <+> dc <+> "*" <+> dd <+> "*" <+> de + renderRef (OTuple6 a b c d e f) = do da <- renderRef a db <- renderRef b @@ -190,21 +264,7 @@ dd <- renderRef d de <- renderRef e df <- renderRef f - return . parens $ da <+> "*" <+> db <+> "*" <+> dc <+> "*" <+> dd <+> "*" <+> de <+> "*" <+> df - renderRef (OOption datatype) = do - dt <- renderRef datatype - return $ parens dt <+> "option" - renderRef (OEither k v) = do - dk <- renderRef k - dv <- renderRef v - return $ (parens $ dk <> "," <+> dv) <+> "Aeson.Compatibility.Either.t" - renderRef OInt = pure "int" - renderRef ODate = pure "Js_date.t" - renderRef OBool = pure "bool" - renderRef OChar = pure "string" - renderRef OString = pure "string" - renderRef OUnit = pure "unit" - renderRef OFloat = pure "float" + pure . parens $ da <+> "*" <+> db <+> "*" <+> dc <+> "*" <+> dd <+> "*" <+> de <+> "*" <+> df -- Util functions @@ -227,7 +287,7 @@ -- (Maybe a) -> 'a0 list -> ["'a0"] -- (Either a b) -> 'a0 'a1 list -> ["'a0","'a1"] renderTypeParameters :: OCamlConstructor -> Doc -renderTypeParameters constructor = mkDocList $ stext . (<>) "'" <$> (nub $ getTypeParameters constructor) +renderTypeParameters constructor = mkDocList $ stext . (<>) "'" <$> sort (nub $ getTypeParameters constructor) -- | For Haskell Sum of Records, create OCaml record types of each RecordConstructor renderSumRecord :: Text -> ValueConstructor -> Reader TypeMetaData (Maybe (Doc,(Text,ValueConstructor))) @@ -235,8 +295,18 @@ let sumRecordName = typeName <> name functionBody <- render constructor pure $ Just (("type" <+> (stext (textLowercaseFirst sumRecordName)) <+> "=" <$$> indent 2 functionBody), (name, (RecordConstructor sumRecordName value))) -renderSumRecord _ _ = return Nothing +renderSumRecord _ _ = pure Nothing +-- | If this type comes from a different OCaml module, then add the appropriate module prefix +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) <> (textLowercaseFirst 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 -> textLowercaseFirst name + -- | Puts parentheses around the doc of an OCaml ref if it contains spaces. ocamlRefParens :: OCamlPrimitive -> Doc -> Doc ocamlRefParens (OList (OCamlPrimitive OChar)) = id @@ -244,12 +314,5 @@ ocamlRefParens (OOption _) = parens ocamlRefParens _ = id --- | Convert a 'Proxy a' into OCaml type source code. -toOCamlTypeSourceWith :: forall a. OCamlType a => Options -> a -> T.Text -toOCamlTypeSourceWith options a = - case toOCamlType (Proxy :: Proxy a) of - OCamlDatatype haskellTypeMetaData _ _ -> - case Map.lookup haskellTypeMetaData (dependencies options) of - Just ocamlTypeMetaData -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData (Just ocamlTypeMetaData) options) - Nothing -> "" - _ -> pprinter $ runReader (render (toOCamlType a)) (TypeMetaData Nothing options) +parensIfNotBlank :: Doc -> Doc +parensIfNotBlank d = let dx = show d in if (length dx) > 0 && dx /= " " then parens d else d 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 @@ -51,6 +51,10 @@ , isTypeParameterRef , mkModulePrefix , oCamlValueIsFloat + + -- Typeable functions + , typeRepToHaskellTypeMetaData + , tyConToHaskellTypeMetaData ) where -- base @@ -66,6 +70,8 @@ import GHC.TypeLits (symbolVal, KnownSymbol) import Prelude +import qualified Data.Map as Map + -- aeson import Data.Aeson (ToJSON, FromJSON) -- bytestring @@ -107,11 +113,11 @@ -- | Smallest unit of computation in OCaml. data OCamlPrimitive - = OInt -- ^ int - | OBool -- ^ bool, boolean + = OBool -- ^ bool, boolean | OChar -- ^ char, it gets interpreted as a string because OCaml char does not support UTF-8 | ODate -- ^ Js_date.t | OFloat -- ^ float + | OInt -- ^ int | OString -- ^ string | OUnit -- ^ () | OList OCamlDatatype -- ^ 'a list, 'a Js_array.t @@ -128,7 +134,7 @@ data OCamlConstructor = OCamlValueConstructor ValueConstructor -- ^ Sum, record (product with named fields) or product without named fields | OCamlEnumeratorConstructor [EnumeratorConstructor] -- ^ Sum of enumerations only. If a sum contains enumerators and at least one constructor with a value then it is an OCamlValueConstructor - | OCamlSumOfRecordConstructor Text ValueConstructor -- ^ Sum that contains at least one record. This construction is unique to Haskell. pIt has special Encoding and Decoding rules in order to output a valid OCaml program. i.e. `data A = A {a :: Int} | B {b :: String}` + | OCamlSumOfRecordConstructor Text ValueConstructor -- ^ Sum that contains at least one record. This construction is unique to Haskell. It has special Encoding and Decoding rules in order to output a valid OCaml program. i.e. `data A = A {a :: Int} | B {b :: String}` deriving (Show, Eq) -- | OCamlConstructor of one RecordConstructor is a record type. @@ -150,13 +156,15 @@ -- | Expected types of a constructor 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 sum type + | 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 Values. deriving (Show, Eq) - +-- -- ^ ------------------------------------------------------------ -- | Create an OCaml type from a Haskell type. Use the Generic -- definition when possible. It also expects `ToJSON` and `FromJSON` @@ -209,8 +217,6 @@ then transformToSumOfRecord (T.pack (datatypeName datatype)) ocamlConstructor else ocamlConstructor - - ------------------------------------------------------------ class GenericValueConstructor f where genericToValueConstructor :: f a -> ValueConstructor @@ -258,18 +264,150 @@ instance GenericOCamlValue U1 where genericToOCamlValue _ = OCamlEmpty --- | Handle type parameter. -instance OCamlType a => GenericOCamlValue (Rec0 a) where - genericToOCamlValue _ = - case toOCamlType (Proxy :: Proxy a) of - OCamlPrimitive primitive -> OCamlPrimitiveRef primitive - OCamlDatatype haskellTypeMetaData name _ -> mkRef haskellTypeMetaData name - where - typeParameterRefs = (T.append) <$> ["a"] <*> (T.pack . show <$> ([0..5] :: [Int])) - mkRef haskellTypeMetaData n - | n `elem` typeParameterRefs = OCamlTypeParameterRef n - | otherwise = OCamlRef haskellTypeMetaData n +-- | Handle type parameter. There are found in the order of declaration on the right hand side of a type. +-- Reordering may be necessary for TypeParameterRefs. +instance Typeable a => GenericOCamlValue (Rec0 a) where + genericToOCamlValue _ = typeRepToOCamlValue $ typeRep (Proxy :: Proxy a) +typeRepToOCamlValue :: TypeRep -> OCamlValue +typeRepToOCamlValue t = + -- check if the type is a primitive + case Map.lookup hd typeParameterRefTyConToOCamlTypeText of + Just p -> OCamlTypeParameterRef p + Nothing -> + case primitiveTypeRepToOCamlPrimitive t of + Just primitive -> OCamlPrimitiveRef primitive + Nothing -> + -- if it has no typeParams then it mkRef + if length typeParams == 0 + then mkRef (tyConToHaskellTypeMetaData hd) (T.pack . show $ hd) + else OCamlRefApp t (mkValues) + where + (hd, typeParams) = splitTyConApp t + + typeParameterRefs = (T.append) <$> ["a"] <*> (T.pack . show <$> ([0..5] :: [Int])) + + mkRef haskellTypeMetaData n = + if n `elem` typeParameterRefs + then OCamlTypeParameterRef n + else OCamlRef haskellTypeMetaData n + + mkValues = + if length typeParams == 0 + then OCamlEmpty + else + if length typeParams == 1 + then typeRepToOCamlValue $ head typeParams -- Values (typeRepToOCamlValue $ head typeParams) OCamlEmpty + else + if length typeParams == 2 + then OCamlRefAppValues (typeRepToOCamlValue $ head typeParams) (typeRepToOCamlValue $ head $ tail typeParams) + else OCamlRefAppValues (typeRepToOCamlValue $ head typeParams) (foldl (\b a -> OCamlRefAppValues b (typeRepToOCamlValue a)) (typeRepToOCamlValue $ head $ tail typeParams) (tail $ tail typeParams)) + +primitiveTypeRepToOCamlPrimitive :: TypeRep -> Maybe OCamlPrimitive +primitiveTypeRepToOCamlPrimitive t = + mkOCamlPrimitive $ length typeParams + where + (hd, typeParams) = splitTyConApp t + mkOCamlPrimitive l + | l == 0 = Map.lookup hd zero + | l == 1 = one hd (typeParams !! 0) + | l == 2 = two hd (typeParams !! 0) (typeParams !! 1) + | l == 3 = three hd (typeParams !! 0) (typeParams !! 1) (typeParams !! 2) + | l == 4 = four hd (typeParams !! 0) (typeParams !! 1) (typeParams !! 2) (typeParams !! 3) + | l == 5 = five hd (typeParams !! 0) (typeParams !! 1) (typeParams !! 2) (typeParams !! 3) (typeParams !! 4) + | l == 6 = six hd (typeParams !! 0) (typeParams !! 1) (typeParams !! 2) (typeParams !! 3) (typeParams !! 4) (typeParams !! 5) + | otherwise = Nothing + + zero :: Map.Map TyCon OCamlPrimitive + zero = Map.fromList + [ ( typeRepTyCon $ typeRep (Proxy :: Proxy Int), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Int8), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Int16), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Int32), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Int64), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Integer), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word8), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word16), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word32), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word64), OInt) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Bool), OBool) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Char), OChar) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy UTCTime), ODate) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Float), OFloat) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Double), OFloat) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Text), OString) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy ByteString), OString) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy String), OString) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy ()), OUnit) + ] + + one :: TyCon -> TypeRep -> Maybe OCamlPrimitive + one tyCon t0 = + if tyCon == (typeRepTyCon $ typeRep (Proxy :: Proxy [])) + then Just $ OList $ mkOCamlDatatype t0 + else + if tyCon == (typeRepTyCon $ typeRep (Proxy :: Proxy Maybe)) + then Just $ OOption $ mkOCamlDatatype t0 + else Nothing + + two :: TyCon -> TypeRep -> TypeRep -> Maybe OCamlPrimitive + two tyCon t0 t1 = + if tyCon == (typeRepTyCon $ typeRep (Proxy :: Proxy Either)) + then Just $ OEither (mkOCamlDatatype t0) (mkOCamlDatatype t1) + else + if tyCon == (typeRepTyCon $ typeRep (Proxy :: Proxy (,))) + then Just $ OTuple2 (mkOCamlDatatype t0) (mkOCamlDatatype t1) + else Nothing + + three :: TyCon -> TypeRep -> TypeRep -> TypeRep -> Maybe OCamlPrimitive + three tyCon t0 t1 t2 = + if tyCon == (typeRepTyCon $ typeRep (Proxy :: Proxy (,,))) + then Just $ OTuple3 (mkOCamlDatatype t0) (mkOCamlDatatype t1) (mkOCamlDatatype t2) + else Nothing + + four :: TyCon -> TypeRep -> TypeRep -> TypeRep -> TypeRep -> Maybe OCamlPrimitive + four tyCon t0 t1 t2 t3 = + if tyCon == (typeRepTyCon $ typeRep (Proxy :: Proxy (,,,))) + then Just $ OTuple4 (mkOCamlDatatype t0) (mkOCamlDatatype t1) (mkOCamlDatatype t2) (mkOCamlDatatype t3) + else Nothing + + five :: TyCon -> TypeRep -> TypeRep -> TypeRep -> TypeRep -> TypeRep -> Maybe OCamlPrimitive + five tyCon t0 t1 t2 t3 t4 = + if tyCon == (typeRepTyCon $ typeRep (Proxy :: Proxy (,,,,))) + then Just $ OTuple5 (mkOCamlDatatype t0) (mkOCamlDatatype t1) (mkOCamlDatatype t2) (mkOCamlDatatype t3) (mkOCamlDatatype t4) + else Nothing + + six :: TyCon -> TypeRep -> TypeRep -> TypeRep -> TypeRep -> TypeRep -> TypeRep -> Maybe OCamlPrimitive + six tyCon t0 t1 t2 t3 t4 t5 = + if tyCon == (typeRepTyCon $ typeRep (Proxy :: Proxy (,,,,,))) + then Just $ OTuple6 (mkOCamlDatatype t0) (mkOCamlDatatype t1) (mkOCamlDatatype t2) (mkOCamlDatatype t3) (mkOCamlDatatype t4) (mkOCamlDatatype t5) + else Nothing + + typeParameterRefMap = Map.fromList + [ ("TypeParameterRef0", toOCamlType (Proxy :: Proxy TypeParameterRef0)) + , ("TypeParameterRef1", toOCamlType (Proxy :: Proxy TypeParameterRef1)) + , ("TypeParameterRef2", toOCamlType (Proxy :: Proxy TypeParameterRef2)) + , ("TypeParameterRef3", toOCamlType (Proxy :: Proxy TypeParameterRef3)) + , ("TypeParameterRef4", toOCamlType (Proxy :: Proxy TypeParameterRef4)) + , ("TypeParameterRef5", toOCamlType (Proxy :: Proxy TypeParameterRef5)) + ] + + mkOCamlDatatype x = + case primitiveTypeRepToOCamlPrimitive x of + Just primitive -> OCamlPrimitive primitive + Nothing -> + case Map.lookup aTyConName typeParameterRefMap of + Just tref -> tref + Nothing -> + OCamlDatatype + (tyConToHaskellTypeMetaData tyc) + aTyConName + (OCamlValueConstructor . NamedConstructor aTyConName $ typeRepToOCamlValue x) + where + tyc = typeRepTyCon x + aTyConName = T.pack . show $ tyc + -- OCamlType instances for primitives instance OCamlType a => OCamlType [a] where @@ -372,7 +510,6 @@ (toOCamlType (Proxy :: Proxy c)) (toOCamlType (Proxy :: Proxy d)) (toOCamlType (Proxy :: Proxy e)) (toOCamlType (Proxy :: Proxy f)) - instance (OCamlType a) => OCamlType (Proxy a) where toOCamlType _ = toOCamlType (undefined :: a) @@ -381,11 +518,19 @@ -- ToJSON and FromJSON instances are provided for the following types in aeson -- not currently defined here -- Map, LocalTime, ZonedTime, IntSet, CTime, Version, Natural --- TimeOfDay, UTCTime, NominalDiffTime, Day, DiffTime, UUID, DotNetTime +-- TimeOfDay, NominalDiffTime, Day, DiffTime, UUID, DotNetTime -- Value, Dual, First, Last, IntMap, Tree, Seq, Vector, HashSet, Proxy -- Const Tagged, Dual, First, Last, tuple up to length of 15 -} +-- | for any type that does not use the same serialization as Generic Aeson +-- and has a manually written OCaml definition, should manually derive OCamlType +-- using this function for convenience. +-- +-- instance OCamlType X where +-- toOCamlType _ = typeableToOCamlType (Proxy :: Proxy X) +-- + typeableToOCamlType :: forall a. Typeable a => Proxy a -> OCamlDatatype typeableToOCamlType Proxy = OCamlDatatype @@ -495,12 +640,13 @@ isSumWithRecord :: OCamlConstructor -> Bool isSumWithRecord (OCamlValueConstructor (MultipleConstructors cs)) = - -- if there is only one constructor than it is not a SumWithRecords. + -- if there is only one constructor then it is not a SumWithRecords. -- if there are multiple constructors and at least one is a record constructor - -- than it is a SumWithRecords + -- then it is a SumWithRecords (\x -> length x > 1 && or x) $ isSumWithRecordsAux . OCamlValueConstructor <$> cs where isSumWithRecordsAux :: OCamlConstructor -> Bool + isSumWithRecordsAux (OCamlValueConstructor (MultipleConstructors cs')) = or $ isSumWithRecordsAux . OCamlValueConstructor <$> cs' isSumWithRecordsAux (OCamlValueConstructor (RecordConstructor _ _)) = True isSumWithRecordsAux _ = False isSumWithRecord _ = False @@ -515,6 +661,7 @@ match value = case value of + (OCamlRefApp typRep _) -> getTypeParameterRefNameForTypeRep typRep (OCamlTypeParameterRef name) -> [name] (Values v1 v2) -> match v1 ++ match v2 (OCamlField _ v1) -> match v1 @@ -533,7 +680,7 @@ getOCamlValues (RecordConstructor _ value) = [value] getOCamlValues (MultipleConstructors cs) = concat $ getOCamlValues <$> cs --- | getTypePar +-- | get all of the type parameters from an OCamlConstructor. getTypeParameters :: OCamlConstructor -> [Text] getTypeParameters (OCamlValueConstructor vc) = getTypeParameterRefNames . getOCamlValues $ vc getTypeParameters (OCamlSumOfRecordConstructor _ vc) = getTypeParameterRefNames . getOCamlValues $ vc @@ -545,6 +692,21 @@ isTypeParameterRef (OCamlDatatype _ _ (OCamlValueConstructor (NamedConstructor _ (OCamlTypeParameterRef _)))) = True isTypeParameterRef _ = False +-- | When there is a record that has its type parameters partially filled, it will should have TypeParameterRef0-5 as the +-- unfilled type parameters. This function properly pushes the TypeParameterRef0-5 to the type signature of an OCaml +-- type. +getTypeParameterRefNameForTypeRep :: TypeRep -> [Text] +getTypeParameterRefNameForTypeRep t = + if length rst == 0 + then typeParamterRefText + else typeParamterRefText <> concat (getTypeParameterRefNameForTypeRep <$> rst) + where + (hd,rst) = splitTyConApp $ t + typeParamterRefText = + case Map.lookup hd typeParameterRefTyConToOCamlTypeText of + Just typeParamterRefText' -> [typeParamterRefText'] + Nothing -> [] + -- | Make OCaml module prefix for a value based on the declaration's and parameter's meta data. mkModulePrefix :: OCamlTypeMetaData -> OCamlTypeMetaData -> Text mkModulePrefix (OCamlTypeMetaData _ decModules decSubModules) (OCamlTypeMetaData _ parModules parSubModules) = @@ -573,3 +735,119 @@ oCamlValueIsFloat :: OCamlValue -> Bool oCamlValueIsFloat (OCamlPrimitiveRef OFloat) = True oCamlValueIsFloat _ = False + + +-- Typeable related functions +-- when a row is a type with type parameters and those type parameters are filled, +-- we need a way to extract what those type parameters are. This is not possible with +-- Generics, but it can be done with Typeable. + +-- | match type parameter reference 'TyCon's (accessible from a TypeRep) to their equivalent OCaml types. +typeParameterRefTyConToOCamlTypeText :: Map.Map TyCon Text +typeParameterRefTyConToOCamlTypeText = Map.fromList + [ ( typeRepTyCon $ typeRep (Proxy :: Proxy TypeParameterRef0), "a0") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy TypeParameterRef1), "a1") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy TypeParameterRef2), "a2") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy TypeParameterRef3), "a3") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy TypeParameterRef4), "a4") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy TypeParameterRef5), "a5") + ] + +-- | convert TypeRep to HaskellTypeMetaData +typeRepToHaskellTypeMetaData :: TypeRep -> HaskellTypeMetaData +typeRepToHaskellTypeMetaData = tyConToHaskellTypeMetaData . typeRepTyCon + +-- | convert TyCon to HaskellTypeMetaData +tyConToHaskellTypeMetaData :: TyCon -> HaskellTypeMetaData +tyConToHaskellTypeMetaData aTypeCon = + HaskellTypeMetaData + (T.pack . tyConName $ aTypeCon) + (T.pack . tyConModule $ aTypeCon) + (T.pack . tyConPackage $ aTypeCon) + +{- +-- | match 'TyCon's (accessible from a TypeRep) to their equivalent OCaml types. +primitiveTyConToOCamlTypeText :: Map.Map TyCon Text +primitiveTyConToOCamlTypeText = Map.fromList + [ ( typeRepTyCon $ typeRep (Proxy :: Proxy [] ), "list") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Maybe ), "option") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Either ), "either") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy () ), "unit") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Text ), "string") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy ByteString), "string") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Day ), "Js_date.t") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy UTCTime ), "Js_date.t") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Float ), "float") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Double ), "float") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Int8 ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Int16 ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Int32 ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Int64 ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Int ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Integer ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word8 ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word16 ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word32 ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Word64 ), "int") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Char ), "string") + , ( typeRepTyCon $ typeRep (Proxy :: Proxy Bool ), "boolean") + ] + +-- | convert a TyCon of a tuple to its size +tupleTyConToSize :: Map.Map TyCon Int +tupleTyConToSize = Map.fromList + [ ( typeRepTyCon $ typeRep (Proxy :: Proxy (,) ), 2) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy (,,) ), 3) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy (,,,) ), 4) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy (,,,,) ), 5) + , ( typeRepTyCon $ typeRep (Proxy :: Proxy (,,,,,) ), 6) + ] + +-- | necessary because the TypeRep for 'String' is '([], [Char])', but we want +-- it to be reduced to an OCaml 'string'. +typeRepIsString :: TypeRep -> Bool +typeRepIsString t = + let (hd, rst) = splitTyConApp t in + show hd == "[]" && length rst == 1 && ((show $ head rst) == "Char") + +typeParameterToRef :: Map.Map TypeRep Text +typeParameterToRef = Map.fromList + [ ( typeRep (Proxy :: Proxy TypeParameterRef0), "a0") + , ( typeRep (Proxy :: Proxy TypeParameterRef1), "a1") + , ( typeRep (Proxy :: Proxy TypeParameterRef2), "a2") + , ( typeRep (Proxy :: Proxy TypeParameterRef3), "a3") + , ( typeRep (Proxy :: Proxy TypeParameterRef4), "a4") + , ( typeRep (Proxy :: Proxy TypeParameterRef5), "a5") + ] + +ocamlDatatypeHasTypeParameter :: OCamlDatatype -> Int -> Bool +ocamlDatatypeHasTypeParameter ocamlDatatype index = ocamlDatatypeHasTypeParameter' ocamlDatatype + where + typeParameter = OCamlTypeParameterRef $ "a" <> (T.pack . show $ index) + + ocamlDatatypeHasTypeParameter' :: OCamlDatatype -> Bool + ocamlDatatypeHasTypeParameter' (OCamlDatatype _ _ ocamlConstructor) = ocamlConstructorHasTypeParameter ocamlConstructor + ocamlDatatypeHasTypeParameter' (OCamlPrimitive ocamlPrimitive) = ocamlPrimitiveHasTypeParameter ocamlPrimitive + + ocamlPrimitiveHasTypeParameter :: OCamlPrimitive -> Bool + ocamlPrimitiveHasTypeParameter (OList d0) = ocamlDatatypeHasTypeParameter' d0 + ocamlPrimitiveHasTypeParameter _ = False + + ocamlConstructorHasTypeParameter :: OCamlConstructor -> Bool + ocamlConstructorHasTypeParameter (OCamlValueConstructor valueConstructor) = valueConstructorHasTypeParameter valueConstructor + ocamlConstructorHasTypeParameter (OCamlSumOfRecordConstructor _ valueConstructor) = valueConstructorHasTypeParameter valueConstructor + ocamlConstructorHasTypeParameter _ = False + + valueConstructorHasTypeParameter :: ValueConstructor -> Bool + valueConstructorHasTypeParameter (NamedConstructor _ ocamlValue) = ocamlValueHasTypeParameter ocamlValue + valueConstructorHasTypeParameter (RecordConstructor _ ocamlValue) = ocamlValueHasTypeParameter ocamlValue + valueConstructorHasTypeParameter (MultipleConstructors ocamlValues) = or $ valueConstructorHasTypeParameter <$> ocamlValues + + ocamlValueHasTypeParameter :: OCamlValue -> Bool + ocamlValueHasTypeParameter (OCamlPrimitiveRef ocamlPrimitive) = ocamlPrimitiveHasTypeParameter ocamlPrimitive + ocamlValueHasTypeParameter o@(OCamlTypeParameterRef _) = o == typeParameter + ocamlValueHasTypeParameter (OCamlField _ v) = ocamlValueHasTypeParameter v + ocamlValueHasTypeParameter (Values v0 v1) = ocamlValueHasTypeParameter v0 || ocamlValueHasTypeParameter v1 + ocamlValueHasTypeParameter _ = False +-} 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 @@ -158,5 +158,12 @@ then ["("] <> (L.intersperse ", " ds) <> [")"] else ds +mkDocListP :: [Doc] -> Doc +mkDocListP ds = + foldl (<>) "" $ + if length ds > 0 + then ["("] <> (L.intersperse ", " ds) <> [")"] + else ds + foldMod :: [Text] -> Text foldMod = T.intercalate "." diff --git a/test/FileApp.hs b/test/FileApp.hs --- a/test/FileApp.hs +++ b/test/FileApp.hs @@ -24,9 +24,9 @@ spec :: Spec spec = do runIO $ mkGoldenFiles (Proxy :: Proxy FilePackage) 10 "test/interface/golden/golden/file" - + let dir = "test/interface/temp" runIO $ mkPackage (Proxy :: Proxy FilePackage) (PackageOptions dir "file" fileMap True $ Just $ SpecOptions "__tests__/file" "golden/file" "http://localhost:8083") - describe "OCaml Declaration with Interface: Product Types" $ do + describe "OCaml Declaration with Interface: Product Types" $ compareInterfaceFiles "File" diff --git a/test/Product.hs b/test/Product.hs --- a/test/Product.hs +++ b/test/Product.hs @@ -9,6 +9,7 @@ module Product where -- base +import Data.Typeable import GHC.Generics -- time import Data.Time @@ -36,14 +37,30 @@ :<|> OCamlModule '["ThreeTypeParameters"] :> Three TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 :<|> OCamlModule '["SubTypeParameter"] :> SubTypeParameter TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 :<|> OCamlModule '["UnnamedProduct"] :> UnnamedProduct - :<|> OCamlModule '["ComplexProduct"] :> OCamlTypeInFile Simple "test/ocaml/Simple" :> ComplexProduct) + :<|> OCamlModule '["ComplexProduct"] :> OCamlTypeInFile Simple "test/ocaml/Simple" :> ComplexProduct + :<|> OCamlModule '["Wrapper"] + :> Wrapper TypeParameterRef0 + :> IntWrapped + :> MaybeWrapped + :> EitherWrapped + :> ComplexWrapped + :> SumWrapped + :> TupleWrapped + :> HalfWrapped TypeParameterRef0 + :> PartiallyWrapped TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 + :> ScrambledTypeParameterRefs TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 TypeParameterRef3 TypeParameterRef4 TypeParameterRef5 + :> WrappedWrapper + :> WrapThree TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 + :> WrapThreeUnfilled TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 + :> WrapThreeFilled + :> WrapThreePartiallyFilled TypeParameterRef0 +-- :> TypeSynonymKey TypeParameterRef0 +-- :> NewTypeKey TypeParameterRef0 + ) compareInterfaceFiles :: FilePath -> SpecWith () compareInterfaceFiles = compareFiles "test/interface" "product" True -compareNoInterfaceFiles :: FilePath -> SpecWith () -compareNoInterfaceFiles = compareFiles "test/nointerface" "product" False - data SimpleChoice = SimpleChoice { choice :: Either String Int @@ -115,25 +132,30 @@ OneTypeParameter { otpId :: Int , otpFirst :: a - } deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + } deriving (Eq,Show,Generic,FromJSON,ToJSON) instance Arbitrary (OneTypeParameter TypeParameterRef0) where arbitrary = OneTypeParameter <$> arbitrary <*> arbitrary instance ToADTArbitrary (OneTypeParameter TypeParameterRef0) +instance (Typeable a, OCamlType a) => (OCamlType (OneTypeParameter a)) + data TwoTypeParameters a b = TwoTypeParameters { ttpId :: Int , ttpFirst :: a , ttpSecond :: b - } deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + , ttpThird :: (a, b) + } deriving (Eq,Show,Generic,FromJSON,ToJSON) instance Arbitrary (TwoTypeParameters TypeParameterRef0 TypeParameterRef1) where - arbitrary = TwoTypeParameters <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = TwoTypeParameters <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance ToADTArbitrary (TwoTypeParameters TypeParameterRef0 TypeParameterRef1) +instance (Typeable a, OCamlType a, Typeable b, OCamlType b) => (OCamlType (TwoTypeParameters a b)) + data Three a b c = Three { threeId :: Int @@ -141,19 +163,21 @@ , threeSecond :: b , threeThird :: c , threeString :: String - } deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + } deriving (Eq,Show,Generic,FromJSON,ToJSON) instance Arbitrary (Three TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) where arbitrary = Three <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance ToADTArbitrary (Three TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) +instance (Typeable a, OCamlType a, Typeable b, OCamlType b, Typeable c, OCamlType c) => (OCamlType (Three a b c)) + data SubTypeParameter a b c = SubTypeParameter { listA :: [a] , maybeB :: Maybe b , tupleC :: (c,b) - } deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + } deriving (Eq,Show,Generic,FromJSON,ToJSON) instance Arbitrary (SubTypeParameter TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) where arbitrary = do @@ -163,6 +187,8 @@ instance ToADTArbitrary (SubTypeParameter TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) +instance (Typeable a, OCamlType a, Typeable b, OCamlType b, Typeable c, OCamlType c) => (OCamlType (SubTypeParameter a b c)) + data UnnamedProduct = UnnamedProduct String Int deriving (Eq, Read, Show, Generic, OCamlType, FromJSON, ToJSON) @@ -204,3 +230,205 @@ ComplexProduct <$> arbitrary <*> pure v0 <*> pure v1 <*> arbitrary <*> arbitrary instance ToADTArbitrary ComplexProduct + +data Wrapper a = + Wrapper + { wpa :: a + } deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance (ToADTArbitrary a, Arbitrary a) => ToADTArbitrary (Wrapper a) +instance (Arbitrary a) => Arbitrary (Wrapper a) where + arbitrary = Wrapper <$> arbitrary +instance (Typeable a, OCamlType a) => (OCamlType (Wrapper a)) + +data IntWrapped = + IntWrapped + { iw :: Wrapper Int + } deriving (Eq,Show,Generic,OCamlType,ToJSON,FromJSON) + +instance ToADTArbitrary IntWrapped +instance Arbitrary IntWrapped where + arbitrary = IntWrapped <$> arbitrary + +data MaybeWrapped = + MaybeWrapped + { mw :: Wrapper (Maybe Int) + } deriving (Eq,Show,Generic,OCamlType,ToJSON,FromJSON) + +instance ToADTArbitrary MaybeWrapped +instance Arbitrary MaybeWrapped where + arbitrary = MaybeWrapped <$> arbitrary + +data EitherWrapped = + EitherWrapped + { ew :: Wrapper (Either Int Double) + } deriving (Eq,Show,Generic,OCamlType,ToJSON,FromJSON) + +instance ToADTArbitrary EitherWrapped +instance Arbitrary EitherWrapped where + arbitrary = EitherWrapped <$> arbitrary + +data ComplexWrapped = + ComplexWrapped + { cw :: Wrapper (Either (Maybe Char) Double) + } deriving (Eq,Show,Generic,OCamlType,ToJSON,FromJSON) + +instance ToADTArbitrary ComplexWrapped +instance Arbitrary ComplexWrapped where + arbitrary = ComplexWrapped <$> arbitrary + +data TupleWrapped = + TupleWrapped + { tw :: Wrapper (Int,String,Double) + } deriving (Eq,Show,Generic,OCamlType,ToJSON,FromJSON) + +instance ToADTArbitrary TupleWrapped +instance Arbitrary TupleWrapped where + arbitrary = TupleWrapped <$> arbitrary + +data SumWrapped + = SW1 + | SW2 (Wrapper Int) + | SW3 (Wrapper (Maybe String)) + | SW4 (Wrapper (Either Int String)) + deriving (Eq,Show,Generic,OCamlType,ToJSON,FromJSON) + +instance ToADTArbitrary SumWrapped +instance Arbitrary SumWrapped where + arbitrary = + oneof + [ pure SW1 + , SW2 <$> arbitrary + , SW3 <$> arbitrary + , SW4 <$> arbitrary + ] + +data HalfWrapped a = + HalfWrapped + { hw :: Wrapper (Either Int a) + } deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance Arbitrary (HalfWrapped TypeParameterRef0) where + arbitrary = HalfWrapped <$> arbitrary + +instance ToADTArbitrary (HalfWrapped TypeParameterRef0) + +instance (Typeable a, OCamlType a) => (OCamlType (HalfWrapped a)) + +data PartiallyWrapped a b c = + PartiallyWrapped + { pw :: Wrapper (Either Int (String,b,Double,c,a)) + } deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance Arbitrary (PartiallyWrapped TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) where + arbitrary = PartiallyWrapped <$> arbitrary + +instance ToADTArbitrary (PartiallyWrapped TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) + +instance (Typeable a, OCamlType a, Typeable b, OCamlType b, Typeable c, OCamlType c) => (OCamlType (PartiallyWrapped a b c)) + +-- | type parameter declaration and use order are different +data ScrambledTypeParameterRefs a b c d e f = + ScrambledTypeParameterRefs + { stprb :: b + , stprd :: d + , stpre :: e + , stpra :: a + , stprf :: f + , stprc :: c + } deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance Arbitrary (ScrambledTypeParameterRefs TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 TypeParameterRef3 TypeParameterRef4 TypeParameterRef5) where + arbitrary = ScrambledTypeParameterRefs <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance ToADTArbitrary (ScrambledTypeParameterRefs TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 TypeParameterRef3 TypeParameterRef4 TypeParameterRef5) + +instance (Typeable a, OCamlType a, Typeable b, OCamlType b, Typeable c, OCamlType c, Typeable d, OCamlType d, Typeable e, OCamlType e, Typeable f, OCamlType f) => (OCamlType (ScrambledTypeParameterRefs a b c d e f)) + +data WrappedWrapper = + WrappedWrapper +-- { ww :: Maybe (Wrapper (Maybe String)) + { ww :: Maybe (Wrapper (Maybe Int)) + } deriving (Eq,Show,Generic,ToJSON,FromJSON,OCamlType) + +instance Arbitrary WrappedWrapper where + arbitrary = WrappedWrapper <$> arbitrary + +instance ToADTArbitrary WrappedWrapper + +data WrapThree a b c = + WrapThree + { wp2a :: a + , wp2b :: b + , wp2ab :: (a, b) + , wp2cb :: (c, b) + } deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance (ToADTArbitrary a, Arbitrary a, ToADTArbitrary b, Arbitrary b, ToADTArbitrary c, Arbitrary c) => ToADTArbitrary (WrapThree a b c) +instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (WrapThree a b c) where + arbitrary = WrapThree <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +instance (Typeable a, OCamlType a, Typeable b, OCamlType b, Typeable c, OCamlType c) => (OCamlType (WrapThree a b c)) + +data WrapThreeUnfilled a b c = + WrapThreeUnfilled + { zed :: String + , unfilled :: WrapThree a b c + } deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance (ToADTArbitrary a, Arbitrary a, ToADTArbitrary b, Arbitrary b, ToADTArbitrary c, Arbitrary c) => ToADTArbitrary (WrapThreeUnfilled a b c) +instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (WrapThreeUnfilled a b c) where + arbitrary = WrapThreeUnfilled <$> arbitrary <*> arbitrary +instance (Typeable a, OCamlType a, Typeable b, OCamlType b, Typeable c, OCamlType c) => (OCamlType (WrapThreeUnfilled a b c)) + +data WrapThreeFilled = + WrapThreeFilled + { foo :: String + , filled :: WrapThree Int Double Person + } deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance ToADTArbitrary WrapThreeFilled +instance Arbitrary WrapThreeFilled where + arbitrary = WrapThreeFilled <$> arbitrary <*> arbitrary +instance OCamlType WrapThreeFilled + +data WrapThreePartiallyFilled a = + WrapThreePartiallyFilled + { bar :: String + , bar2 :: [Int] + , partiallyFilled :: WrapThree Float a Double + } deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance (ToADTArbitrary a, Arbitrary a) => ToADTArbitrary (WrapThreePartiallyFilled a) +instance Arbitrary a => Arbitrary (WrapThreePartiallyFilled a) where + arbitrary = WrapThreePartiallyFilled <$> arbitrary <*> arbitrary <*> arbitrary +instance (Typeable a, OCamlType a) => OCamlType (WrapThreePartiallyFilled a) + +-- phantom types + +data TypeSynonymKey a = String + deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance (ToADTArbitrary a, Arbitrary a) => ToADTArbitrary (TypeSynonymKey a) +instance Arbitrary a => Arbitrary (TypeSynonymKey a) where + arbitrary = arbitrary +instance (Typeable a, OCamlType a) => OCamlType (TypeSynonymKey a) + +newtype NewTypeKey a = NewTypeKey String + deriving (Eq,Show,Generic,ToJSON,FromJSON) + +instance (ToADTArbitrary a, Arbitrary a) => ToADTArbitrary (NewTypeKey a) +instance Arbitrary a => Arbitrary (NewTypeKey a) where + arbitrary = NewTypeKey <$> arbitrary +instance (Typeable a, OCamlType a) => OCamlType (NewTypeKey a) + + +{- +λ> toOCamlType (Proxy :: Proxy (Key User)) +OCamlDatatype (HaskellTypeMetaData "Key" "Database.Persist.Class.PersistEntity" "persistent-2.6-HdpHylIi1gZ4QjAhgpXd6i") "Key" (OCamlValueConstructor (NamedConstructor "Key" OCamlEmpty)) +λ + + +λ> toOCamlType (Proxy :: Proxy (UserTag)) +OCamlDatatype (HaskellTypeMetaData "UserTag" "Onping.Persist.Models.Internal" "onping-types-0.12.0.0-537fBzusEVB7hcaZbAcQql") "UserTag" (OCamlValueConstructor (RecordConstructor "UserTag" (Values (Values (Values (OCamlField "userTagUser" (OCamlRefApp (Key User) (OCamlRef (HaskellTypeMetaData "User" "Plowtech.Authentication.Persist.Models" "plowtech-authentication-types-0.3.0.0-HOAisznLARVIB1OtLfSJK3") "User"))) (OCamlField "userTagOwner" (OCamlRefApp (Key User) (OCamlRef (HaskellTypeMetaData "User" "Plowtech.Authentication.Persist.Models" "plowtech-authentication-types-0.3.0.0-HOAisznLARVIB1OtLfSJK3") "User")))) (Values (OCamlField "userTagGroup" (OCamlRefApp (Key Group) (OCamlRef (HaskellTypeMetaData "Group" "Onping.Persist.Models.Internal" "onping-types-0.12.0.0-537fBzusEVB7hcaZbAcQql") "Group"))) (Values (OCamlField "userTagSuperGroup" (OCamlRefApp (Key Group) (OCamlRef (HaskellTypeMetaData "Group" "Onping.Persist.Models.Internal" "onping-types-0.12.0.0-537fBzusEVB7hcaZbAcQql") "Group"))) (OCamlField "userTagDefaultDash" (OCamlRefApp (Key Dashboard) (OCamlRef (HaskellTypeMetaData "Dashboard" "Onping.Persist.Models.Internal" "onping-types-0.12.0.0-537fBzusEVB7hcaZbAcQql") "Dashboard")))))) (Values (Values (OCamlField "userTagPhone" (OCamlPrimitiveRef (OOption (OCamlPrimitive OInt)))) (OCamlField "userTagName" (OCamlPrimitiveRef (OOption (OCamlPrimitive OString))))) (Values (OCamlField "userTagCallAlert" (OCamlPrimitiveRef OBool)) (Values (OCamlField "userTagEmailAlert" (OCamlPrimitiveRef OBool)) (OCamlField "userTagTextAlert" (OCamlPrimitiveRef OBool)))))))) + +-} diff --git a/test/ProductApp.hs b/test/ProductApp.hs --- a/test/ProductApp.hs +++ b/test/ProductApp.hs @@ -31,15 +31,4 @@ compareInterfaceFiles "SubTypeParameter" compareInterfaceFiles "UnnamedProduct" compareInterfaceFiles "ComplexProduct" - - let dir2 = "test/nointerface/temp" - runIO $ mkPackage (Proxy :: Proxy ProductPackage) (PackageOptions dir2 "product" fileMap False Nothing) - - describe "OCaml Declaration without Interface: Product Types" $ do - compareNoInterfaceFiles "Person" - compareNoInterfaceFiles "Company" - compareNoInterfaceFiles "Card" - compareNoInterfaceFiles "OneTypeParameter" - compareNoInterfaceFiles "TwoTypeParameters" - compareNoInterfaceFiles "ThreeTypeParameters" - compareNoInterfaceFiles "SubTypeParameter" + compareInterfaceFiles "Wrapper" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -35,8 +35,7 @@ (mkOCamlTypeMetaData (Proxy :: Proxy Product.ProductPackage)) <> (mkOCamlTypeMetaData (Proxy :: Proxy D.DependencyPackageWithoutProduct)) `shouldBe` mkOCamlTypeMetaData (Proxy :: Proxy D.DependencyPackage) - print $ mkOCamlTypeMetaData (Proxy :: Proxy D.SubsPackage) - _ <- forkIO $ run 8081 Product.productPackageApp _ <- forkIO $ run 8082 sumPackageApp run 8083 File.filePackageApp + pure () diff --git a/test/Sum.hs b/test/Sum.hs --- a/test/Sum.hs +++ b/test/Sum.hs @@ -10,7 +10,7 @@ -- base import GHC.Generics - +import Data.Typeable -- aeson import Data.Aeson (FromJSON, ToJSON) @@ -30,9 +30,6 @@ -- servant import Servant.API --- servant-server -import Servant - -- ocaml-export import OCaml.Export hiding (mkGoldenFiles) import Util @@ -44,8 +41,8 @@ :<|> OCamlModule '["NameOrIdNumber"] :> NameOrIdNumber :<|> OCamlModule '["SumVariant"] :> SumVariant :<|> OCamlModule '["WithTuple"] :> WithTuple - :<|> OCamlModule '["SumWithRecord"] :> SumWithRecord - :<|> OCamlModule '["Result"] :> Result TypeParameterRef0 TypeParameterRef1 + :<|> OCamlModule '["SumWithRecord"] :> SumWithRecord -- :> SumWithRecordMixed + :<|> OCamlModule '["Result"] :> Result TypeParameterRef0 TypeParameterRef1 -- :> ComplexResult TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 :<|> OCamlModule '["NewType"] :> NewType) compareInterfaceFiles :: FilePath -> SpecWith () @@ -81,19 +78,6 @@ compareInterfaceFiles "SumWithRecord" compareInterfaceFiles "Result" compareInterfaceFiles "NewType" -{- - let dir2 = "test/nointerface/temp" - runIO $ mkPackage (Proxy :: Proxy SumPackage) (PackageOptions dir2 "sum" Map.empty False Nothing) - - describe "Sum Types" $ do - compareNoInterfaceFiles "OnOrOff" - compareNoInterfaceFiles "NameOrIdNumber" - compareNoInterfaceFiles "SumVariant" - compareNoInterfaceFiles "WithTuple" - compareNoInterfaceFiles "SumWithRecord" - compareNoInterfaceFiles "Result" - compareNoInterfaceFiles "NewType" --} data OnOrOff = On | Off deriving (Show,Eq,Generic,OCamlType,ToJSON,FromJSON) @@ -114,13 +98,39 @@ data Result a b = Success a | Error b - deriving (Show, Eq, Generic, OCamlType, ToJSON, FromJSON) + deriving (Show, Eq, Generic, ToJSON, FromJSON) instance Arbitrary (Result TypeParameterRef0 TypeParameterRef1) where arbitrary = oneof [Success <$> arbitrary, Error <$> arbitrary] instance ToADTArbitrary (Result TypeParameterRef0 TypeParameterRef1) +instance (Typeable a, OCamlType a, Typeable b, OCamlType b) => (OCamlType (Result a b)) + +data ComplexResult a b c + = CR0 a + | CR1 a b + | CR2 b (c,a) + | CR3 String b Int a + | CR4 { cr4b :: b, cr4ac :: (a,c) } + | CR5 + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +instance Arbitrary (ComplexResult TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) where + arbitrary = + oneof + [ CR0 <$> arbitrary + , CR1 <$> arbitrary <*> arbitrary + , CR2 <$> arbitrary <*> arbitrary + , CR3 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , CR4 <$> arbitrary <*> arbitrary + , pure CR5 + ] + +instance ToADTArbitrary (ComplexResult TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) + +instance (Typeable a, OCamlType a, Typeable b, OCamlType b, Typeable c, OCamlType c) => (OCamlType (ComplexResult a b c)) + data SumVariant = HasNothing | HasSingleInt Int @@ -169,6 +179,25 @@ instance ToADTArbitrary SumWithRecord +data SumWithRecordMixed + = SRM1 {srm1 :: Int} + | SRM2 + | SRM3 {srm2 :: String, srm3 :: Float} + | SRM4 Int (String, Double) + deriving (Show,Eq,Generic, OCamlType, ToJSON, FromJSON) + +instance Arbitrary SumWithRecordMixed where + arbitrary = + oneof + [ SRM1 <$> arbitrary + , pure SRM2 + , SRM3 <$> arbitrary <*> arbitrary + , SRM4 <$> arbitrary <*> arbitrary + ] + +instance ToADTArbitrary SumWithRecordMixed + + newtype NewType = NewType Int deriving (Show,Eq,Generic,OCamlType, ToJSON, FromJSON) @@ -177,3 +206,22 @@ arbitrary = NewType <$> arbitrary instance ToADTArbitrary NewType + + +{- +introduce Enumerator +extra type is made +but anything coming after the enumerator is broken + + + + +λ> toOCamlType (Proxy :: Proxy (ComplexResult TypeParameterRef0 TypeParameterRef1 TypeParameterRef2)) + +OCamlDatatype (HaskellTypeMetaData "ComplexResult" "Sum" "main") "ComplexResult" (OCamlValueConstructor (MultipleConstructors [MultipleConstructors [NamedConstructor "CR0" (OCamlTypeParameterRef "a0"),MultipleConstructors [NamedConstructor "CR1" (Values (OCamlTypeParameterRef "a0") (OCamlTypeParameterRef "a1")),NamedConstructor "CR2" (Values (OCamlTypeParameterRef "a1") (OCamlPrimitiveRef (OTuple2 (OCamlDatatype (HaskellTypeMetaData "a2" "OCaml.BuckleScript.Types" "ocaml-export") "a2" (OCamlValueConstructor (NamedConstructor "a2" (OCamlTypeParameterRef "a2")))) (OCamlDatatype (HaskellTypeMetaData "a0" "OCaml.BuckleScript.Types" "ocaml-export") "a0" (OCamlValueConstructor (NamedConstructor "a0" (OCamlTypeParameterRef "a0")))))))]],MultipleConstructors [NamedConstructor "CR3" (Values (Values (OCamlPrimitiveRef (OList (OCamlPrimitive OChar))) (OCamlTypeParameterRef "a1")) (Values (OCamlPrimitiveRef OInt) (OCamlTypeParameterRef "a0"))),MultipleConstructors [RecordConstructor "CR4" (Values (OCamlField "cr4b" (OCamlTypeParameterRef "a1")) (OCamlField "cr4ac" (OCamlPrimitiveRef (OTuple2 (OCamlDatatype (HaskellTypeMetaData "a0" "OCaml.BuckleScript.Types" "ocaml-export") "a0" (OCamlValueConstructor (NamedConstructor "a0" (OCamlTypeParameterRef "a0")))) (OCamlDatatype (HaskellTypeMetaData "a2" "OCaml.BuckleScript.Types" "ocaml-export") "a2" (OCamlValueConstructor (NamedConstructor "a2" (OCamlTypeParameterRef "a2")))))))),NamedConstructor "CR5" OCamlEmpty]]])) + +λ> toOCamlType (Proxy :: Proxy SumWithRecord) + +OCamlDatatype (HaskellTypeMetaData "SumWithRecord" "Sum" "main") "SumWithRecord" (OCamlSumOfRecordConstructor "SumWithRecord" (MultipleConstructors [RecordConstructor "A1" (OCamlField "a1" (OCamlPrimitiveRef OInt)),RecordConstructor "B2" (Values (OCamlField "b2" (OCamlPrimitiveRef (OList (OCamlPrimitive OChar)))) (OCamlField "b3" (OCamlPrimitiveRef OInt)))])) + +-}