diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright James M.C. Haver II (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of James M.C. Haver II nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ocaml-export.cabal b/ocaml-export.cabal new file mode 100644 --- /dev/null +++ b/ocaml-export.cabal @@ -0,0 +1,104 @@ +-- This file has been generated from package.yaml by hpack version 0.17.1. +-- +-- see: https://github.com/sol/hpack + +name: ocaml-export +version: 0.1.0.0 +synopsis: Convert Haskell types in OCaml types +description: README.md +category: Web +homepage: https://github.com/plow-technologies/ocaml-export#readme +bug-reports: https://github.com/plow-technologies/ocaml-export/issues +author: James M.C. Haver II +maintainer: james.haver@plowtech.net +copyright: 2017 Plow Technologies +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/plow-technologies/ocaml-export + +library + hs-source-dirs: + src + ghc-options: -Wall -Wredundant-constraints -fprint-potential-instances + build-depends: + base >= 4.7 && < 5 + , aeson + , bytestring + , containers + , directory + , file-embed + , filepath + , formatting + , hspec-golden-aeson >= 0.4.0.0 + , mtl + , split + , QuickCheck + , quickcheck-arbitrary-adt + , servant + , servant-server + , text + , template-haskell + , time + , typelits-witnesses + , wl-pprint-text + exposed-modules: + OCaml.Export + OCaml.BuckleScript.Decode + OCaml.BuckleScript.Encode + OCaml.BuckleScript.Record + OCaml.BuckleScript.Spec + OCaml.BuckleScript.Types + OCaml.Internal.Common + OCaml.BuckleScript.Internal.Spec + OCaml.BuckleScript.Internal.Module + OCaml.BuckleScript.Internal.Package + other-modules: + OCaml.File + Paths_ocaml_export + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -fprint-potential-instances + build-depends: + base + , aeson + , bytestring + , constraints + , containers + , directory + , filepath + , hspec + , hspec-golden-aeson + , ocaml-export + , process + , QuickCheck + , quickcheck-arbitrary-adt + , servant + , servant-server + , template-haskell + , text + , time + , wai + , wai-extra + , warp + , typelits-witnesses + other-modules: + Dependency + File + FileApp + Options + Product + ProductApp + Sum + SumApp + Util + default-language: Haskell2010 diff --git a/src/OCaml/BuckleScript/Decode.hs b/src/OCaml/BuckleScript/Decode.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/BuckleScript/Decode.hs @@ -0,0 +1,482 @@ +{-| +Module : OCaml.BuckleScript.Decode +Description : Make a JSON decoder for an OCamlDatatype that matches Generic aeson FromJSON +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module OCaml.BuckleScript.Decode + ( toOCamlDecoderSourceWith + , toOCamlDecoderInterfaceWith + ) where + +-- base +import Control.Monad.Reader +import qualified Data.List as L +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Proxy (Proxy (..)) + +-- 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 + + +-- | Render OCamlDatatype into an OCaml declaration +class HasDecoder a where + render :: a -> Reader TypeMetaData Doc + +-- | Render OCamlPrimitive decoders and type parameters +class HasDecoderRef a where + renderRef :: a -> Reader TypeMetaData Doc + +-- | Render OCamlDataype into an OCaml interface +class HasDecoderInterface a where + renderInterface :: a -> Reader TypeMetaData Doc + +instance HasDecoderInterface OCamlDatatype where + renderInterface datatype@(OCamlDatatype _ typeName constructor@(OCamlSumOfRecordConstructor _ (MultipleConstructors constructors))) = do + fnName <- renderRef datatype + let typeParameterInterfaces = linesBetween $ catMaybes (renderSumRecordInterface typeName . OCamlValueConstructor <$> constructors) + (typeParameterEncoders, typeParameters) = renderTypeParameterVals constructor + pure $ typeParameterInterfaces + <$$> "val" <+> fnName <+> ":" <+> typeParameterEncoders <> "Js_json.t ->" <+> "(" <> typeParameters <> (stext . textLowercaseFirst $ typeName) <> ", string)" <+> "Js_result.t" + + + 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)" <+> "Js_result.t" + + 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 + fnName <- renderRef datatype + fnBody <- mapM renderSum (OCamlSumOfRecordConstructor typeName <$> constructors) + typeParameterDeclarations <- linesBetween <$> catMaybes <$> sequence (renderSumRecord typeName . OCamlValueConstructor <$> constructors) + ocamlInterface <- asks (includeOCamlInterface . userOptions) + if ocamlInterface + then do + pure $ typeParameterDeclarations <$$> + ("let" <+> fnName <+> "json =") <$$> + (indent 2 ("match Aeson.Decode.(field \"tag\" string json) with" <$$> foldl1 (<$$>) fnBody <$$> fnFooter)) + else do + let (typeParameterSignatures,typeParameters) = renderTypeParameters constructor + pure $ typeParameterDeclarations <$$> + ("let" <+> fnName <+> typeParameterSignatures <+> "(json : Js_json.t)" <+> typeParameters <> ":(" <> stext (textLowercaseFirst typeName) <> ", string) Js_result.t =") <$$> + (indent 2 ("match Aeson.Decode.(field \"tag\" string json) with" <$$> foldl1 (<$$>) fnBody <$$> fnFooter)) + where + fnFooter = + "| err -> Js_result.Error (\"Unknown tag value found '\" ^ err ^ \"'.\")" + <$$> "| exception Aeson.Decode.DecodeError message -> Js_result.Error message" + + + render datatype@(OCamlDatatype _ name constructor@(OCamlEnumeratorConstructor constructors)) = do + fnName <- renderRef datatype + fnBody <- mapM render constructors + ocamlInterface <- asks (includeOCamlInterface . userOptions) + if ocamlInterface + then do + pure $ "let" <+> fnName <+> "json =" + <$$> indent 2 ("match Js_json.decodeString json with" + <$$> foldl1 (<$$>) fnBody <$$> fnFooter fnName) + else do + let (typeParameterSignatures,typeParameters) = renderTypeParameters constructor + returnType = "(" <> typeParameters <> (stext . textLowercaseFirst $ name) <> ", string) Js_result.t =" + pure $ "let" <+> fnName <+> typeParameterSignatures <+>"(json : Js_json.t) :" <> returnType + <$$> indent 2 ("match Js_json.decodeString json with" + <$$> foldl1 (<$$>) fnBody <$$> fnFooter fnName) + where + fnFooter fnName + = "| Some err -> Js_result.Error (\"" <> fnName <> ": unknown enumeration '\" ^ err ^ \"'.\")" + <$$> "| None -> Js_result.Error \"" <> fnName <> ": expected a top-level JSON string.\"" + + render datatype@(OCamlDatatype _ name constructor) = do + fnName <- renderRef datatype + fnBody <- render constructor + ocamlInterface <- asks (includeOCamlInterface . userOptions) + if ocamlInterface + then do + let typeParameters = getTypeParameters constructor + renderedTypeParameters = foldl (<>) "" $ stext <$> L.intersperse " " ((\t -> "decode" <> (textUppercaseFirst t)) <$> typeParameters) + pure $ "let" <+> fnName <+> renderedTypeParameters <+> "json" <+> "=" <$$> fnBody + else do + let (typeParameterSignatures,typeParameters) = renderTypeParameters constructor + returnType = "(" <> typeParameters <> (stext . textLowercaseFirst $ name) <> ", string) Js_result.t =" + pure $ "let" <+> fnName <+> typeParameterSignatures <+> "(json : Js_json.t) :" <> returnType <$$> fnBody + + render (OCamlPrimitive primitive) = renderRef primitive + +instance HasDecoderRef OCamlDatatype where + -- this should only catch type parameters + renderRef datatype@(OCamlDatatype typeRef name _) = + if isTypeParameterRef datatype + then + pure $ parens ("fun a -> unwrapResult" <+> parens ("decode" <> (stext . textUppercaseFirst $ name) <+> "a")) + else do + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> pure $ "decode" <> (stext . textUppercaseFirst $ name) + Just decOCamlTypeMetaData -> do + ds <- asks (dependencies . userOptions) + case Map.lookup typeRef ds of + Just parOCamlTypeMetaData -> do + let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData + pure $ prefix <> "decode" <> (stext . textUppercaseFirst $ name) + + Nothing -> fail ("OCaml.BuckleScript.Decode (HasDecoderRef OCamlDataType) expected to find dependency:\n\n" ++ show typeRef ++ "\n\nin\n\n" ++ show ds) + + renderRef (OCamlPrimitive primitive) = renderRef primitive + +instance HasDecoder OCamlConstructor where + render (OCamlValueConstructor (NamedConstructor name value)) = do + decoder <- render value + return $ indent 2 $ "match Aeson.Decode." <> decoder <+> "json" <+> "with" + <$$> "| v -> Js_result.Ok" <+> parens (stext name <+> "v") + <$$> "| exception Aeson.Decode.DecodeError msg -> Js_result.Error (\"decode" <> (stext . textUppercaseFirst $ name) <> ": \" ^ msg)" + + render (OCamlValueConstructor (RecordConstructor name value)) = do + decoders <- render value + pure + $ " match Aeson.Decode." + <$$> (indent 4 ("{" <+> decoders <$$> "}")) + <$$> " with" + <$$> " | v -> Js_result.Ok v" + <$$> " | exception Aeson.Decode.DecodeError message -> Js_result.Error (\"decode" <> (stext . textUppercaseFirst $ name) <> ": \" ^ message)" + + render (OCamlValueConstructor (MultipleConstructors constructors)) = do + decoders <- mapM (renderSum . OCamlValueConstructor) constructors + pure $ indent 2 "match Aeson.Decode.(field \"tag\" string json) with" + <$$> indent 2 (foldl (<$$>) "" decoders) + <$$> indent 2 fnFooter + where + fnFooter = "| err -> Js_result.Error (\"Unknown tag value found '\" ^ err ^ \"'.\")" + <$$> "| 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 + 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))" + + -- 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 (OCamlPrimitiveRef primitive) = renderRef primitive + + render (OCamlTypeParameterRef name) = + pure $ "(fun a -> unwrapResult (decode" <> (stext . textUppercaseFirst $ name) <+> "a))" + + render (Values x y) = do + dx <- render x + dy <- render y + return $ 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 (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" + + render OCamlEmpty = pure (stext "") + +instance HasDecoder EnumeratorConstructor where + render (EnumeratorConstructor name) = pure $ "| Some \"" <> stext name <> "\" -> Js_result.Ok" <+> stext name + +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 OFloat = pure "float" + renderRef OString = pure "string" + + renderRef (OList (OCamlPrimitive OChar)) = pure "string" + + renderRef (OList datatype@(OCamlDatatype typeRef name _)) = + if isTypeParameterRef datatype + then + pure . parens $ "list" <+> (parens $ "fun a -> unwrapResult (decode" <> (stext . textUppercaseFirst $ name) <+> "a)") + else do + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> fail $ "OCaml.BuckleScript.Decode (HasDecoderRef (OList (OCamlDatatype typeRep name _))) mOCamlTypeMetaData is Nothing:\n\n" ++ (show datatype) + Just decOCamlTypeMetaData -> do + ds <- asks (dependencies . userOptions) + case Map.lookup typeRef ds of + Just parOCamlTypeMetaData -> do + let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData + pure . parens $ "list" <+> (parens $ "fun a -> unwrapResult (" <> prefix <> "decode" <> (stext . textUppercaseFirst $ name) <+> "a)") + Nothing -> fail ("OCaml.BuckleScript.Decode (HasDecoderRef (OList (OCamlDatatype typeRep name _))) expected to find dependency:\n\n" ++ show typeRef ++ "\n\nin\n\n" ++ show ds) + + renderRef (OList datatype) = do + dt <- renderRef datatype + pure . parens $ "list" <+> dt + + renderRef (OOption _) = pure "" + + renderRef (OEither v0 v1) = do + dv0 <- renderRef v0 + dv1 <- renderRef v1 + pure $ parens $ "either" <+> dv0 <+> dv1 + + renderRef (OTuple2 v0 v1) = do + dv0 <- renderRef v0 + dv1 <- renderRef v1 + pure $ parens $ "pair" <+> dv0 <+> dv1 + + renderRef (OTuple3 v0 v1 v2) = do + dv0 <- renderRef v0 + dv1 <- renderRef v1 + dv2 <- renderRef v2 + pure $ parens $ "tuple3" <+> dv0 <+> dv1 <+> dv2 + + renderRef (OTuple4 v0 v1 v2 v3) = do + dv0 <- renderRef v0 + dv1 <- renderRef v1 + dv2 <- renderRef v2 + dv3 <- renderRef v3 + pure $ parens $ "tuple4" <+> dv0 <+> dv1 <+> dv2 <+> dv3 + + renderRef (OTuple5 v0 v1 v2 v3 v4) = do + dv0 <- renderRef v0 + dv1 <- renderRef v1 + dv2 <- renderRef v2 + dv3 <- renderRef v3 + dv4 <- renderRef v4 + pure $ parens $ "tuple5" <+> dv0 <+> dv1 <+> dv2 <+> dv3 <+> dv4 + + renderRef (OTuple6 v0 v1 v2 v3 v4 v5) = do + dv0 <- renderRef v0 + dv1 <- renderRef v1 + dv2 <- renderRef v2 + dv3 <- renderRef v3 + dv4 <- renderRef v4 + dv5 <- renderRef v5 + pure $ parens $ "tuple6" <+> dv0 <+> dv1 <+> dv2 <+> dv3 <+> dv4 <+> dv5 + +-- Util + +-- | "" -> decode +renderSumCondition :: T.Text -> Doc -> Reader TypeMetaData Doc +renderSumCondition name contents = do + ao <- asks (aesonOptions . userOptions) + let jsonConstructorName = T.pack . Aeson.constructorTagModifier ao . T.unpack $ name + pure $ "|" <+> dquotes (stext jsonConstructorName) <+> "->" <$$> + indent 3 contents + +-- | Render a sum type constructor in context of a data type with multiple +-- constructors. +renderSum :: OCamlConstructor -> Reader TypeMetaData Doc +renderSum (OCamlValueConstructor (NamedConstructor name OCamlEmpty)) = renderSumCondition name ("Js_result.Ok" <+> stext name) +renderSum (OCamlValueConstructor (NamedConstructor name v@(Values _ _))) = do + val <- rArgs name v + renderSumCondition name val + +renderSum (OCamlValueConstructor (NamedConstructor name value)) = do + ao <- asks (aesonOptions . userOptions) + 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" + <$$> + indent 1 + ( "| v -> Js_result.Ok (" <> (stext name) <+> "v)" + <$$> "| exception Aeson.Decode.DecodeError message -> Js_result.Error (\"" <> (stext jsonConstructorName) <> ": \" ^ message)" + ) <> line + ) + +renderSum (OCamlValueConstructor (RecordConstructor name value)) = do + val <- render value + renderSumCondition name val + +renderSum (OCamlValueConstructor (MultipleConstructors constrs)) = + foldl1 (<$+$>) <$> mapM (renderSum . OCamlValueConstructor) constrs + +renderSum (OCamlSumOfRecordConstructor typeName (RecordConstructor name _value)) = + renderOutsideEncoder typeName name + +renderSum (OCamlSumOfRecordConstructor typeName (MultipleConstructors constrs)) = + foldl1 (<$+$>) <$> mapM renderSum (OCamlSumOfRecordConstructor typeName <$> constrs) + +renderSum (OCamlEnumeratorConstructor _) = pure "" -- handled elsewhere +renderSum _ = pure "" + +renderOutsideEncoder :: Text -> Text -> Reader TypeMetaData Doc +renderOutsideEncoder typeName name = + pure $ + "|" <+> (dquotes . stext $ name) <+> "->" + <$$> indent 3 ("(match" <+> "decode" <> (stext $ typeName <> textUppercaseFirst name) <+> "json" <+> "with" + <$$> indent 1 ("| Js_result.Ok v -> Js_result.Ok" <+> (parens ((stext $ textUppercaseFirst name) <+> "v")) + <$$> "| Js_result.Error message -> Js_result.Error" <+> (parens $ (dquotes $ "decode" <> stext typeName <> ": ") <+> "^ message")) + <$$> ")") + + +flattenOCamlValue :: OCamlValue -> [OCamlValue] +flattenOCamlValue (Values l r) = flattenOCamlValue l ++ flattenOCamlValue r +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. +rArgs :: Text -> OCamlValue -> Reader TypeMetaData Doc +rArgs name vals = do + v <- mk name 0 $ (Just <$> flattenOCamlValue vals) ++ [Nothing] + pure $ + parens $ "match Aeson.Decode.(field \"contents\" Js.Json.decodeArray json) with" + <$$> (indent 1 "| Some v ->" + <$$> (indent 3 v) + <$$> (indent 1 "| None -> Js_result.Error (\"" <> (stext name) <+> "expected an array.\")" )) <> line + +mk :: Text -> Int -> [Maybe OCamlValue] -> Reader TypeMetaData Doc +mk name i [x] = + case x of + Nothing -> do + let ts = foldl (<>) "" $ L.intersperse ", " ((stext . T.append "v" . T.pack . show) <$> [0..i-1]) + pure $ indent 1 $ "Js_result.Ok" <+> parens (stext name <+> parens ts) + Just _ -> pure "" +mk name i (x:xs) = + case x of + Nothing -> mk name i xs + Just x' -> do + renderedVal <- render x' + renderedInternal <- mk name (i+1) xs + let iDoc = (stext . T.pack . show $ i) + pure $ indent 1 $ "(match Aeson.Decode." <> renderedVal <+> ("v." <> parens iDoc) <+> "with" + <$$> + indent 1 + ("| v" <> iDoc <+> "->" <$$> (indent 2 renderedInternal) + <$$> "| exception Aeson.Decode.DecodeError message -> Js_result.Error (\"" <> (stext name) <> ": \" ^ message)" + ) + <$$> ")" + +mk _name _i [] = pure "" + +renderTypeParameterValsAux :: [OCamlValue] -> (Doc,Doc) +renderTypeParameterValsAux ocamlValues = + let typeParameterNames = (<>) "'" <$> getTypeParameterRefNames ocamlValues + typeDecs = (foldl (<>) "" $ L.intersperse " -> " $ (\t -> "(Js_json.t -> (" <> (stext t) <> ", string) Js_result.t)") <$> typeParameterNames) <> " -> " + in + if length typeParameterNames > 0 + then + if length typeParameterNames > 1 + then (typeDecs, foldl (<>) "" $ ["("] <> (L.intersperse ", " $ stext <$> typeParameterNames) <> [") "]) + else (typeDecs, stext . flip (<>) " " . head $ typeParameterNames) + else ("","") + +renderTypeParameterVals :: OCamlConstructor -> (Doc,Doc) +renderTypeParameterVals (OCamlValueConstructor vc) = renderTypeParameterValsAux $ getOCamlValues vc +renderTypeParameterVals (OCamlSumOfRecordConstructor _ vc) = renderTypeParameterValsAux $ getOCamlValues vc +renderTypeParameterVals _ = ("","") + + +renderTypeParametersAux :: [OCamlValue] -> (Doc,Doc) +renderTypeParametersAux ocamlValues = do + let typeParameterNames = getTypeParameterRefNames ocamlValues + typeDecs = (\t -> "(type " <> (stext t) <> ")") <$> typeParameterNames :: [Doc] + encoderDecs = (\t -> "(decode" <> (stext $ textUppercaseFirst t) <+> ":" <+> "Js_json.t -> (" <> (stext t) <> ", string) Js_result.t)" ) <$> typeParameterNames :: [Doc] + typeParams = foldl (<>) "" $ if length typeParameterNames > 1 then ["("] <> (L.intersperse ", " $ stext <$> typeParameterNames) <> [") "] else ((\x -> stext $ x <> " ") <$> typeParameterNames) :: [Doc] + (foldl (<+>) "" (typeDecs ++ encoderDecs), typeParams ) + +getOCamlValues :: ValueConstructor -> [OCamlValue] +getOCamlValues (NamedConstructor _ value) = [value] +getOCamlValues (RecordConstructor _ value) = [value] +getOCamlValues (MultipleConstructors cs) = concat $ getOCamlValues <$> cs + +renderTypeParameters :: OCamlConstructor -> (Doc,Doc) +renderTypeParameters (OCamlValueConstructor vc) = renderTypeParametersAux $ getOCamlValues vc +renderTypeParameters (OCamlSumOfRecordConstructor _ vc) = renderTypeParametersAux $ getOCamlValues vc +renderTypeParameters _ = ("","") + +-- | Render an OCaml val interface for a record constructor in a sum of records +renderSumRecordInterface :: Text -> OCamlConstructor -> Maybe Doc +renderSumRecordInterface typeName (OCamlValueConstructor (RecordConstructor name _value)) = + Just $ "val decode" <> (stext $ typeName <> name) <+> ":" <+> "Js_json.t" <+> "->" <+> parens (stext (textLowercaseFirst $ typeName <> name) <> comma <+> "string") <+> "Js_result.t" +renderSumRecordInterface _ _ = Nothing + + +-- Exported + +-- | 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) diff --git a/src/OCaml/BuckleScript/Encode.hs b/src/OCaml/BuckleScript/Encode.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/BuckleScript/Encode.hs @@ -0,0 +1,497 @@ +{-| +Module : OCaml.BuckleScript.Encode +Description : Make a JSON encoder for an OCamlDatatype that matches Generic aeson ToJSON +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +For a Haskell type with an instance of OCamlType, output an +OCaml type to JSON (aeson) encoder. +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module OCaml.BuckleScript.Encode + ( toOCamlEncoderSourceWith + , toOCamlEncoderInterfaceWith + ) where + +-- base +import Control.Monad.Reader +import qualified Data.List as L +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Proxy (Proxy (..)) + +-- aeson +import qualified Data.Aeson.Types as Aeson (Options(..)) + +-- containers +import qualified Data.Map 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 +import OCaml.Internal.Common + +-- | Render the encoder function +class HasEncoder a where + render :: a -> Reader TypeMetaData Doc + +-- | Render the encode type signature +class HasEncoderRef a where + renderRef :: a -> Reader TypeMetaData Doc + +-- | Render the encoder interface +class HasEncoderInterface a where + renderTypeInterface :: a -> Reader TypeMetaData Doc + + +instance HasEncoderInterface OCamlDatatype where + -- sum that has at least one record type + renderTypeInterface datatype@(OCamlDatatype _ typeName constructor@(OCamlSumOfRecordConstructor _ (MultipleConstructors constructors))) = do + fnName <- renderRef datatype + let (typeParameterSignatures,typeParameters) = renderTypeParameterVals constructor + sumRecordDeclarations = linesBetween $ catMaybes (renderSumRecordInterface typeName . OCamlValueConstructor <$> constructors) + encodeFnName = stext . textLowercaseFirst $ typeName + pure $ sumRecordDeclarations + <$$> "val" <+> fnName <+> ":" <+> typeParameterSignatures <+> typeParameters <> encodeFnName <+> "->" <+> "Js_json.t" + + -- other data types + 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" + + -- no need to render for primitives + renderTypeInterface _ = pure "" + +instance HasEncoder OCamlDatatype where + -- sum that has at least one record constructor + render datatype@(OCamlDatatype _ typeName constructor@(OCamlSumOfRecordConstructor _ (MultipleConstructors constructors))) = do + ocamlInterface <- asks (includeOCamlInterface . userOptions) + fnName <- renderRef datatype + typeParameterDeclarations <- linesBetween <$> catMaybes <$> sequence (renderSumRecord typeName . OCamlValueConstructor <$> constructors) + fnBody <- mapM renderSum (OCamlSumOfRecordConstructor typeName <$> constructors) + + if ocamlInterface + then do + let typeParameters = renderEncodeTypeParameters constructor + pure $ typeParameterDeclarations + <$$> ("let" <+> fnName <+> typeParameters <+> "x =") + <$$> (indent 2 ("match x with" <$$> foldl1 (<$$>) fnBody)) + else do + let (typeParameterSignatures,typeParameters) = renderTypeParameters constructor + encodeFnName = stext $ textLowercaseFirst typeName + pure $ typeParameterDeclarations + <$$> ("let" <+> fnName <+> typeParameterSignatures <+> "(x :" <+> typeParameters <> encodeFnName <> ") :Js_json.t =") + <$$> (indent 2 ("match x with" <$$> foldl1 (<$$>) fnBody)) + + -- sum + render datatype@(OCamlDatatype _ typeName constructor@(OCamlValueConstructor (MultipleConstructors constructors))) = do + ocamlInterface <- asks (includeOCamlInterface . userOptions) + fnName <- renderRef datatype + dc <- mapM renderSum (OCamlValueConstructor <$> constructors) + if ocamlInterface + then do + let encodeTypeParameters = renderEncodeTypeParameters constructor + pure $ + ("let" <+> fnName <+> encodeTypeParameters <+> "x =") <$$> + (indent 2 ("match x with" <$$> foldl1 (<$$>) dc)) + else do + let (typeParameterSignatures,typeParameters) = renderTypeParameters constructor + encodeFnName = stext $ textLowercaseFirst typeName + pure $ + ("let" <+> fnName <+> typeParameterSignatures <+> "(x :" <+> typeParameters <> encodeFnName <> ") :Js_json.t =") <$$> + (indent 2 ("match x with" <$$> foldl1 (<$$>) dc)) + + -- product or record + render datatype@(OCamlDatatype _ typeName constructor) = do + ocamlInterface <- asks (includeOCamlInterface . userOptions) + fnName <- renderRef datatype + renderedConstructor <- render constructor + if ocamlInterface + then do + let typeParameters = renderEncodeTypeParameters constructor + pure $ + "let" <+> fnName <+> typeParameters <+> "x =" <$$> (indent 2 renderedConstructor) + else do + let (typeParameterSignatures,typeParameters) = renderTypeParameters constructor + encodeFnName = stext $ textLowercaseFirst typeName + pure $ "let" <+> fnName <+> typeParameterSignatures <+> "(x :" <+> typeParameters <> encodeFnName <> ") :Js_json.t =" + <$$> indent 2 renderedConstructor + + -- primitive + render (OCamlPrimitive primitive) = renderRef primitive + +-- | produce encode function name for data types and primitives +instance HasEncoderRef OCamlDatatype where + renderRef datatype@(OCamlDatatype typeRef name _) = do + if isTypeParameterRef datatype + then + pure $ "encode" <> (stext . textUppercaseFirst $ name) + else do + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> pure $ "encode" <> (stext . textUppercaseFirst $ name) + 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) + + renderRef (OCamlPrimitive primitive) = renderRef primitive + +instance HasEncoder OCamlConstructor where + -- Single constructor, no values: empty array + render (OCamlValueConstructor (NamedConstructor _name OCamlEmpty)) = + pure $ "Aeson.Encode.list []" + + -- Single constructor, multiple values: create array with values + render (OCamlValueConstructor (NamedConstructor name value)) = do + let constructorParams = constructorParameters 0 value + (encoders, _) <- renderVariable constructorParams value + + let encoders' = + if length constructorParams > 1 + then "Aeson.Encode.array" <+> arraybrackets encoders + else encoders + constructorParams' = + if length constructorParams > 1 + then ["("] <> (L.intersperse "," constructorParams) <> [")"] + else (L.intersperse "," constructorParams) + + pure $ "match x with" <$$> + "|" <+> stext name <+> foldl1 (<>) constructorParams' <+> "->" <$$> indent 3 encoders' + + -- Record constructor + render (OCamlValueConstructor (RecordConstructor _ value)) = do + recordValue <- render value + pure . nest 2 $ "Aeson.Encode.object_" <$$> "[" <+> recordValue <$$> "]" + + -- Sum + render (OCamlValueConstructor (MultipleConstructors constrs)) = do + sums <- mapM renderSum (OCamlValueConstructor <$> constrs) + pure $ "match x with" <$$> foldl1 (<$$>) sums + + -- Enumerator + render ec@(OCamlEnumeratorConstructor _constructors) = + (<$$>) "match x with" <$> renderSum ec + + render _ = return "" + + +-- | special rendering function for sum with record types +renderSumRecord :: Text -> OCamlConstructor -> Reader TypeMetaData (Maybe Doc) +renderSumRecord typeName (OCamlValueConstructor (RecordConstructor name value)) = do + ocamlInterface <- asks (includeOCamlInterface . userOptions) + let sumRecordName = typeName <> name + sumRecordBody <- render (OCamlValueConstructor $ RecordConstructor sumRecordName value) + if ocamlInterface + then + pure $ Just $ "let encode" <> stext sumRecordName <+> "x =" + <$$> indent 2 sumRecordBody + else + pure $ Just $ "let encode" <> stext sumRecordName <+> "(x : " <> (stext $ textLowercaseFirst sumRecordName) <> ") :Js_json.t =" + <$$> indent 2 sumRecordBody + +renderSumRecord _ _ = return Nothing + +-- | special rendering function for an encoders interface +renderSumRecordInterface :: Text -> OCamlConstructor -> Maybe Doc +renderSumRecordInterface typeName (OCamlValueConstructor (RecordConstructor name _value)) = + let sumRecordName = typeName <> name + in Just $ "val encode" <> stext sumRecordName <+> ":" <+> (stext . textLowercaseFirst $ sumRecordName) <+> "->" <+> "Js_json.t" +renderSumRecordInterface _ _ = Nothing + +-- | +renderSumOfRecordEncoder :: Text -> Text -> Reader TypeMetaData Doc +renderSumOfRecordEncoder typeName name = do + ao <- asks (aesonOptions . userOptions) + let jsonConstructorName = T.pack . Aeson.constructorTagModifier ao . T.unpack $ name + pure $ + "|" <+> stext name <+> "y0 ->" + <$$> " (match (Js.Json.decodeObject (encode" <> (stext . textUppercaseFirst $ typeName) <> stext name <+> "y0)) with" + <$$> " | Some dict ->" + <$$> " Js.Dict.set dict \"tag\" (Js.Json.string \"" <> stext jsonConstructorName <> "\");" + <$$> " Js.Json.object_ dict" + <$$> " | None ->" + <$$> " Aeson.Encode.object_ []" + <$$> " )" + +-- | render product values +jsonEncodeObject :: Doc -> Doc -> Maybe Doc -> Doc +jsonEncodeObject constructor tag mContents = + case mContents of + Nothing -> constructor <$$> indent 3 ("Aeson.Encode.object_" <$$> indent 2 ("[" <+> tag <$$> "]")) + Just contents -> constructor <$$> indent 3 ("Aeson.Encode.object_" <$$> indent 2 ("[" <+> tag <$$> contents <$$> "]")) + +-- | render body rules for sum types +renderSum :: OCamlConstructor -> Reader TypeMetaData Doc +renderSum (OCamlValueConstructor (NamedConstructor name OCamlEmpty)) = do + ao <- asks (aesonOptions . userOptions) + let jsonConstructorName = T.pack . Aeson.constructorTagModifier ao . T.unpack $ name + constructorMatchCase = "|" <+> stext name <+> "->" + encodeTag = pair (dquotes "tag") ("Aeson.Encode.string" <+> dquotes (stext jsonConstructorName)) + pure $ jsonEncodeObject constructorMatchCase encodeTag Nothing + +renderSum (OCamlValueConstructor (NamedConstructor name value)) = do + let constructorParams = constructorParameters 0 value + ao <- asks (aesonOptions . userOptions) + let jsonConstructorName = T.pack . Aeson.constructorTagModifier ao . T.unpack $ name + (encoders, _) <- renderVariable constructorParams value + let encoders' = + if length constructorParams > 1 + then "Aeson.Encode.array" <+> arraybrackets encoders + else encoders + constructorParams' = + if length constructorParams > 1 + then ["("] <> (L.intersperse "," constructorParams) <> [")"] + else (L.intersperse "," constructorParams) + constructorMatchCase = "|" <+> stext name <+> foldl1 (<>) constructorParams' <+> "->" + encodeTag = pair (dquotes "tag") ("Aeson.Encode.string" <+> dquotes (stext jsonConstructorName)) + encodeContents = ";" <+> pair (dquotes "contents") encoders' + + pure $ jsonEncodeObject constructorMatchCase encodeTag (Just encodeContents) + +renderSum (OCamlValueConstructor (RecordConstructor name value)) = do + ao <- asks (aesonOptions . userOptions) + let jsonConstructorName = T.pack . Aeson.constructorTagModifier ao . T.unpack $ name + encoder <- render value + let constructorMatchCase = "|" <+> stext name <+> "->" + encodeTag = pair (dquotes "tag") (dquotes $ stext jsonConstructorName) + encodeContents = comma <+> encoder + pure $ jsonEncodeObject constructorMatchCase encodeTag (Just encodeContents) + +renderSum (OCamlValueConstructor (MultipleConstructors constructors)) = do + encoders <- mapM renderSum (OCamlValueConstructor <$> constructors) + pure $ foldl1 (<$$>) encoders + +renderSum (OCamlSumOfRecordConstructor typeName (RecordConstructor name _value)) = do + renderSumOfRecordEncoder typeName name + +renderSum (OCamlSumOfRecordConstructor typeName (MultipleConstructors constructors)) = do + encoders <- mapM renderSum (OCamlSumOfRecordConstructor typeName <$> constructors) + pure $ foldl1 (<$$>) encoders + +renderSum (OCamlEnumeratorConstructor constructors) = + pure $ foldl1 (<$$>) $ (\(EnumeratorConstructor name) -> "|" <+> stext name <+> "->" <$$> " Aeson.Encode.string" <+> dquotes (stext name)) <$> constructors + +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.boolean" + 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 + return . parens $ "Aeson.Encode.list" <+> dd + + renderRef (OOption datatype) = do + dd <- renderRef datatype + return $ "Aeson.Encode.optional" <+> dd + + renderRef (OEither t0 t1) = do + dt0 <- renderRef t0 + dt1 <- renderRef t1 + return $ "Aeson.Encode.either" <+> dt0 <+> dt1 + + renderRef (OTuple2 t0 t1) = do + dt0 <- renderRef t0 + dt1 <- renderRef t1 + return $ "Aeson.Encode.pair" <+> dt0 <+> dt1 + + renderRef (OTuple3 t0 t1 t2) = do + dt0 <- renderRef t0 + dt1 <- renderRef t1 + dt2 <- renderRef t2 + return $ "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 + return $ "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 + return $ "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 + return $ "Aeson.Encode.tuple6" <+> dt0 <+> dt1 <+> dt2 <+> dt3 <+> dt4 <+> dt5 + +-- | 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 ] + + +-- | 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 +renderVariable :: [Doc] -> OCamlValue -> Reader TypeMetaData (Doc, [Doc]) +renderVariable (d : ds) v@(OCamlRef {}) = do + v' <- render v + return (v' <+> d, ds) +renderVariable ds OCamlEmpty = return (empty, ds) +renderVariable (_ : ds) (OCamlPrimitiveRef OUnit) = + return ("Aeson.Encode.null", ds) +renderVariable (d : ds) (OCamlPrimitiveRef ref) = do + r <- renderRef ref + return (r <+> d, ds) +renderVariable (d : ds) ref@(OCamlTypeParameterRef _) = do + r <- render ref + return (r <+> d, ds) +renderVariable ds (Values 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 + +-- | For an OCamlConstructor, get its OCamlValues as a list, if it has +-- type parameters, render the encoder type signatures for each type parameter +-- as `('a0 -> Js_json.t)` and `'a0`. This is for the interface. +-- fst Doc is type parameter encoder signature +-- snd Doc is list of type parameters which will be rendered as part of the main +-- type's values. +-- For `Either a b`: `("('a0 -> Js_json.t) ('a1 -> Js_json.t)","('a0, 'a1)")` +renderTypeParameterVals :: OCamlConstructor -> (Doc,Doc) +renderTypeParameterVals (OCamlValueConstructor vc) = renderTypeParameterValsAux $ getOCamlValues vc +renderTypeParameterVals (OCamlSumOfRecordConstructor _ vc) = renderTypeParameterValsAux $ getOCamlValues vc +renderTypeParameterVals _ = ("","") + +-- | Helper function for renderTypeParameterVals +renderTypeParameterValsAux :: [OCamlValue] -> (Doc,Doc) +renderTypeParameterValsAux ocamlValues = + let typeParameterNames = (<>) "'" <$> getTypeParameterRefNames ocamlValues + typeDecs = (\t -> "(" <> (stext t) <+> "-> Js_json.t)") <$> typeParameterNames + in + if length typeDecs > 0 + then + let ts = + if length typeParameterNames > 1 + then foldl (<>) "" $ ["("] <> (L.intersperse ", " $ stext <$> typeParameterNames) <> [") "] + else + -- `flip (<>) " "` means add a space to the end + if length typeParameterNames == 1 then stext . flip (<>) " " . head $ typeParameterNames + else "" + in ((foldl (<>) "" $ (L.intersperse " -> " typeDecs)) <> " ->", ts) + else ("","") + +-- | Render type parameters as encode functions. This is for a let declaration that has +-- a complete type signature. +-- `Either a b` : `("(encodeA0 : 'a0 -> Js_json.t) (encodeA0 : 'a1 -> Js_json.t)", "('a0, 'a1)")` +renderTypeParameters :: OCamlConstructor -> (Doc,Doc) +renderTypeParameters (OCamlValueConstructor vc) = renderTypeParametersAux $ getOCamlValues vc +renderTypeParameters (OCamlSumOfRecordConstructor _ vc) = renderTypeParametersAux $ getOCamlValues vc +renderTypeParameters _ = ("","") + +-- | Helper function for renderTypeParameters +renderTypeParametersAux :: [OCamlValue] -> (Doc,Doc) +renderTypeParametersAux ocamlValues = do + let typeParameterNames = getTypeParameterRefNames ocamlValues + typeDecs = (\t -> "(type " <> (stext t) <> ")") <$> typeParameterNames :: [Doc] + parserDecs = (\t -> "(encode" <> (stext $ textUppercaseFirst t) <+> ":" <+> (stext t) <+> "-> Js_json.t)" ) <$> typeParameterNames :: [Doc] + typeParams = foldl (<>) "" $ if length typeParameterNames > 1 then ["("] <> (L.intersperse ", " $ stext <$> typeParameterNames) <> [") "] else ((\x -> stext $ x <> " ") <$> typeParameterNames) :: [Doc] + (foldl (<+>) "" (typeDecs ++ parserDecs), typeParams ) + +-- | render type parameter encoder names for all of a constructors type parameters +-- `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) + +-- | 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) diff --git a/src/OCaml/BuckleScript/Internal/Module.hs b/src/OCaml/BuckleScript/Internal/Module.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/BuckleScript/Internal/Module.hs @@ -0,0 +1,239 @@ +{-| +Module : OCaml.BuckleScript.Internal.Module +Description : Build OCaml Modules from Haskell Types +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module OCaml.BuckleScript.Internal.Module + ( + -- define an OCamlModule with servant style types + OCamlModule + , OCamlSubModule + , OCamlTypeInFile + + , EmbeddedOCamlFiles (..) + + , HasOCamlType (..) + + -- template haskell + -- load OCamlTypeInFile files at compile time + , HasEmbeddedFile (..) + ) where + +-- base +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable, typeRep, typeRepTyCon, tyConName, splitTyConApp) +import GHC.TypeLits (Nat, Symbol, KnownSymbol, symbolVal) + +-- bytestring +import Data.ByteString (ByteString) + +-- containers +import qualified Data.Map.Strict as Map + +-- directory +-- import System.Directory (createDirectoryIfMissing) + +-- file-embed +import Data.FileEmbed (embedFile) + +-- filepath +import System.FilePath.Posix ((<.>)) -- ((), (<.>)) + +-- ocaml-export +import OCaml.Internal.Common hiding (()) +import OCaml.BuckleScript.Decode +import OCaml.BuckleScript.Encode +import OCaml.BuckleScript.Record +import OCaml.BuckleScript.Spec +import OCaml.BuckleScript.Types + +-- servant +import Servant.API ((:>)) + +-- template-haskell +import Language.Haskell.TH + +-- text +import Data.Text (Text) +import qualified Data.Text as T +-- import qualified Data.Text.IO as T +import Data.Text.Encoding (decodeUtf8) + + +-- ============================================== +-- Types +-- ============================================== + +-- | An OCamlModule as a Haskell type. File level 'modules' is relative to a +-- root directory prvoiided in the 'mkPackage' function. +data OCamlModule (modules :: [Symbol]) + deriving Typeable + +-- | Symobl will be expaneded to +-- "module SymbolName = struct ... end". +data OCamlSubModule (subModules :: Symbol) + deriving Typeable + +-- | A handwritten OCaml type, encoder and decoder from a file. +data OCamlTypeInFile a (filePath :: Symbol) + deriving Typeable + + +-- ============================================== +-- Data Types +-- ============================================== + +-- | Store OCamlFileInType data. +data EmbeddedOCamlFiles = + EmbeddedOCamlFiles + { eocDeclaration :: ByteString + , eocInterface :: Maybe ByteString + , eocSpec :: Maybe ByteString + } + + + + + +-- ============================================== +-- Type Level Functions +-- ============================================== + +-- | Convert a Haskell type into OCaml source code. +class HasOCamlType api where + mkType :: Proxy api -> Options -> Bool -> Map.Map String EmbeddedOCamlFiles -> [Text] + mkInterface :: Proxy api -> Options -> Map.Map String EmbeddedOCamlFiles -> [Text] + mkSpec :: Proxy api -> Options -> [Text] -> Text -> Text -> Map.Map String EmbeddedOCamlFiles -> [Text] + +instance (HasOCamlTypeFlag a ~ flag, HasOCamlType' flag (a :: *)) => HasOCamlType a where + mkType = mkType' (Proxy :: Proxy flag) + mkInterface = mkInterface' (Proxy :: Proxy flag) + mkSpec = mkSpec' (Proxy :: Proxy flag) + +type family (HasOCamlTypeFlag a) :: Nat where + HasOCamlTypeFlag (OCamlSubModule a :> b) = 4 + HasOCamlTypeFlag (a :> b) = 3 + HasOCamlTypeFlag (OCamlTypeInFile a b) = 2 + HasOCamlTypeFlag a = 1 + +-- | Helper function to work avoid overlapped instances. +class HasOCamlType' (flag :: Nat) api where + mkType' :: Proxy flag -> Proxy api -> Options -> Bool -> Map.Map String EmbeddedOCamlFiles -> [Text] + mkInterface' :: Proxy flag -> Proxy api -> Options -> Map.Map String EmbeddedOCamlFiles -> [Text] + mkSpec' :: Proxy flag -> Proxy api -> Options -> [Text] -> Text -> Text -> Map.Map String EmbeddedOCamlFiles -> [Text] + +instance (KnownSymbol subModule, HasOCamlType b) => HasOCamlType' 4 (OCamlSubModule subModule :> b) where + mkType' _ Proxy options interface fileMap = ["module " <> (T.pack $ symbolVal (Proxy :: Proxy subModule)) <> " = struct\n"] <> (mkType (Proxy :: Proxy b) options interface fileMap) <> ["\nend"] + + mkInterface' _ Proxy options fileMap = ["module " <> (T.pack $ symbolVal (Proxy :: Proxy subModule)) <> " : sig\n"] <> (mkInterface (Proxy :: Proxy b) options fileMap) <> ["\nend"] + + mkSpec' _ Proxy options modules url goldendir fileMap = mkSpec (Proxy :: Proxy b) options modules url goldendir fileMap + +instance (HasOCamlType a, HasOCamlType b) => HasOCamlType' 3 (a :> b) where + mkType' _ Proxy options interface fileMap = (mkType (Proxy :: Proxy a) options interface fileMap) <> (mkType (Proxy :: Proxy b) options interface fileMap) + mkInterface' _ Proxy options fileMap = (mkInterface (Proxy :: Proxy a) options fileMap) <> (mkInterface (Proxy :: Proxy b) options fileMap) + mkSpec' _ Proxy options modules url goldendir fileMap = (mkSpec (Proxy :: Proxy a) options modules url goldendir fileMap) <> (mkSpec (Proxy :: Proxy b) options modules url goldendir fileMap) + +instance (Typeable a) => HasOCamlType' 2 (OCamlTypeInFile a b) where + mkType' _ Proxy _options _ fileMap = do + let typeName = tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a) + case eocDeclaration <$> Map.lookup typeName fileMap of + Just v -> [decodeUtf8 v] + _ -> fail $ "Unable to find the embedded file for " ++ typeName + + mkInterface' _ Proxy _options fileMap = do + let typeName = tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a) + case eocInterface <$> Map.lookup typeName fileMap of + Just (Just v) -> [decodeUtf8 v] + _ -> fail $ "Unable to find the embedded file for " ++ typeName + + mkSpec' _ Proxy _options modules url goldendir _fileMap = + [typeInFileToOCamlSpec (T.pack . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)) typeParameterRefCount modules url goldendir] + where + parameters = fmap show . snd . splitTyConApp $ typeRep (Proxy :: Proxy a) + inParameters = flip elem parameters + xs = + [ inParameters "TypeParameterRef0" + , inParameters "TypeParameterRef1" + , inParameters "TypeParameterRef2" + , inParameters "TypeParameterRef3" + , inParameters "TypeParameterRef4" + , inParameters "TypeParameterRef5" + , inParameters "TypeParameterRef6" + ] + countTrues = foldl (flip ((+) . fromEnum)) 0 + typeParameterRefCount = countTrues xs + + +instance (OCamlType a) => HasOCamlType' 1 a where + mkType' _ a options interface _ = body + where + body = [(toOCamlTypeSourceWith options a) + , (toOCamlEncoderSourceWith (options {includeOCamlInterface = interface}) a) + , (toOCamlDecoderSourceWith (options {includeOCamlInterface = interface}) a)] + + mkInterface' _ a options _ = body + where + body = [(toOCamlTypeSourceWith options a) + , (toOCamlEncoderInterfaceWith options a) + , (toOCamlDecoderInterfaceWith options a)] + + mkSpec' _ a _options modules url goldendir _ = [toOCamlSpec a modules url goldendir] + + + + +-- ============================================== +-- Template Haskell +-- ============================================== + +-- | Use Template Haskell to load OCaml files for an OCaml Module at compile time. +-- '$(mkFile (Proxy :: Proxy Package))'. +class HasEmbeddedFile api where + mkFiles :: Bool -> Bool -> Proxy api -> Q Exp + +instance (HasEmbeddedFile' api) => HasEmbeddedFile api where + mkFiles includeInterface includeSpec Proxy = ListE <$> mkFiles' includeInterface includeSpec (Proxy :: Proxy api) + +-- | Help function for HasEmbeddedFile. +class HasEmbeddedFile' api where + mkFiles' :: Bool -> Bool -> Proxy api -> Q [Exp] + +instance (HasEmbeddedFile' a, HasEmbeddedFile' b) => HasEmbeddedFile' (a :> b) where + mkFiles' includeInterface includeSpec Proxy = (<>) <$> mkFiles' includeInterface includeSpec (Proxy :: Proxy a) <*> mkFiles' includeInterface includeSpec (Proxy :: Proxy b) + +instance (Typeable a, KnownSymbol b) => HasEmbeddedFile' (OCamlTypeInFile a b) where + mkFiles' includeInterface includeSpec Proxy = do + let typeFilePath = symbolVal (Proxy :: Proxy b) + let typeName = tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a) + ml <- embedFile (typeFilePath <.> "ml") + + mli <- if includeInterface + then (\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") + else pure $ ConE $ mkName "Nothing" + + pure [TupE [LitE $ StringL typeName, AppE (AppE (AppE (ConE $ mkName "EmbeddedOCamlFiles") ml) mli) spec]] + +instance {-# OVERLAPPABLE #-} HasEmbeddedFile' a where + mkFiles' _ _ Proxy = pure [] diff --git a/src/OCaml/BuckleScript/Internal/Package.hs b/src/OCaml/BuckleScript/Internal/Package.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/BuckleScript/Internal/Package.hs @@ -0,0 +1,268 @@ +{-| +Module : OCaml.BuckleScript.Internal.Package +Description : Build OCaml Modules from Haskell Types +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module OCaml.BuckleScript.Internal.Package + ( + -- define an OCamlPackage with servant style types + OCamlPackage + , NoDependency + + + , PackageOptions (..) + , defaultPackageOptions + , SpecOptions (..) + , defaultSpecOptions + + , HasOCamlPackage (..) + , HasOCamlModule (..) + , HasOCamlTypeMetaData (..) + + ) where + +-- base +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) +import Data.Typeable (typeRep, Typeable, typeRepTyCon, tyConName, tyConModule, tyConPackage) +import GHC.TypeLits + +-- containers +import qualified Data.Map.Strict as Map + +-- directory +import System.Directory (createDirectoryIfMissing) + +-- filepath +import System.FilePath.Posix ((), (<.>)) + +-- ocaml-export +import OCaml.Internal.Common hiding (()) +import OCaml.BuckleScript.Internal.Module +import OCaml.BuckleScript.Types + +-- servant +import Servant.API ((:>), (:<|>)) + +-- text +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T + +-- typelits-witnesses +import GHC.TypeLits.List + + + +-- ============================================== +-- Types +-- ============================================== + +data OCamlPackage (packageName :: Symbol) (packageDependencies :: [*]) + deriving Typeable + +type NoDependency = '[] + + + + +-- ============================================== +-- Data Types +-- ============================================== + +-- | Options for creating an OCaml package based on Haskell types. +data PackageOptions + = PackageOptions + { packageRootDir :: FilePath -- ^ root directory where all relatives directories will be placed. + , packageSrcDir :: FilePath -- ^ location to place ml and mli files relative to 'packageRootDir'. + , packageEmbeddedFiles :: Map.Map String EmbeddedOCamlFiles + , createInterfaceFile :: Bool -- ^ create an mli file if 'True'. + , mSpecOptions :: Maybe SpecOptions -- ^ produce OCaml spec file if 'Just'. + } + +-- | Default 'PackageOptions'. +defaultPackageOptions :: PackageOptions +defaultPackageOptions = PackageOptions "ocaml-generic-package" "src" Map.empty True (Just defaultSpecOptions) + +-- | Details for OCaml spec. +data SpecOptions + = SpecOptions + { specDir :: FilePath -- ^ Directory in which to store the OCaml spec, relative to 'packageRootDir'. + , goldenDir :: FilePath -- ^ Location of golden JSON files produced by Haskell, relative to 'packageRootDir'. + , servantURL :: String -- ^ The URL of the automated Servant spec server to run OCaml specs against. + } + +-- | Default 'SpecOptions'. +defaultSpecOptions :: SpecOptions +defaultSpecOptions = SpecOptions "/__tests__" "/__tests__/golden" "localhost:8081" + + +-- ============================================== +-- Type Level Functions +-- ============================================== + +-- | Iterate over a list of OCamlModule types that are concated with '(:<|>)', +-- to create a package. +class HasOCamlPackage a where + mkPackage :: Proxy a -> PackageOptions -> IO () + +instance (HasOCamlTypeMetaData deps, HasOCamlTypeMetaData a, HasOCamlPackage' a) => HasOCamlPackage (OCamlPackage packageName deps :> a) where + mkPackage Proxy packageOptions = mkPackage' (Proxy :: Proxy a) packageOptions (mkOCamlTypeMetaData (Proxy :: Proxy deps) <> mkOCamlTypeMetaData (Proxy :: Proxy a)) + +instance {-# OVERLAPPABLE #-} (HasOCamlTypeMetaData a, HasOCamlPackage' a) => HasOCamlPackage a where + mkPackage Proxy packageOptions = do + mkPackage' (Proxy :: Proxy a) packageOptions (mkOCamlTypeMetaData (Proxy :: Proxy a)) + +class HasOCamlPackage' a where + mkPackage' :: Proxy a -> PackageOptions -> Map.Map HaskellTypeMetaData OCamlTypeMetaData -> IO () + +instance (HasOCamlPackage' modul, HasOCamlPackage' rest) => HasOCamlPackage' (modul :<|> rest) where + mkPackage' Proxy packageOptions deps = do + mkPackage' (Proxy :: Proxy modul) packageOptions deps + mkPackage' (Proxy :: Proxy rest) packageOptions deps + +instance {-# OVERLAPPABLE #-} (HasOCamlModule a) => HasOCamlPackage' a where + mkPackage' Proxy packageOptions = mkModule (Proxy :: Proxy a) packageOptions + + + + + +-- | Depending on 'PackageOptions' settings, 'mkModule' can +-- - make a declaration file containing encoders and decoders +-- - make an OCaml interface file +-- - make a Spec file that tests the encoders and decoders against a golden file and a servant server +class HasOCamlModule a where + mkModule :: Proxy a -> PackageOptions -> Map.Map HaskellTypeMetaData OCamlTypeMetaData -> IO () + +instance (KnownSymbols modules, HasOCamlModule' api) => HasOCamlModule ((OCamlModule modules) :> api) where + mkModule Proxy packageOptions deps = mkModule' (Proxy :: Proxy api) (symbolsVal (Proxy :: Proxy modules)) packageOptions deps + +class HasOCamlModule' a where + mkModule' :: Proxy a -> [String] -> PackageOptions -> Map.Map HaskellTypeMetaData OCamlTypeMetaData -> IO () + +instance (HasOCamlType api) => HasOCamlModule' api where + mkModule' Proxy modules packageOptions ds = do + if (length modules) == 0 + then fail "OCamlModule filePath needs at least one file name" + else do + createDirectoryIfMissing True (rootDir packageSrcDir packageOptions) + let typF = (<> "\n") . T.intercalate "\n\n" $ mkType (Proxy :: Proxy api) (defaultOptions {dependencies = ds}) (createInterfaceFile packageOptions) (packageEmbeddedFiles packageOptions) + T.writeFile (fp <.> "ml") typF + + if createInterfaceFile packageOptions + then do + let intF = (<> "\n") . T.intercalate "\n\n" $ mkInterface (Proxy :: Proxy api) (defaultOptions {dependencies = ds}) (packageEmbeddedFiles packageOptions) + T.writeFile (fp <.> "mli") intF + else pure () + + case mSpecOptions packageOptions of + Nothing -> pure () + Just specOptions -> do + let specF = (<> "\n") . T.intercalate "\n\n" $ mkSpec (Proxy :: Proxy api) (defaultOptions {dependencies = ds}) moduls (T.pack $ servantURL specOptions) (T.pack $ goldenDir specOptions) (packageEmbeddedFiles packageOptions) + let specBody = if specF /= "" then ("let () =\n" <> specF) else "" + createDirectoryIfMissing True (rootDir (specDir specOptions)) + T.writeFile (specFp <> "_spec" <.> "ml") specBody + + where + specFp = rootDir (specDir specOptions) (foldl () "" modules) + moduls = T.pack <$> modules + where + rootDir = packageRootDir packageOptions + fp = rootDir (packageSrcDir packageOptions) (foldl () "" modules) + + + + + +-- | Produce type meta data for an OCamlPackage and its dependencies +class HasOCamlTypeMetaData a where + mkOCamlTypeMetaData :: Proxy a -> Map.Map HaskellTypeMetaData OCamlTypeMetaData + +-- | packages +instance (HasOCamlTypeMetaData (OCamlPackage packageName deps), HasOCamlTypeMetaData rest) => HasOCamlTypeMetaData (OCamlPackage packageName deps :<|> rest) where + mkOCamlTypeMetaData Proxy = mkOCamlTypeMetaData (Proxy :: Proxy (OCamlPackage packageName deps)) <> mkOCamlTypeMetaData (Proxy :: Proxy rest) + +-- | build a packages dependencies and its declared modules +instance (HasOCamlTypeMetaData deps, HasOCamlTypeMetaData modules) => HasOCamlTypeMetaData (OCamlPackage packageName deps :> modules) where + mkOCamlTypeMetaData Proxy = mkOCamlTypeMetaData (Proxy :: Proxy deps) <> mkOCamlTypeMetaData (Proxy :: Proxy modules) + +-- | packages +instance (HasOCamlTypeMetaData modul, HasOCamlTypeMetaData rst) => HasOCamlTypeMetaData (modul ': rst) where + mkOCamlTypeMetaData Proxy = mkOCamlTypeMetaData (Proxy :: Proxy modul) <> mkOCamlTypeMetaData (Proxy :: Proxy rst) + +-- | modules +instance (HasOCamlTypeMetaData modul, HasOCamlTypeMetaData rst) => HasOCamlTypeMetaData (modul :<|> rst) where + mkOCamlTypeMetaData Proxy = mkOCamlTypeMetaData (Proxy :: Proxy modul) <> mkOCamlTypeMetaData (Proxy :: Proxy rst) + +-- | single module +instance (KnownSymbols modules, HasOCamlTypeMetaData' api) => HasOCamlTypeMetaData ((OCamlModule modules) :> api) where + mkOCamlTypeMetaData Proxy = Map.fromList $ mkOCamlTypeMetaData' (T.pack <$> symbolsVal (Proxy :: Proxy modules)) [] (Proxy :: Proxy api) + +-- | empty list +instance HasOCamlTypeMetaData '[] where + mkOCamlTypeMetaData Proxy = Map.empty + +-- | Need flag to overcome overlapping issues +type family (HasOCamlTypeMetaDataFlag a) :: Nat where + HasOCamlTypeMetaDataFlag (OCamlSubModule a :> b) = 4 + HasOCamlTypeMetaDataFlag (a :> b) = 3 + HasOCamlTypeMetaDataFlag (OCamlTypeInFile a b) = 2 + HasOCamlTypeMetaDataFlag a = 1 + +class HasOCamlTypeMetaData' a where + mkOCamlTypeMetaData' :: [Text] -> [Text] -> Proxy a -> [(HaskellTypeMetaData,OCamlTypeMetaData)] + +instance (HasOCamlTypeMetaDataFlag a ~ flag, HasOCamlTypeMetaData'' flag (a :: *)) => HasOCamlTypeMetaData' a where + mkOCamlTypeMetaData' = mkOCamlTypeMetaData'' (Proxy :: Proxy flag) + +class HasOCamlTypeMetaData'' (flag :: Nat) a where + mkOCamlTypeMetaData'' :: Proxy flag -> [Text] -> [Text] -> Proxy a -> [(HaskellTypeMetaData,OCamlTypeMetaData)] + +instance (KnownSymbol subModule, HasOCamlTypeMetaData' b) => HasOCamlTypeMetaData'' 4 (OCamlSubModule subModule :> b) where + mkOCamlTypeMetaData'' _ modules subModules Proxy = + (mkOCamlTypeMetaData' modules (subModules ++ [T.pack $ symbolVal (Proxy :: Proxy subModule)]) (Proxy :: Proxy b)) + +instance (HasOCamlTypeMetaData' a, HasOCamlTypeMetaData' b) => HasOCamlTypeMetaData'' 3 (a :> b) where + mkOCamlTypeMetaData'' _ modul subModul Proxy = (mkOCamlTypeMetaData' modul subModul (Proxy :: Proxy a)) <> (mkOCamlTypeMetaData' modul subModul (Proxy :: Proxy b)) + + +instance (Typeable a) => HasOCamlTypeMetaData'' 2 (OCamlTypeInFile a b) where + mkOCamlTypeMetaData'' _ modul subModul Proxy = + [( HaskellTypeMetaData typeName (T.pack . tyConModule . typeRepTyCon $ aTypeRep) (T.pack . tyConPackage . typeRepTyCon $ aTypeRep) + , OCamlTypeMetaData typeName modul subModul + )] + where + aTypeRep = typeRep (Proxy :: Proxy a) + typeName = T.pack . tyConName . typeRepTyCon $ aTypeRep + +instance (Typeable a) => HasOCamlTypeMetaData'' 1 a where + mkOCamlTypeMetaData'' _ modul subModul Proxy = + [( HaskellTypeMetaData typeName (T.pack . tyConModule . typeRepTyCon $ aTypeRep) (T.pack . tyConPackage . typeRepTyCon $ aTypeRep) + , OCamlTypeMetaData typeName modul subModul + )] + where + aTypeRep = typeRep (Proxy :: Proxy a) + typeName = T.pack . tyConName . typeRepTyCon $ aTypeRep diff --git a/src/OCaml/BuckleScript/Internal/Spec.hs b/src/OCaml/BuckleScript/Internal/Spec.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/BuckleScript/Internal/Spec.hs @@ -0,0 +1,245 @@ +{-| +Module : OCaml.BuckleScript.Internal.Spec +Description : Build OCaml Modules from Haskell Types +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module OCaml.BuckleScript.Internal.Spec + ( + mkOCamlSpecServer + , MkOCamlSpecAPI + + , mkGoldenFiles + + -- utility functions + , OCamlSpecAPI + , OCamlPackageTypeCount (..) + , OCamlModuleTypeCount (..) + ) where + +-- base +import Data.Proxy +import Data.Semigroup (Semigroup (..)) +import GHC.Generics +import GHC.TypeLits + +-- aeson +import Data.Aeson (ToJSON) + +-- hspec-aeson-golden +import Test.Aeson.Internal.ADT.GoldenSpecs (mkGoldenFileForType) + +-- ocaml-export +import OCaml.Internal.Common hiding (()) +import OCaml.BuckleScript.Internal.Module +import OCaml.BuckleScript.Internal.Package + +-- quickcheck-arbitrary-adt +import Test.QuickCheck.Arbitrary.ADT + +-- servant +import Servant.API + +-- template-haskell +import Language.Haskell.TH + +-- text +import Data.Text (Text) + + +mkOCamlSpecServer :: forall ocamlPackage. (OCamlPackageTypeCount ocamlPackage) => String -> Proxy ocamlPackage -> Q [Dec] +mkOCamlSpecServer typeName Proxy = do + let sizes = ocamlPackageTypeCount (Proxy :: Proxy ocamlPackage) + if (length sizes) < 1 || (not . and $ (> 0) <$> sizes) + then fail $ "sizes must have at least one element and each element must be greater than zero: " <> show sizes + else do + let argss = (\size -> foldr (\l r -> ParensE $ UInfixE l (ConE $ mkName ":<|>") r) (VarE $ mkName "pure") (replicate (size-1) (VarE $ mkName "pure"))) <$> sizes + let args = foldl (\l r -> UInfixE l (ConE $ mkName ":<|>") r) (head argss) (tail argss) + return $ + [ SigD serverName (AppT (ConT $ mkName "Server") $ AppT (ConT $ mkName "MkOCamlSpecAPI") (ConT $ apiName)) + , FunD serverName [Clause [] (NormalB args ) [] ] + + , SigD apiProxy (AppT (ConT $ mkName "Proxy") $ AppT (ConT $ mkName "MkOCamlSpecAPI") (ConT $ apiName)) + , FunD apiProxy [Clause [] (NormalB $ ConE $ mkName "Proxy") []] + + , SigD appName (ConT $ mkName "Application") + , FunD appName [Clause [] (NormalB $ AppE (AppE (VarE $ mkName "serve") (VarE apiProxy)) (VarE serverName)) []] + ] + where + serverName = mkName $ lowercaseFirst typeName ++ "Server" + apiName = mkName $ uppercaseFirst typeName + apiProxy = mkName $ lowercaseFirst typeName ++ "API" + appName = mkName $ lowercaseFirst typeName ++ "App" + + +-- | Make hspec-aeson-golden golden files for each type in an OCamlPackage +class HasMkGoldenFiles a where + mkGoldenFiles :: Proxy a -> Int -> FilePath -> IO () + +instance (HasMkGoldenFilesFlag a ~ flag, HasMkGoldenFiles' flag (a :: *)) => HasMkGoldenFiles a where + mkGoldenFiles = mkGoldenFiles' (Proxy :: Proxy flag) + +type family (HasMkGoldenFilesFlag a) :: Nat where + HasMkGoldenFilesFlag (OCamlPackage a b :> c) = 7 + HasMkGoldenFilesFlag ((OCamlModule a :> b) :<|> c) = 6 + HasMkGoldenFilesFlag (OCamlModule a :> b) = 5 + HasMkGoldenFilesFlag (OCamlSubModule a :> b) = 4 + HasMkGoldenFilesFlag (OCamlTypeInFile a b) = 3 + HasMkGoldenFilesFlag (a :> b) = 2 + HasMkGoldenFilesFlag a = 1 + +class HasMkGoldenFiles' (flag :: Nat) a where + mkGoldenFiles' :: Proxy flag -> Proxy a -> Int -> FilePath -> IO () + +instance (HasMkGoldenFiles a) => HasMkGoldenFiles' 7 (OCamlPackage packageName deps :> a) where + mkGoldenFiles' _ Proxy size fp = mkGoldenFiles (Proxy :: Proxy a) size fp + +instance (HasMkGoldenFiles a, HasMkGoldenFiles b) => HasMkGoldenFiles' 6 ((OCamlModule modules :> a) :<|> b) where + mkGoldenFiles' _ Proxy size fp = do + mkGoldenFiles (Proxy :: Proxy a) size fp + mkGoldenFiles (Proxy :: Proxy b) size fp + +instance (HasMkGoldenFiles a) => HasMkGoldenFiles' 5 (OCamlModule modules :> a) where + mkGoldenFiles' _ Proxy size fp = mkGoldenFiles (Proxy :: Proxy a) size fp + +instance (HasMkGoldenFiles a) => HasMkGoldenFiles' 4 (OCamlSubModule subModule :> a) where + mkGoldenFiles' _ Proxy size fp = mkGoldenFiles (Proxy :: Proxy a) size fp + +instance (ToADTArbitrary a, ToJSON a) => HasMkGoldenFiles' 3 (OCamlTypeInFile a b) where + mkGoldenFiles' _ Proxy size fp = mkGoldenFileForType size (Proxy :: Proxy a) fp + +instance (HasMkGoldenFiles a, HasMkGoldenFiles b) => HasMkGoldenFiles' 2 (a :> b) where + mkGoldenFiles' _ Proxy size fp = do + mkGoldenFiles (Proxy :: Proxy a) size fp + mkGoldenFiles (Proxy :: Proxy b) size fp + +instance (ToADTArbitrary a, ToJSON a) => HasMkGoldenFiles' 1 a where + mkGoldenFiles' _ Proxy size fp = mkGoldenFileForType size (Proxy :: Proxy a) fp + + + + + +-- | Convert an OCamlPackage into a servant API. +type family MkOCamlSpecAPI a :: * where + MkOCamlSpecAPI (OCamlPackage a deps :> rest) = MkOCamlSpecAPI rest + MkOCamlSpecAPI ((OCamlModule modules :> api) :<|> rest) = MkOCamlSpecAPI' modules '[] api :<|> MkOCamlSpecAPI rest + MkOCamlSpecAPI (OCamlModule modules :> api) = MkOCamlSpecAPI' modules '[] api + +-- | Utility type level function. +type family MkOCamlSpecAPI' modules subModules api :: * where + MkOCamlSpecAPI' modules subModules ((OCamlSubModule restSubModules) :> a) = MkOCamlSpecAPI' modules (Append subModules '[restSubModules]) a + MkOCamlSpecAPI' modules subModules (a :> b) = MkOCamlSpecAPI' modules subModules a :<|> MkOCamlSpecAPI' modules subModules b + MkOCamlSpecAPI' modules subModules (OCamlTypeInFile api _typeFilePath) = OCamlSpecAPI modules subModules api + MkOCamlSpecAPI' modules subModules api = OCamlSpecAPI modules subModules api + +-- | A servant route for a testing an OCaml type's encoder and decoder +type OCamlSpecAPI (modules :: [Symbol]) (subModules :: [Symbol]) typ = + ConcatSymbols (Insert (TypeName typ) (Append modules subModules)) (ReqBody '[JSON] [typ] :> Post '[JSON] [typ]) + +class OCamlModuleTypeCount api where + ocamlModuleTypeCount :: Proxy api -> Int + +instance (OCamlModuleTypeCountFlag a ~ flag, OCamlModuleTypeCount' flag (a :: *)) => OCamlModuleTypeCount a where + ocamlModuleTypeCount = ocamlModuleTypeCount' (Proxy :: Proxy flag) + +type family (OCamlModuleTypeCountFlag a) :: Bool where + OCamlModuleTypeCountFlag (a :> b) = 'True + OCamlModuleTypeCountFlag (OCamlModule a) = 'True + OCamlModuleTypeCountFlag (OCamlSubModule a) = 'True + OCamlModuleTypeCountFlag a = 'False + +class OCamlModuleTypeCount' (flag :: Bool) a where + ocamlModuleTypeCount' :: Proxy flag -> Proxy a -> Int + +instance (OCamlModuleTypeCount a, OCamlModuleTypeCount b) => OCamlModuleTypeCount' 'True (a :> b) where + ocamlModuleTypeCount' _ Proxy = (ocamlModuleTypeCount (Proxy :: Proxy a)) + (ocamlModuleTypeCount (Proxy :: Proxy b)) + +instance OCamlModuleTypeCount' 'True (OCamlModule modules) where + ocamlModuleTypeCount' _ Proxy = 0 + +instance OCamlModuleTypeCount' 'True (OCamlSubModule subModules) where + ocamlModuleTypeCount' _ Proxy = 0 + +instance OCamlModuleTypeCount' 'False a where + ocamlModuleTypeCount' _ Proxy = 1 + +class OCamlPackageTypeCount modules where + ocamlPackageTypeCount :: Proxy modules -> [Int] + +instance (OCamlPackageTypeCountFlag a ~ flag, OCamlPackageTypeCount' flag (a :: *)) => OCamlPackageTypeCount a where + ocamlPackageTypeCount = ocamlPackageTypeCount' (Proxy :: Proxy flag) + +type family (OCamlPackageTypeCountFlag a) :: Bool where + OCamlPackageTypeCountFlag (OCamlPackage a b :> c) = 'True + OCamlPackageTypeCountFlag (a :<|> b) = 'True + OCamlPackageTypeCountFlag a = 'False + +class OCamlPackageTypeCount' (flag :: Bool) a where + ocamlPackageTypeCount' :: Proxy flag -> Proxy a -> [Int] + +-- OCamlPackage does not increment +instance (OCamlPackageTypeCount b) => OCamlPackageTypeCount' 'True (OCamlPackage a deps :> b) where + ocamlPackageTypeCount' _ Proxy = ocamlPackageTypeCount (Proxy :: Proxy b) + +-- Choice operator does not increment +instance (OCamlModuleTypeCount a, OCamlPackageTypeCount b) => OCamlPackageTypeCount' 'True (a :<|> b) where + ocamlPackageTypeCount' _ Proxy = (ocamlModuleTypeCount (Proxy :: Proxy a)) : (ocamlPackageTypeCount (Proxy :: Proxy b)) + +-- everything else should count as one +instance (OCamlModuleTypeCount a) => OCamlPackageTypeCount' 'False a where + ocamlPackageTypeCount' _ Proxy = [ocamlModuleTypeCount (Proxy :: Proxy a)] + + +-- | Convert a type into a Symbol at the type level. +type family TypeName a :: Symbol where + -- Types which don't have a Generic instance + TypeName Double = "Double" + TypeName Int = "Int" + TypeName String = "String" + TypeName Text = "Text" + + -- Generic instances + TypeName (M1 D ('MetaData name _ _ _) f ()) = name + TypeName a = TypeName (Rep a ()) + +-- | Append two type level lists. +type family Append xy ys where + Append '[] ys = ys + Append (x ': xs) ys = x ': (Append xs ys) + +-- | Get the length of a type level list. +type family Length xs :: Nat where + Length '[] = 0 + Length (x ': xs) = 1 + Length xs + +-- | Insert type into type level list +type family Insert a xs where + Insert a '[] = a ': '[] + Insert a (x ': xs) = x ': (Insert a xs) + +-- | Concat a Symbol the end of a list of Symbols. +type family ConcatSymbols xs rhs :: * where + ConcatSymbols '[] rhs = rhs + ConcatSymbols (x ': xs) rhs = x :> ConcatSymbols xs rhs diff --git a/src/OCaml/BuckleScript/Record.hs b/src/OCaml/BuckleScript/Record.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/BuckleScript/Record.hs @@ -0,0 +1,255 @@ +{-| +Module : OCaml.BuckleScript.Record +Description : Create OCaml data types from Haskell data types +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +For a Haskell type with an instance of OCamlType, output the +OCaml type declaration. +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module OCaml.BuckleScript.Record + ( toOCamlTypeSourceWith + ) where + +-- base +import Control.Monad.Reader +import Data.List (nub) +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Proxy (Proxy (..)) + +-- containers +import qualified Data.Map.Strict as Map + +-- ocaml-export +import OCaml.BuckleScript.Types +import OCaml.Internal.Common + +-- text +import Data.Text (Text) +import qualified Data.Text as T + +-- wl-pprint +import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) + +-- | render a Haskell data type in OCaml +class HasType a where + render :: a -> Reader TypeMetaData Doc + +class HasRecordType a where + renderRecord :: a -> Reader TypeMetaData Doc + +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. + sumRecordsData <- catMaybes <$> sequence (renderSumRecord typeName <$> constructors) + let sumRecords = msuffix (line <> line) (fst <$> sumRecordsData) + newConstructors = replaceRecordConstructors (snd <$> sumRecordsData) <$> constructors + typeParameters = renderTypeParameters constructor + fnName <- renderRef datatype + fnBody <- render (OCamlValueConstructor $ MultipleConstructors newConstructors) + pure $ sumRecords <> ("type" <+> typeParameters <+> fnName <+> "=" <$$> indent 2 ("|" <+> fnBody)) + + render datatype@(OCamlDatatype _ _ constructor@(OCamlValueConstructor (RecordConstructor _ _))) = do + let typeParameters = renderTypeParameters constructor + fnName <- renderRef datatype + fnBody <- render constructor + pure $ "type" <+> typeParameters <+> fnName <+> "=" <$$> indent 2 fnBody + + render datatype@(OCamlDatatype _ _ constructor) = do + let typeParameters = renderTypeParameters constructor + fnName <- renderRef datatype + fnBody <- render constructor + pure $ "type" <+> typeParameters <+> fnName <+> "=" <$$> indent 2 ("|" <+> fnBody) + + render (OCamlPrimitive primitive) = renderRef primitive + +instance HasTypeRef OCamlDatatype where + renderRef datatype@(OCamlDatatype typeRef typeName _) = do + if isTypeParameterRef datatype + then + pure . stext $ "'" <> textLowercaseFirst typeName + else do + mOCamlTypeMetaData <- asks topLevelOCamlTypeMetaData + case mOCamlTypeMetaData of + Nothing -> pure . stext . textLowercaseFirst $ typeName + + Just decOCamlTypeMetaData -> do + ds <- asks (dependencies . userOptions) + case Map.lookup typeRef ds of + Just parOCamlTypeMetaData -> do + let prefix = stext $ mkModulePrefix decOCamlTypeMetaData parOCamlTypeMetaData + pure $ prefix <> (stext . textLowercaseFirst $ typeName) + Nothing -> fail ("expected to find dependency:\n\n" ++ show typeRef ++ "\n\nin\n\n" ++ show ds) + + renderRef (OCamlPrimitive primitive) = renderRef primitive + +instance HasType OCamlConstructor where + render (OCamlValueConstructor value) = render value + render (OCamlSumOfRecordConstructor _ value) = render value + render (OCamlEnumeratorConstructor constructors) = do + mintercalate (line <> "|" <> space) <$> sequence (render <$> constructors) + +instance HasType ValueConstructor where + -- record + render (RecordConstructor _ value) = do + fields <- renderRecord value + pure $ "{" <+> fields <$$> "}" + + -- enumerator + render (NamedConstructor constructorName (OCamlEmpty)) = do + pure $ stext constructorName + + -- product + render (NamedConstructor constructorName value) = do + types <- render value + pure $ stext constructorName <+> "of" <+> types + + -- sum + 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 + 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 + + 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 + render (OCamlField name value) = do + dv <- renderRecord value + return $ stext name <+> ":" <+> dv + +instance HasRecordType OCamlValue where + renderRecord (OCamlPrimitiveRef primitive) = renderRef primitive + renderRecord (Values x y) = do + dx <- renderRecord x + dy <- renderRecord y + return $ dx <$$> ";" <+> dy + renderRecord value = render value + +instance HasTypeRef OCamlPrimitive where + renderRef (OList (OCamlPrimitive OChar)) = renderRef OString + renderRef (OList datatype) = do + dt <- renderRef datatype + return $ parens dt <+> "list" + renderRef (OTuple2 a b) = do + da <- renderRef a + db <- renderRef b + return . parens $ da <+> "*" <+> db + renderRef (OTuple3 a b c) = do + da <- renderRef a + db <- renderRef b + dc <- renderRef c + return . 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 + 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 + renderRef (OTuple6 a b c d e f) = do + da <- renderRef a + db <- renderRef b + dc <- renderRef c + 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" + +-- Util functions + +-- | A Haskell Sum of Records needs to be transformed into OCaml record types +-- and a sum type. Replace RecordConstructor with NamedConstructor. +replaceRecordConstructors :: [(Text,ValueConstructor)] -> ValueConstructor -> ValueConstructor +replaceRecordConstructors newConstructors recordConstructor@(RecordConstructor oldName _) = + case length newRecordConstructor > 0 of + False -> recordConstructor + True -> head newRecordConstructor + where + replace (oldName', (RecordConstructor newName _value)) = + if oldName == oldName' then (Just $ NamedConstructor oldName' (OCamlRef (HaskellTypeMetaData "" "" "") newName)) else Nothing + replace _ = Nothing + newRecordConstructor = catMaybes $ replace <$> newConstructors + +replaceRecordConstructors _ rc = rc + +-- | Given a constructor, output a list of type parameters. +-- (Maybe a) -> 'a0 list -> ["'a0"] +-- (Either a b) -> 'a0 'a1 list -> ["'a0","'a1"] +renderTypeParameters :: OCamlConstructor -> Doc +renderTypeParameters constructor = mkDocList $ stext . (<>) "'" <$> (nub $ getTypeParameters constructor) + +-- | For Haskell Sum of Records, create OCaml record types of each RecordConstructor +renderSumRecord :: Text -> ValueConstructor -> Reader TypeMetaData (Maybe (Doc,(Text,ValueConstructor))) +renderSumRecord typeName constructor@(RecordConstructor name value) = do + let sumRecordName = typeName <> name + functionBody <- render constructor + pure $ Just (("type" <+> (stext (textLowercaseFirst sumRecordName)) <+> "=" <$$> indent 2 functionBody), (name, (RecordConstructor sumRecordName value))) +renderSumRecord _ _ = return Nothing + +-- | Puts parentheses around the doc of an OCaml ref if it contains spaces. +ocamlRefParens :: OCamlPrimitive -> Doc -> Doc +ocamlRefParens (OList (OCamlPrimitive OChar)) = id +ocamlRefParens (OList _) = parens +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) diff --git a/src/OCaml/BuckleScript/Spec.hs b/src/OCaml/BuckleScript/Spec.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/BuckleScript/Spec.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module OCaml.BuckleScript.Spec + ( mkSampleServerAndGoldenSpec + , toOCamlSpec + , typeInFileToOCamlSpec + ) where + +-- base +import Data.Monoid +-- text +import Data.Text (Text) +import qualified Data.Text as T +-- ocaml-export +import OCaml.BuckleScript.Types hiding (getOCamlValues) +import OCaml.Internal.Common +-- wl-pprint +import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>), ()) + +mkSampleServerAndGoldenSpec :: OCamlDatatype -> Maybe Int -> [Text] -> Text -> Text -> Doc +mkSampleServerAndGoldenSpec (OCamlDatatype _ typeName constructors) mParameterRefCount modules url goldenDir = + indent 2 $ + "AesonSpec.sampleGoldenAndServerSpec" <$$> (indent 2 $ + decoders + <$$> encoders + <$$> (dquotes down) + <$$> (dquotes . stext $ ((url urlModul) typeName)) + <$$> (dquotes (stext $ goldenDir textUppercaseFirst typeName)) <> ";") + where + (tprDecoders, tprEncoders) = renderTypeParameterVals mParameterRefCount constructors + decoders = if tprDecoders == "" then (smodul <> "decode" <> up) else ("(" <> smodul <> "decode" <> up <+> (stext tprDecoders) <> ")") + encoders = if tprEncoders == "" then (smodul <> "encode" <> up) else ("(" <> smodul <> "encode" <> up <+> (stext tprEncoders) <> ")") + up = stext . textUppercaseFirst $ typeName + down = stext . textLowercaseFirst $ typeName + modul = T.intercalate "." (textUppercaseFirst <$> modules) :: Text + smodul = stext $ if modul /= "" then modul <> "." else "" + urlModul = T.intercalate "/" (textUppercaseFirst <$> modules) :: Text + +mkSampleServerAndGoldenSpec (OCamlPrimitive _) _ _mod _url _fp = "" + +renderTypeParameterVals :: Maybe Int -> OCamlConstructor -> (Text,Text) +renderTypeParameterVals (Just count) _ = renderTypeParameterValsAux count +renderTypeParameterVals _ (OCamlValueConstructor vc) = + renderTypeParameterValsAux . length . getTypeParameterRefNames . getOCamlValues $ vc +renderTypeParameterVals _ (OCamlSumOfRecordConstructor _ vc) = + renderTypeParameterValsAux . length . getTypeParameterRefNames . getOCamlValues $ vc +renderTypeParameterVals _ _ = ("","") + +renderTypeParameterValsAux :: Int -> (Text, Text) +renderTypeParameterValsAux size = + if size > 0 + then + ( T.intercalate " " $ mkDecoders <$> [0..(size-1)] + , T.intercalate " " $ mkEncoders <$> [0..(size-1)] + ) + else + ("","") + where +-- size = length $ getTypeParameterRefNames ocamlValues + mkDecoders _ = "AesonSpec.decodeIntWithResult" + mkEncoders _ = "Aeson.Encode.int" + -- body i = "(fun (x : Js_json.t) -> Aeson.Decode.wrapResult (Aeson.Decode.singleEnumerator Aeson.Helper.TypeParameterRef" <> (T.pack . show $ i) <> ") x)" + -- body2 i = "(fun _x -> Aeson.Encode.singleEnumerator Aeson.Helper.TypeParameterRef" <> (T.pack . show $ i) <> ")" + +getOCamlValues :: ValueConstructor -> [OCamlValue] +getOCamlValues (NamedConstructor _ value) = [value] +getOCamlValues (RecordConstructor _ value) = [value] +getOCamlValues (MultipleConstructors cs) = concat $ getOCamlValues <$> cs + +toOCamlSpec :: OCamlType a => a -> [Text] -> Text -> Text -> Text +toOCamlSpec a modules url fp = + pprinter $ mkSampleServerAndGoldenSpec (toOCamlType a) Nothing modules url fp + +-- | OCamlTypeInFile do not require an instance of OCamlType since they are +-- hand written OCaml files for Haskell types. Use typeable to get the +-- type name. +typeInFileToOCamlSpec :: Text -> Int -> [Text] -> Text -> Text -> Text +typeInFileToOCamlSpec aTyConName typeParameterRefCount modules url fp = + pprinter $ mkSampleServerAndGoldenSpec + (OCamlDatatype (HaskellTypeMetaData aTyConName "" "") + aTyConName $ OCamlValueConstructor $ NamedConstructor aTyConName $ OCamlEmpty) + (Just typeParameterRefCount) + modules + url + fp + +{- +toOCamlSpec2 :: Text -> [Text] -> Text -> Text -> Text +toOCamlSpec2 a modules url fp = + pprinter $ mkSampleServerAndGoldenSpec (OCamlDatatype (HaskellTypeMetaData a "" "") a $ OCamlValueConstructor $ NamedConstructor a $ OCamlEmpty) modules url fp +-} diff --git a/src/OCaml/BuckleScript/Types.hs b/src/OCaml/BuckleScript/Types.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/BuckleScript/Types.hs @@ -0,0 +1,551 @@ +{-| +Module : OCaml.BuckleScript.Types +Description : Tree representation of Haskell datatypes in OCaml +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +OCaml datatype representation of a Haskell datatype. A recursive tree that +can be interpreted to output OCaml code. It is meant to encode a Haskell type +into OCaml and make json seraliazers that match the output from Generic aeson +instances. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module OCaml.BuckleScript.Types + ( OCamlDatatype (..) + , OCamlPrimitive (..) + , OCamlConstructor (..) + , ValueConstructor (..) + , EnumeratorConstructor (..) + , OCamlValue (..) + , OCamlType (..) + , HaskellTypeMetaData (..) + , OCamlTypeMetaData (..) + + -- 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 + + -- functions for manipulating and querying the data type tree + , getTypeParameterRefNames + , getOCamlValues + , getTypeParameters + , isTypeParameterRef + , mkModulePrefix + ) where + +-- base +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List (nub) +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.Proxy +import Data.Time +import Data.Word (Word, Word8, Word16, Word32, Word64) +import GHC.Generics +import GHC.TypeLits (symbolVal, KnownSymbol) +import Prelude + +-- aeson +import Data.Aeson (ToJSON, FromJSON) + +-- text +import Data.Text (Text) +import qualified Data.Text as T + +-- QuickCheck +import Test.QuickCheck + +-- quicheck-arbitrary-adt +import Test.QuickCheck.Arbitrary.ADT + +-- | Top level of an OCaml datatype. A data type may be composed of +-- primitives and/or a combination of constructors and primitives. +-- OCamlDatatype is recursive via OCamlConstructor -> ValueConstructor +-- -> OCamlValue -> OCamlPrimitive -> OCamlDatatype. +data OCamlDatatype + = OCamlDatatype HaskellTypeMetaData Text OCamlConstructor -- ^ The name of a type and its type constructor + | OCamlPrimitive OCamlPrimitive -- ^ A primitive value + deriving (Show, Eq) + +-- | Store data about the Haskell origin of a type. +data HaskellTypeMetaData = + HaskellTypeMetaData + Text -- "TypeName" + Text -- "Module.Name" + Text -- "package-name" + deriving (Show, Eq, Ord) + +-- | Store data about the OCaml destination of a type. +data OCamlTypeMetaData = + OCamlTypeMetaData + Text -- "typeName" + [Text] -- ["File","Path"] + [Text] -- ["Sub","Module"] + deriving (Show, Eq, Ord) + +-- | Smallest unit of computation in OCaml. +data OCamlPrimitive + = OInt -- ^ int + | 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 + | OString -- ^ string + | OUnit -- ^ () + | OList OCamlDatatype -- ^ 'a list, 'a Js_array.t + | OOption OCamlDatatype -- ^ 'a option + | OEither OCamlDatatype OCamlDatatype -- ^ 'l 'r Aeson.Compatibility.Either.t + | OTuple2 OCamlDatatype OCamlDatatype -- ^ (*) + | OTuple3 OCamlDatatype OCamlDatatype OCamlDatatype -- ^ (**) + | OTuple4 OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype -- ^ (***) + | OTuple5 OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype -- ^ (****) + | OTuple6 OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype OCamlDatatype -- ^ (*****) + deriving (Show, Eq) + +-- | OCamlConstructor take values to create a new instances of a type. +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}` + deriving (Show, Eq) + +-- | OCamlConstructor of one RecordConstructor is a record type. +-- OCamlConstructor of one NamedConstructor that has one value is a Haskell newtype. +-- OCamlConstructor of one NamedConstructor is a product without field names. +-- OCamlConstructor of multiple NamedConstructors is a sum type. +-- OCamlConstructor of at least one RecordConstructor and any other amount of ValueConstructors greater than one is a OCamlSumWithRecordConstructor. +data ValueConstructor + = NamedConstructor Text OCamlValue -- ^ Product without named fields + | RecordConstructor Text OCamlValue -- ^ Product with named fields + | MultipleConstructors [ValueConstructor] -- ^ Sum type + deriving (Show, Eq) + +-- | Enumerators have no values, only tags. +data EnumeratorConstructor + = EnumeratorConstructor Text -- ^ Enumerator and its tag + deriving (Show, Eq) + +-- | Expected types of a constructor +data OCamlValue + = OCamlRef HaskellTypeMetaData Text -- ^ The name of a non-primitive data type + | 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 + deriving (Show, Eq) + +------------------------------------------------------------ +-- | Create an OCaml type from a Haskell type. Use the Generic +-- definition when possible. It also expects `ToJSON` and `FromJSON` +-- to be derived generically. +class OCamlType a where + toOCamlType :: a -> OCamlDatatype + toOCamlType = genericToOCamlDatatype . from + default toOCamlType :: (Generic a, GenericOCamlDatatype (Rep a)) => + a -> OCamlDatatype + +------------------------------------------------------------ +class GenericOCamlDatatype f where + genericToOCamlDatatype :: f a -> OCamlDatatype + +-- | Capture the Haskell type at the left side declaration `data Maybe a`, `data Person`, etc.. +-- Transform the constructor, depending on its values, if necessary. +instance (KnownSymbol typ, KnownSymbol package, KnownSymbol modul, GenericValueConstructor f) => GenericOCamlDatatype (M1 D ('MetaData typ modul package 'False) f) where + genericToOCamlDatatype datatype = + OCamlDatatype + (HaskellTypeMetaData + (T.pack $ symbolVal (Proxy :: Proxy typ)) + (T.pack $ symbolVal (Proxy :: Proxy modul)) + (T.pack $ symbolVal (Proxy :: Proxy package))) + (T.pack (datatypeName datatype)) + (transform (OCamlValueConstructor (genericToValueConstructor (unM1 datatype)))) + where + transform ocamlConstructor = + if isEnumeration ocamlConstructor + then transformToEnumeration ocamlConstructor + else + if isSumWithRecord ocamlConstructor + then transformToSumOfRecord (T.pack (datatypeName datatype)) ocamlConstructor + else ocamlConstructor + +instance (KnownSymbol typ, KnownSymbol package, KnownSymbol modul, GenericValueConstructor f) => GenericOCamlDatatype (M1 D ('MetaData typ modul package 'True) f) where + genericToOCamlDatatype datatype = + OCamlDatatype + (HaskellTypeMetaData + (T.pack $ symbolVal (Proxy :: Proxy typ)) + (T.pack $ symbolVal (Proxy :: Proxy modul)) + (T.pack $ symbolVal (Proxy :: Proxy package))) + (T.pack (datatypeName datatype)) + (transform (OCamlValueConstructor (genericToValueConstructor (unM1 datatype)))) + where + transform ocamlConstructor = + if isEnumeration ocamlConstructor + then transformToEnumeration ocamlConstructor + else + if isSumWithRecord ocamlConstructor + then transformToSumOfRecord (T.pack (datatypeName datatype)) ocamlConstructor + else ocamlConstructor + + + +------------------------------------------------------------ +class GenericValueConstructor f where + genericToValueConstructor :: f a -> ValueConstructor + +-- | Capture the Haskell type at the constructor. `Just` or `Nothing` from +-- `data Maybe a = Just a | Nothing`. +instance (Constructor c, GenericOCamlValue f) => GenericValueConstructor (C1 c f) where + genericToValueConstructor constructor = + if conIsRecord constructor + then RecordConstructor name (genericToOCamlValue (unM1 constructor)) + else NamedConstructor name (genericToOCamlValue (unM1 constructor)) + where + name = T.pack $ conName constructor + +-- | Capture the Haskell right side at the sum partition `|`. +instance (GenericValueConstructor f, GenericValueConstructor g) => + GenericValueConstructor (f :+: g) where + genericToValueConstructor _ = + MultipleConstructors + [ genericToValueConstructor (undefined :: f p) + , genericToValueConstructor (undefined :: g p) + ] + +------------------------------------------------------------ +class GenericOCamlValue f where + genericToOCamlValue :: f a -> OCamlValue + +-- | Capture the constructor field. +instance (Selector s, GenericOCamlValue a) => + GenericOCamlValue (S1 s a) where + genericToOCamlValue selector = + case selName selector of + "" -> genericToOCamlValue (undefined :: a p) + name -> OCamlField (T.pack name) (genericToOCamlValue (undefined :: a p)) + +-- | Capture the product comma. +instance (GenericOCamlValue f, GenericOCamlValue g) => + GenericOCamlValue (f :*: g) where + genericToOCamlValue _ = + Values + (genericToOCamlValue (undefined :: f p)) + (genericToOCamlValue (undefined :: g p)) + +-- | Enumerator, constructor with no values. +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 + +-- OCamlType instances for primitives + +instance OCamlType a => OCamlType [a] where + toOCamlType _ = OCamlPrimitive (OList (toOCamlType (Proxy :: Proxy a))) + +instance OCamlType a => OCamlType (Maybe a) where + toOCamlType _ = OCamlPrimitive (OOption (toOCamlType (Proxy :: Proxy a))) + +instance (OCamlType l, OCamlType r) => OCamlType (Either l r) where + toOCamlType _ = OCamlPrimitive (OEither (toOCamlType (Proxy :: Proxy l)) (toOCamlType (Proxy :: Proxy r))) + +instance OCamlType () where + toOCamlType _ = OCamlPrimitive OUnit + +instance OCamlType Text where + toOCamlType _ = OCamlPrimitive OString + +instance OCamlType Day where + toOCamlType _ = OCamlPrimitive ODate + +instance OCamlType UTCTime where + toOCamlType _ = OCamlPrimitive ODate + +instance OCamlType Float where + toOCamlType _ = OCamlPrimitive OFloat + +instance OCamlType Double where + toOCamlType _ = OCamlPrimitive OFloat + +instance OCamlType Int8 where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Int16 where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Int32 where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Int64 where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Word where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Word8 where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Word16 where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Word32 where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Word64 where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Int where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Integer where + toOCamlType _ = OCamlPrimitive OInt + +instance OCamlType Char where + toOCamlType _ = OCamlPrimitive OChar + +instance OCamlType Bool where + toOCamlType _ = OCamlPrimitive OBool + +instance (OCamlType a, OCamlType b) => OCamlType (a, b) where + toOCamlType _ = + OCamlPrimitive $ + OTuple2 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b)) + +instance (OCamlType a, OCamlType b, OCamlType c) => OCamlType (a, b, c) where + toOCamlType _ = + OCamlPrimitive $ + OTuple3 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b)) + (toOCamlType (Proxy :: Proxy c)) + +instance (OCamlType a, OCamlType b, OCamlType c, OCamlType d) => OCamlType (a, b, c, d) where + toOCamlType _ = + OCamlPrimitive $ + OTuple4 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b)) + (toOCamlType (Proxy :: Proxy c)) (toOCamlType (Proxy :: Proxy d)) + +instance (OCamlType a, OCamlType b, OCamlType c, OCamlType d, OCamlType e) => OCamlType (a, b, c, d, e) where + toOCamlType _ = + OCamlPrimitive $ + OTuple5 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b)) + (toOCamlType (Proxy :: Proxy c)) (toOCamlType (Proxy :: Proxy d)) + (toOCamlType (Proxy :: Proxy e)) + +instance (OCamlType a, OCamlType b, OCamlType c, OCamlType d, OCamlType e, OCamlType f) => OCamlType (a, b, c, d, e, f) where + toOCamlType _ = + OCamlPrimitive $ + OTuple6 (toOCamlType (Proxy :: Proxy a)) (toOCamlType (Proxy :: Proxy b)) + (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) + +{- +-- 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 +-- Value, Dual, First, Last, IntMap, Tree, Seq, Vector, HashSet, Proxy +-- Const Tagged, Dual, First, Last, tuple up to length of 15 +-} + + +-- | Used to fill the type parameters of proxy types. `Proxy :: Proxy (Maybe TypeParameterRef0)`, `Proxy :: Proxy Either TypeParameterRef0 TypeParameterRef1`. JSON representation is as an Int to simplify the automated tests. +newtype TypeParameterRef0 = TypeParameterRef0 Int deriving (Read, Show, Eq, Generic) +instance Arbitrary TypeParameterRef0 where arbitrary = TypeParameterRef0 <$> arbitrary +instance ToADTArbitrary TypeParameterRef0 +instance FromJSON TypeParameterRef0 +instance ToJSON TypeParameterRef0 +instance OCamlType TypeParameterRef0 where + toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a0" "OCaml.BuckleScript.Types" "ocaml-export") "a0" $ OCamlValueConstructor $ NamedConstructor "a0" $ OCamlTypeParameterRef "a0" + +-- | Second unique TypeParameterRef. +newtype TypeParameterRef1 = TypeParameterRef1 Int deriving (Read, Show, Eq, Generic) +instance Arbitrary TypeParameterRef1 where arbitrary = TypeParameterRef1 <$> arbitrary +instance ToADTArbitrary TypeParameterRef1 +instance FromJSON TypeParameterRef1 +instance ToJSON TypeParameterRef1 +instance OCamlType TypeParameterRef1 where + toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a1" "OCaml.BuckleScript.Types" "ocaml-export") "a1" $ OCamlValueConstructor $ NamedConstructor "a1" $ OCamlTypeParameterRef "a1" + +-- | Third unique TypeParameterRef. +data TypeParameterRef2 = TypeParameterRef2 Int deriving (Read, Show, Eq, Generic) +instance Arbitrary TypeParameterRef2 where arbitrary = TypeParameterRef2 <$> arbitrary +instance ToADTArbitrary TypeParameterRef2 +instance FromJSON TypeParameterRef2 +instance ToJSON TypeParameterRef2 +instance OCamlType TypeParameterRef2 where + toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a2" "OCaml.BuckleScript.Types" "ocaml-export") "a2" $ OCamlValueConstructor $ NamedConstructor "a2" $ OCamlTypeParameterRef "a2" + +-- | Fourth unique TypeParameterRef. +data TypeParameterRef3 = TypeParameterRef3 Int deriving (Read, Show, Eq, Generic) +instance Arbitrary TypeParameterRef3 where arbitrary = TypeParameterRef3 <$> arbitrary +instance ToADTArbitrary TypeParameterRef3 +instance FromJSON TypeParameterRef3 +instance ToJSON TypeParameterRef3 +instance OCamlType TypeParameterRef3 where + toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a3" "OCaml.BuckleScript.Types" "ocaml-export") "a3" $ OCamlValueConstructor $ NamedConstructor "a3" $ OCamlTypeParameterRef "a3" + +-- | Fifth unique TypeParameterRef. +data TypeParameterRef4 = TypeParameterRef4 Int deriving (Read, Show, Eq, Generic) +instance Arbitrary TypeParameterRef4 where arbitrary = TypeParameterRef4 <$> arbitrary +instance ToADTArbitrary TypeParameterRef4 +instance FromJSON TypeParameterRef4 +instance ToJSON TypeParameterRef4 +instance OCamlType TypeParameterRef4 where + toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a4" "OCaml.BuckleScript.Types" "ocaml-export") "a4" $ OCamlValueConstructor $ NamedConstructor "a4" $ OCamlTypeParameterRef "a4" + +-- | Sixth unique TypeParameterRef. +data TypeParameterRef5 = TypeParameterRef5 Int deriving (Read, Show, Eq, Generic) +instance Arbitrary TypeParameterRef5 where arbitrary = TypeParameterRef5 <$> arbitrary +instance ToADTArbitrary TypeParameterRef5 +instance FromJSON TypeParameterRef5 +instance ToJSON TypeParameterRef5 +instance OCamlType TypeParameterRef5 where + toOCamlType _ = OCamlDatatype (HaskellTypeMetaData "a5" "OCaml.BuckleScript.Types" "ocaml-export") "a5" $ OCamlValueConstructor $ NamedConstructor "a5" $ OCamlTypeParameterRef "a5" + +-- Utility functions + +-- | Whether a set of constructors is an enumeration, i.e. whether they lack +-- values. data A = A | B | C would be simple data A = A Int | B | C would not +-- be simple. +isEnumeration :: OCamlConstructor -> Bool +isEnumeration (OCamlValueConstructor (NamedConstructor _ OCamlEmpty)) = True +isEnumeration (OCamlValueConstructor (MultipleConstructors cs)) = all isEnumeration (OCamlValueConstructor <$> cs) +isEnumeration _ = False + + +-- | Tranform an OCamlConstructor to EnumeratorConstructors +transformToEnumeration :: OCamlConstructor -> OCamlConstructor +transformToEnumeration (OCamlValueConstructor (NamedConstructor name OCamlEmpty)) = + OCamlEnumeratorConstructor [EnumeratorConstructor name] + +transformToEnumeration (OCamlValueConstructor (MultipleConstructors cs)) = + -- wrap cs in OCamlValueConstructor so the type matches + -- getEnumeratorConstructor to make sure it only returns OCamlEnumeratorConstructor + -- then concat the results and rewrap it in OCamlEnumeratorConstructor + OCamlEnumeratorConstructor . concat . catMaybes + $ getEnumeratorConstructor . transformToEnumeration . OCamlValueConstructor + <$> cs + where + getEnumeratorConstructor constructor = + case constructor of + (OCamlEnumeratorConstructor c) -> Just c + _ -> Nothing + +transformToEnumeration cs = cs + +-- | transform a OCamlConstructor to OCamlSumOfRecordConstructor +transformToSumOfRecord :: Text -> OCamlConstructor -> OCamlConstructor +transformToSumOfRecord typeName (OCamlValueConstructor value@(MultipleConstructors _cs)) = OCamlSumOfRecordConstructor typeName value +transformToSumOfRecord _ constructor = constructor + + +-- | Haskell allows you to directly declare a sum of records, +-- i.e. data A = A {a :: Int} | B {b :: String}. This does not exist in +-- OCaml so we have to work around it. + +isSumWithRecord :: OCamlConstructor -> Bool +isSumWithRecord (OCamlValueConstructor (MultipleConstructors cs)) = + -- if there is only one constructor than it is not a SumWithRecords. + -- if there are multiple constructors and at least one is a record constructor + -- than it is a SumWithRecords + (\x -> length x > 1 && or x) $ isSumWithRecordsAux . OCamlValueConstructor <$> cs + where + isSumWithRecordsAux :: OCamlConstructor -> Bool + isSumWithRecordsAux (OCamlValueConstructor (RecordConstructor _ _)) = True + isSumWithRecordsAux _ = False +isSumWithRecord _ = False + +-- | Convert OCamlValues to the type parameter names of a data type. +-- `Either a0 a1` -> `["a0","a1"]` +getTypeParameterRefNames :: [OCamlValue] -> [Text] +getTypeParameterRefNames = nub . concat . (fmap match) + where + lift (OCamlDatatype _ _ constructor) = getTypeParameters constructor + lift _ = [] + + match value = + case value of + (OCamlTypeParameterRef name) -> [name] + (Values v1 v2) -> match v1 ++ match v2 + (OCamlField _ v1) -> match v1 + (OCamlPrimitiveRef (OList v1)) -> lift v1 + (OCamlPrimitiveRef (OOption v1)) -> lift v1 + (OCamlPrimitiveRef (OTuple2 v1 v2)) -> lift v1 ++ lift v2 + (OCamlPrimitiveRef (OTuple3 v1 v2 v3)) -> lift v1 ++ lift v2 ++ lift v3 + (OCamlPrimitiveRef (OTuple4 v1 v2 v3 v4)) -> lift v1 ++ lift v2 ++ lift v3 ++ lift v4 + (OCamlPrimitiveRef (OTuple5 v1 v2 v3 v4 v5)) -> lift v1 ++ lift v2 ++ lift v3 ++ lift v4 ++ lift v5 + (OCamlPrimitiveRef (OTuple6 v1 v2 v3 v4 v5 v6)) -> lift v1 ++ lift v2 ++ lift v3 ++ lift v4 ++ lift v5 ++ lift v6 + _ -> [] + +-- | getOCamlValues flatten the values from MultipleConstructors into a list and remove ValueConstructor. +getOCamlValues :: ValueConstructor -> [OCamlValue] +getOCamlValues (NamedConstructor _ value) = [value] +getOCamlValues (RecordConstructor _ value) = [value] +getOCamlValues (MultipleConstructors cs) = concat $ getOCamlValues <$> cs + +-- | getTypePar +getTypeParameters :: OCamlConstructor -> [Text] +getTypeParameters (OCamlValueConstructor vc) = getTypeParameterRefNames . getOCamlValues $ vc +getTypeParameters (OCamlSumOfRecordConstructor _ vc) = getTypeParameterRefNames . getOCamlValues $ vc +getTypeParameters _ = [] + +-- | Matches all of the TypeParameterRefs (TypeParameterRef0 to TypeParameterRef5). +-- This function is needed to work around the tree structure for special rules for rendering type parameters. +isTypeParameterRef :: OCamlDatatype -> Bool +isTypeParameterRef (OCamlDatatype _ _ (OCamlValueConstructor (NamedConstructor _ (OCamlTypeParameterRef _)))) = True +isTypeParameterRef _ = False + +-- | 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) = + if prefix /= "" then prefix <> "." else "" + where + (l,r) = zipWithRightRemainder (decModules <> decSubModules) (parModules <> parSubModules) + prefix = T.intercalate "." $ (removeMatchingHead l) <> r + +-- | Iterate through the beginning of a list, remove values as long as they are equal. +-- When one inequality is found, return the value and its tail. +removeMatchingHead :: Eq a => [(a,a)] -> [a] +removeMatchingHead [] = [] +removeMatchingHead (hd:tl) = + if fst hd == snd hd + then removeMatchingHead tl + else [snd hd] <> (snd <$> tl) + +-- | Zip two lists. If the right hand side is longer, then return the remaining right side. +zipWithRightRemainder :: [a] -> [b] -> ([(a,b)], [b]) +zipWithRightRemainder [] bs = ([], bs) +zipWithRightRemainder _ab [] = ([], []) +zipWithRightRemainder (a:as) (b:bs) = ([(a,b)], []) <> zipWithRightRemainder as bs diff --git a/src/OCaml/Export.hs b/src/OCaml/Export.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/Export.hs @@ -0,0 +1,62 @@ +{-| +Module : OCaml.Export +Description : Export everything from one module +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +-} + +module OCaml.Export + ( OCamlPackage + , NoDependency + , OCamlModule + , OCamlSubModule + , OCamlTypeInFile + + , PackageOptions (..) + , defaultPackageOptions + , SpecOptions (..) + , defaultSpecOptions + + , EmbeddedOCamlFiles (..) + + , mkPackage + , mkFiles + , mkOCamlTypeMetaData + + -- OCaml.BuckleScript.Types + , OCamlType (..) + , TypeParameterRef0 + , TypeParameterRef1 + , TypeParameterRef2 + , TypeParameterRef3 + , TypeParameterRef4 + , TypeParameterRef5 + + -- servant spec + , mkOCamlSpecServer + , MkOCamlSpecAPI + , mkGoldenFiles + + -- re-export + , Proxy (..) + , (:>) + , (:<|>) (..) + , Application + , Server + , serve + + ) where + +import Data.Proxy (Proxy (..)) + +import OCaml.BuckleScript.Types + +import OCaml.BuckleScript.Internal.Module +import OCaml.BuckleScript.Internal.Package +import OCaml.BuckleScript.Internal.Spec + +import Servant (Application, Server, serve) +import Servant.API ((:>), (:<|>) (..)) diff --git a/src/OCaml/File.hs b/src/OCaml/File.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/File.hs @@ -0,0 +1,89 @@ +{-| +Module : OCaml.File +Description : Create OCaml files +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module OCaml.File where + +-- base +import Data.ByteString (ByteString) +import Data.Monoid + +-- directory +import System.Directory + +-- text +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T + +-- file-embed +import Data.FileEmbed (embedFile) + + +bsConfigFile :: ByteString +bsConfigFile = $(embedFile "bs-src/bsconfig.json") + +packageFile :: ByteString +packageFile = $(embedFile "bs-src/package.json") + +webpackConfigFile :: ByteString +webpackConfigFile = $(embedFile "bs-src/webpack.config.js") + +data OCamlFile = + OCamlFile + { ocamlFilePath :: FilePath + , ocamlDeclarations :: [Text] + } + +data OCamlInterface = + OCamlInterface + { declars :: [Text] + , inters :: [Text] + , specs :: [Text] + } + +instance Monoid OCamlInterface where + mappend a b = OCamlInterface (declars a <> declars b) (inters a <> inters b) (specs a <> specs b) + mempty = OCamlInterface [] [] [] + +createOCamlFile :: FilePath -> OCamlFile -> IO () +createOCamlFile rootDir ocamlFile = do + createDirectoryIfMissing True rootDir + let file = rootDir <> "/" <> ocamlFilePath ocamlFile <> ".ml" + body = T.intercalate "\n\n" (ocamlDeclarations ocamlFile) <> "\n" + T.writeFile file body + +createOCamlFiles :: FilePath -> [OCamlFile] -> IO () +createOCamlFiles root files = mapM_ (createOCamlFile root) files + +createOCamlFileWithInterface :: FilePath -> FilePath -> FilePath -> OCamlInterface -> IO () +createOCamlFileWithInterface rootDir specRootDir fileName ocamlInterface = do + createDirectoryIfMissing True rootDir + createDirectoryIfMissing True specRootDir + let fp = rootDir <> "/" <> fileName + body = T.intercalate "\n\n" (declars ocamlInterface) <> "\n" + interfaceBody = T.intercalate "\n\n" (inters ocamlInterface) <> "\n" + T.writeFile (fp <> ".ml") body + T.writeFile (fp <> ".mli") interfaceBody + if (length $ specs ocamlInterface) > 0 + then do + let specfp = specRootDir <> "/" <> fileName + specBody = "let () =\n" <> (T.intercalate "\n\n" (specs ocamlInterface) <> "\n") + T.writeFile (specfp <> "_spec.ml") specBody + else pure () + +createOCamlSpecFile :: FilePath -> FilePath -> Text -> IO () +createOCamlSpecFile rootDir fileName ocamlSpec = do + createDirectoryIfMissing True rootDir + let fp = rootDir <> "/" <> fileName + body = "let () =\n" <> ocamlSpec + T.writeFile (fp <> "_spec.ml") body diff --git a/src/OCaml/Internal/Common.hs b/src/OCaml/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/src/OCaml/Internal/Common.hs @@ -0,0 +1,162 @@ +{-| +Module : OCaml.Internal.Common +Description : Internal utility functions +Copyright : Plow Technologies, 2017 +License : BSD3 +Maintainer : mchaver@gmail.com +Stability : experimental + +-} + + +{-# LANGUAGE OverloadedStrings #-} + +module OCaml.Internal.Common where + +-- base +import Data.Char (toLower,toUpper) +import qualified Data.List as L +import Data.Monoid + +-- aeson +import qualified Data.Aeson.Types as Aeson (Options(..), defaultOptions) + +-- containers +import qualified Data.Map.Strict as Map + +-- formatting +import Formatting hiding (stext, text) + +-- ocaml-export +import OCaml.BuckleScript.Types (HaskellTypeMetaData, OCamlTypeMetaData) + +-- text +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT + +-- wl-pprint +import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>)) + + +-- | For URLs and POSIX systems. +() :: Text -> Text -> Text +() a b = + if hasEndingSeparator sA + then + if hasLeadingSeparator sB + then T.pack $ sA ++ drop 1 sB + else T.pack $ sA ++ sB + else + T.pack $ sA ++ "/" ++ sB + where + sA = T.unpack a + sB = T.unpack b + + hasEndingSeparator :: String -> Bool + hasEndingSeparator lst@(_hd:_tl) = (==) '/' . last $ lst + hasEndingSeparator [] = False + + hasLeadingSeparator :: String -> Bool + hasLeadingSeparator (hd:_tl) = hd == '/' + hasLeadingSeparator [] = False + +infix 5 + + +data Options = Options + { includeOCamlInterface :: Bool + , aesonOptions :: Aeson.Options + , dependencies :: Map.Map HaskellTypeMetaData OCamlTypeMetaData + } + +defaultOptions :: Options +defaultOptions = Options {includeOCamlInterface = False, aesonOptions = Aeson.defaultOptions, dependencies = Map.empty} + +data TypeMetaData = TypeMetaData + { topLevelOCamlTypeMetaData :: Maybe OCamlTypeMetaData -- Just if not primitive + , userOptions :: Options + } + +cr :: Format r r +cr = now "\n" + +mintercalate :: Monoid m => m -> [m] -> m +mintercalate _ [] = mempty +mintercalate _ [x] = x +mintercalate separator (x:xs) = x <> separator <> mintercalate separator xs + +msuffix :: Monoid m => m -> [m] -> m +msuffix _ [] = mempty +msuffix suffix [x] = x <> suffix +msuffix suffix (x:xs) = x <> suffix <> msuffix suffix xs + +mconcatWith :: Monoid m => m -> m -> [m] -> m +mconcatWith _ _ [] = mempty +mconcatWith pre suf [x] = pre <> x <> suf +mconcatWith pre suf (x:xs) = pre <> x <> suf <> mconcatWith pre suf xs + +mintercalatefinish :: Monoid m => m -> m -> [m] -> m +mintercalatefinish _ _ [] = mempty +mintercalatefinish _ f [x] = x <> f +mintercalatefinish separator f (x:xs) = x <> separator <> (mintercalatefinish separator f xs) + +pprinter :: Doc -> Text +pprinter = LT.toStrict . displayT . renderPretty 0.4 100 + +stext :: Data.Text.Text -> Doc +stext = text . LT.fromStrict + +spaceparens :: Doc -> Doc +spaceparens doc = "(" <+> doc <+> ")" + + +-- | Parentheses of which the right parenthesis exists on a new line +newlineparens :: Doc -> Doc +newlineparens doc = "(" <> doc <$$> ")" + +-- | An empty line, regardless of current indentation +emptyline :: Doc +emptyline = nest minBound linebreak + +-- | Like <$$>, but with an empty line in between +(<$+$>) :: Doc -> Doc -> Doc +l <$+$> r = l <> emptyline <$$> r + +linesBetween :: [Doc] -> Doc +linesBetween docs = + let extra = if length docs > 0 then line else "" + in foldl (<>) "" $ (L.intersperse (line <> line) docs) <> [extra] + +squarebracks :: Doc -> Doc +squarebracks doc = "[" <+> doc <+> "]" + +arraybrackets :: Doc -> Doc +arraybrackets doc = "[|" <+> doc <+> "|]" + +pair :: Doc -> Doc -> Doc +pair l r = spaceparens $ l <> comma <+> r + +lowercaseFirst :: String -> String +lowercaseFirst (hd:tl) = toLower hd : tl +lowercaseFirst [] = [] + +uppercaseFirst :: String -> String +uppercaseFirst (hd:tl) = toUpper hd : tl +uppercaseFirst [] = [] + +textLowercaseFirst :: Text -> Text +textLowercaseFirst = T.pack . lowercaseFirst . T.unpack + +textUppercaseFirst :: Text -> Text +textUppercaseFirst = T.pack . uppercaseFirst . T.unpack + +mkDocList :: [Doc] -> Doc +mkDocList ds = + foldl (<>) "" $ + if length ds > 1 + then ["("] <> (L.intersperse ", " ds) <> [")"] + else ds + +foldMod :: [Text] -> Text +foldMod = T.intercalate "." diff --git a/test/Dependency.hs b/test/Dependency.hs new file mode 100644 --- /dev/null +++ b/test/Dependency.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Dependency where + +-- base +import Data.Monoid ((<>)) +import GHC.Generics (Generic) + +-- aeson +import Data.Aeson (FromJSON, ToJSON) + +-- containers +import Data.Map as Map + +-- hspec +import Test.Hspec + +-- hspec-aeson-golden +import Test.Aeson.Internal.ADT.GoldenSpecs + +-- QuickCheck +import Test.QuickCheck + +-- quickcheck-arbitrary-adt +import Test.QuickCheck.Arbitrary.ADT + +-- text +import Data.Text (Text) + +-- time +import Data.Time +import Data.Time.Clock.POSIX + +-- ocaml-export +import OCaml.Export +import Product (ProductPackage, Person) +import Util + +--mkGolden :: forall a. (ToADTArbitrary a, ToJSON a) => Proxy a -> IO () +--mkGolden Proxy = mkGoldenFileForType 10 (Proxy :: Proxy a) "test/interface/golden/golden/dependency" + +--mkGoldenFiles :: IO () +--mkGoldenFiles = do +-- mkGolden (Proxy :: Proxy Class) + +type DependencyPackage + = OCamlPackage "dependency" '[ProductPackage] :> ( + OCamlModule '["Class"] :> Class) + +type DependencyPackageWithoutProduct + = OCamlPackage "dependency" NoDependency :> ( + OCamlModule '["Class"] :> Class) + +type SchoolPackage + = OCamlPackage "school" '[DependencyPackage] :> ( + OCamlModule '["School"] :> School) +{- +data Person = Person + { id :: Int + , name :: Maybe String + } deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance Arbitrary Person where + arbitrary = Person <$> arbitrary <*> arbitrary + +instance ToADTArbitrary Person +-} +data Class = Class + { subject :: String + , students :: [Person] -- from another package + , professor :: Person + } deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance Arbitrary Class where + arbitrary = do + k <- choose (1,3) + v <- vector k + Class <$> arbitrary <*> pure v <*> arbitrary + +instance ToADTArbitrary Class + +data School = School + { schoolName :: String + , classes :: [Class] + , administrator :: Person + } deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance Arbitrary School where + arbitrary = do + k <- choose (1,3) + v <- vector k + School <$> arbitrary <*> pure v <*> arbitrary + +instance ToADTArbitrary School + +data A = + A Int + deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance ToADTArbitrary A +instance Arbitrary A where + arbitrary = A <$> arbitrary + +data B = + B String Int + deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance ToADTArbitrary B +instance Arbitrary B where + arbitrary = B <$> arbitrary <*> arbitrary + +data C = + C (Int,Int) + deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance ToADTArbitrary C +instance Arbitrary C where + arbitrary = C <$> arbitrary + +data D = + D String C + deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance ToADTArbitrary D +instance Arbitrary D where + arbitrary = D <$> arbitrary <*> arbitrary + +data E = + E Double + deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance ToADTArbitrary E +instance Arbitrary E where + arbitrary = E <$> arbitrary + +type SubsPackage = OCamlPackage "subs" NoDependency :> + (OCamlModule '["AtoE"] :> A :> (OCamlSubModule "One" :> B :> (OCamlSubModule "Two" :> C) :> D) :> E) +-- (OCamlModule '["AtoE"] :> OCamlSubModule '["One"] :> A) + +spec :: Spec +spec = do + runIO $ mkGoldenFiles (Proxy :: Proxy DependencyPackage) 10 "test/interface/golden/golden/dependency" + runIO $ mkGoldenFiles (Proxy :: Proxy SubsPackage) 10 "test/interface/golden/golden/subs" + runIO $ mkGoldenFiles (Proxy :: Proxy SchoolPackage) 10 "test/interface/golden/golden/school" + let dir = "test/interface/temp" + runIO $ mkPackage (Proxy :: Proxy DependencyPackage) (PackageOptions dir "dependency" Map.empty True Nothing) + runIO $ mkPackage (Proxy :: Proxy SubsPackage) (PackageOptions dir "subs" Map.empty True Nothing) + runIO $ mkPackage (Proxy :: Proxy SchoolPackage) (PackageOptions dir "school" Map.empty True Nothing) + + return () diff --git a/test/File.hs b/test/File.hs new file mode 100644 --- /dev/null +++ b/test/File.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module File where + +-- base +import Data.Proxy +import GHC.Generics (Generic) + +-- aeson +import Data.Aeson + +-- hspec +import Test.Hspec + +-- hspec-golden-aeson +import Test.Aeson.Internal.ADT.GoldenSpecs + +-- QuickCheck +import Test.QuickCheck + +-- quickcheck-arbitrary-adt +import Test.QuickCheck.Arbitrary.ADT + +-- ocaml-export +import OCaml.Export + +type FilePackage = OCamlPackage "" NoDependency :> + (OCamlModule '["File"] + :> OCamlTypeInFile Person "test/ocaml/Person" + :> Automobile + :> OCamlTypeInFile Business "test/ocaml/Business" + :> OCamlTypeInFile (Wrapper TypeParameterRef0 TypeParameterRef1) "test/ocaml/Wrapper" + ) + +data Person = Person + { id :: Int + , name :: Maybe String + } deriving (Show, Eq, Generic, FromJSON, ToJSON) + +instance Arbitrary Person where + arbitrary = Person <$> arbitrary <*> arbitrary + +instance ToADTArbitrary Person + + +data Automobile = Automobile + { make :: String + , model :: String + , year :: Int + } deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance Arbitrary Automobile where + arbitrary = Automobile <$> arbitrary <*> arbitrary <*> arbitrary + +instance ToADTArbitrary Automobile + + +data Business = Business + { taxId :: String + , owner :: Person + , employees :: [Person] + , companyVehicle :: Maybe Automobile + } deriving (Show, Eq, Generic, FromJSON, ToJSON) + +instance Arbitrary Business where + arbitrary = do + employeeCount <- choose (0,3) + Business <$> arbitrary <*> arbitrary <*> vector employeeCount <*> arbitrary + +instance ToADTArbitrary Business + +data Wrapper a b = Wrapper + { wrapperA :: a + , wrapperB :: b + , wrapperC :: String + } deriving (Show, Eq, Generic, FromJSON, ToJSON) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Wrapper a b) where + arbitrary = Wrapper <$> arbitrary <*> arbitrary <*> arbitrary + +instance (ToADTArbitrary a, ToADTArbitrary b) => ToADTArbitrary (Wrapper a b) diff --git a/test/FileApp.hs b/test/FileApp.hs new file mode 100644 --- /dev/null +++ b/test/FileApp.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds #-} + +{-# LANGUAGE TemplateHaskell #-} + +module FileApp where + +-- containers +import qualified Data.Map as Map + +-- hspec +import Test.Hspec + +-- servant-server +import Servant + +-- ocaml-export +import OCaml.Export +import File +import Util + +$(mkOCamlSpecServer "FilePackage" (Proxy :: Proxy FilePackage)) + +fileMap :: Map.Map String EmbeddedOCamlFiles +fileMap = Map.fromList $(mkFiles True False (Proxy :: Proxy FilePackage)) + +compareInterfaceFiles = compareFiles "test/interface" "file" True + +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 + compareInterfaceFiles "File" diff --git a/test/Options.hs b/test/Options.hs new file mode 100644 --- /dev/null +++ b/test/Options.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Options where + +{- +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson.Types hiding (Options) +import Data.Char (toUpper,toLower) +import Data.Monoid ((<>)) +import Data.Proxy +import Data.Text (Text) +import Data.Time +import Data.Time.Clock.POSIX +import GHC.Generics +import OCaml.Export hiding (Options,defaultOptions) +import qualified OCaml.Export as OCaml (Options,defaultOptions) +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.ADT +import Test.Aeson.Internal.ADT.GoldenSpecs +import Util + + +testOptionsInterface = testOCamlTypeWithInterface Options + +mkTestOCaml :: OCamlType a => Text -> a -> OCamlInterface +mkTestOCaml modul = mkOCamlInterfaceWithSpec "http://localhost:8081" "__tests__/golden/" modul + +fieldUpperOptions = defaultOptions { fieldLabelModifier = map toUpper } + +constructorLowerOptions = defaultOptions { constructorTagModifier = map toLower } + +oo = OCaml.defaultOptions {aesonOptions = fieldUpperOptions } +ii = OCaml.defaultOptions {aesonOptions = constructorLowerOptions } + +spec :: Spec +spec = do + describe "OCaml Declaration with Interface: Types with Aeson Options" $ do + testOptionsInterface "Person" (mkOCamlInterfaceWithOptions oo (Proxy :: Proxy Person)) + testOptionsInterface "NameOrIdNumber" (mkOCamlInterfaceWithOptions ii (Proxy :: Proxy NameOrIdNumber)) + +data Person = Person + { id :: Int + , name :: Maybe String + , created :: UTCTime + } deriving (Show, Eq, Generic, OCamlType) + +instance Arbitrary Person where + arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary + +instance ToADTArbitrary Person + +instance ToJSON Person where + toJSON = genericToJSON fieldUpperOptions + +instance FromJSON Person where + parseJSON = genericParseJSON fieldUpperOptions + +data NameOrIdNumber = Name String | IdNumber Int + deriving (Show, Eq, Generic, OCamlType) + +instance ToJSON NameOrIdNumber where + toJSON = genericToJSON constructorLowerOptions + +instance FromJSON NameOrIdNumber where + parseJSON = genericParseJSON constructorLowerOptions +-} diff --git a/test/Product.hs b/test/Product.hs new file mode 100644 --- /dev/null +++ b/test/Product.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# LANGUAGE FlexibleInstances #-} + + +-- for OCaml Module +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE TemplateHaskell #-} + + +module Product where + +-- base +import Data.Monoid ((<>)) +import GHC.Generics +-- text +import Data.Text (Text) +-- time +import Data.Time +import Data.Time.Clock.POSIX +-- containers +import qualified Data.Map as Map + +-- aeson +import Data.Aeson (FromJSON, ToJSON) + +-- hspec +import Test.Hspec +-- QuickCheck +import Test.QuickCheck +-- quickcheck-arbitrary-adt +import Test.QuickCheck.Arbitrary.ADT +-- hspec-golden-aeson +import Test.Aeson.Internal.ADT.GoldenSpecs +-- ocaml-export +import OCaml.Export hiding (mkGoldenFiles) +import Util + +type ProductPackage + = OCamlPackage "product" NoDependency + :> (OCamlModule '["SimpleChoice"] :> SimpleChoice + :<|> OCamlModule '["Person"] :> Person + :<|> OCamlModule '["Company"] :> Company + :<|> OCamlModule '["Card"] :> Suit :> Card + :<|> OCamlModule '["CustomOption"] :> Company2 + :<|> OCamlModule '["OneTypeParameter"] :> OneTypeParameter TypeParameterRef0 + :<|> OCamlModule '["TwoTypeParameters"] :> TwoTypeParameters TypeParameterRef0 TypeParameterRef1 + :<|> OCamlModule '["ThreeTypeParameters"] :> Three TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 + :<|> OCamlModule '["SubTypeParameter"] :> SubTypeParameter TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) + +mkGolden :: forall a. (ToADTArbitrary a, ToJSON a) => Proxy a -> IO () +mkGolden Proxy = mkGoldenFileForType 10 (Proxy :: Proxy a) "test/interface/golden/golden/product" + +mkGoldenFiles :: IO () +mkGoldenFiles = do + mkGolden (Proxy :: Proxy SimpleChoice) + mkGolden (Proxy :: Proxy Person) + mkGolden (Proxy :: Proxy Company) + mkGolden (Proxy :: Proxy Suit) + mkGolden (Proxy :: Proxy Card) + mkGolden (Proxy :: Proxy Company2) + mkGolden (Proxy :: Proxy (OneTypeParameter TypeParameterRef0)) + mkGolden (Proxy :: Proxy (TwoTypeParameters TypeParameterRef0 TypeParameterRef1)) + mkGolden (Proxy :: Proxy (Three TypeParameterRef0 TypeParameterRef1 TypeParameterRef2)) + mkGolden (Proxy :: Proxy (SubTypeParameter TypeParameterRef0 TypeParameterRef1 TypeParameterRef2)) + +compareInterfaceFiles = compareFiles "test/interface" "product" True + +compareNoInterfaceFiles = compareFiles "test/nointerface" "product" False + + +spec :: Spec +spec = do + runIO $ mkGoldenFiles + + let dir = "test/interface/temp" + runIO $ mkPackage (Proxy :: Proxy ProductPackage) (PackageOptions dir "product" Map.empty True $ Just $ SpecOptions "__tests__/product" "golden/product" "http://localhost:8081") + + describe "OCaml Declaration with Interface: Product Types" $ do + compareInterfaceFiles "Person" + compareInterfaceFiles "Company" + compareInterfaceFiles "Card" + compareInterfaceFiles "OneTypeParameter" + compareInterfaceFiles "TwoTypeParameters" + compareInterfaceFiles "ThreeTypeParameters" + compareInterfaceFiles "SubTypeParameter" + + let dir2 = "test/nointerface/temp" + runIO $ mkPackage (Proxy :: Proxy ProductPackage) (PackageOptions dir2 "product" Map.empty False Nothing) + + describe "OCaml Declaration without Interface: Product Types" $ do + compareNoInterfaceFiles "Person" + compareNoInterfaceFiles "Company" + compareNoInterfaceFiles "Card" + compareNoInterfaceFiles "OneTypeParameter" + compareNoInterfaceFiles "TwoTypeParameters" + compareNoInterfaceFiles "ThreeTypeParameters" + compareNoInterfaceFiles "SubTypeParameter" + +data SimpleChoice = + SimpleChoice + { choice :: Either String Int + } deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance Arbitrary SimpleChoice where + arbitrary = SimpleChoice <$> arbitrary + +instance ToADTArbitrary SimpleChoice + +data Person = Person + { id :: Int + , name :: Maybe String + , created :: UTCTime + } deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance Arbitrary Person where + arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary + +instance ToADTArbitrary Person + +data Company = Company + { address :: String + , employees :: [Person] + } deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance Arbitrary Company where + arbitrary = do + k <- choose (1,3) + v <- vector k + Company <$> arbitrary <*> pure v + +instance ToADTArbitrary Company + +data Company2 = Company2 + { address2 :: String + , boss :: Maybe Person + } deriving (Show, Eq, Generic, OCamlType, FromJSON, ToJSON) + +instance Arbitrary Company2 where + arbitrary = Company2 <$> arbitrary <*> arbitrary + +instance ToADTArbitrary Company2 + +data Suit + = Clubs + | Diamonds + | Hearts + | Spades + deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + +instance Arbitrary Suit where + arbitrary = elements [Clubs, Diamonds, Hearts, Spades] + +instance ToADTArbitrary Suit + +data Card = + Card + { cardSuit :: Suit + , cardValue :: Int + } deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + +instance Arbitrary Card where + arbitrary = Card <$> arbitrary <*> arbitrary + +instance ToADTArbitrary Card + +data OneTypeParameter a = + OneTypeParameter + { otpId :: Int + , otpFirst :: a + } deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + +instance Arbitrary (OneTypeParameter TypeParameterRef0) where + arbitrary = OneTypeParameter <$> arbitrary <*> arbitrary + +instance ToADTArbitrary (OneTypeParameter TypeParameterRef0) + +data TwoTypeParameters a b = + TwoTypeParameters + { ttpId :: Int + , ttpFirst :: a + , ttpSecond :: b + } deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + +instance Arbitrary (TwoTypeParameters TypeParameterRef0 TypeParameterRef1) where + arbitrary = TwoTypeParameters <$> arbitrary <*> arbitrary <*> arbitrary + +instance ToADTArbitrary (TwoTypeParameters TypeParameterRef0 TypeParameterRef1) + +data Three a b c = + Three + { threeId :: Int + , threeFirst :: a + , threeSecond :: b + , threeThird :: c + , threeString :: String + } deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + +instance Arbitrary (Three TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) where + arbitrary = Three <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance ToADTArbitrary (Three TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) + +data SubTypeParameter a b c = + SubTypeParameter + { listA :: [a] + , maybeB :: Maybe b + , tupleC :: (c,b) + } deriving (Eq,Show,Generic,OCamlType,FromJSON,ToJSON) + +instance Arbitrary (SubTypeParameter TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) where + arbitrary = do + k <- choose (1,3) + v <- vector k + SubTypeParameter <$> pure v <*> arbitrary <*> arbitrary + +instance ToADTArbitrary (SubTypeParameter TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) diff --git a/test/ProductApp.hs b/test/ProductApp.hs new file mode 100644 --- /dev/null +++ b/test/ProductApp.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module ProductApp where + +import OCaml.Export +import Product + +$(mkOCamlSpecServer "ProductPackage" (Proxy :: Proxy ProductPackage)) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +import Network.Wai.Handler.Warp +import Network.Wai +import Network.Wai.Middleware.RequestLogger (logStdout) +import System.Process + +-- base +import Control.Concurrent (forkIO) +import Data.Monoid ((<>)) +import GHC.TypeLits + +-- ByteString +import Data.ByteString (unpack) + +-- hspec +import Test.Hspec + +-- hspec-aeson-golden +import Test.Aeson.GenericSpecs + + +-- servant +import Servant + +-- servant-server +import Servant.API + +-- text +import Data.Text (Text) + +-- ocaml-export +import OCaml.Export +import qualified Dependency as D +import qualified File as File +import qualified FileApp as File +import qualified Options as Options +import qualified Product as Product +import ProductApp +import qualified Sum as Sum +import SumApp + +logAllMiddleware :: Application -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived +logAllMiddleware app req respond = do + d <- requestBody req + print $ requestHeaders req + print $ d + app req respond + +-- npm start --prefix path/to/your/app + +main :: IO () +main = do + hspec Product.spec + hspec Sum.spec + hspec File.spec +-- hspec Options.spec + hspec D.spec + + hspec $ + describe "mkOCamlTypeMetaData" $ + it "mkOCamlTypeMetaData on package A and B should equal mkOCamlTypeMetaData on B which has A as a dependency" $ + (mkOCamlTypeMetaData (Proxy :: Proxy Product.ProductPackage)) <> (mkOCamlTypeMetaData (Proxy :: Proxy D.DependencyPackageWithoutProduct)) + `shouldBe` mkOCamlTypeMetaData (Proxy :: Proxy D.DependencyPackage) + +-- print $ ocamlPackageTypeCount (Proxy :: Proxy Product.ProductPackage) + +-- print $ mkOCamlTypeMetaData (Proxy :: Proxy Product.ProductPackage) + print $ mkOCamlTypeMetaData (Proxy :: Proxy D.SubsPackage) + + _ <- forkIO $ run 8081 productPackageApp + _ <- forkIO $ run 8082 sumPackageApp + run 8083 File.filePackageApp + +-- curl -i -d '"hi"' -H 'Content-type: application/json' -X POST http://localhost:8081/x/y + diff --git a/test/Sum.hs b/test/Sum.hs new file mode 100644 --- /dev/null +++ b/test/Sum.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Sum where + +-- base +import GHC.Generics + +-- aeson +import Data.Aeson (FromJSON, ToJSON) + +-- containers +import qualified Data.Map as Map + +-- hspec +import Test.Hspec + +-- QuickCheck +import Test.QuickCheck hiding (Result, Success) + +-- quickcheck-arbitrary-adt +import Test.QuickCheck.Arbitrary.ADT +import Test.Aeson.Internal.ADT.GoldenSpecs + +-- servant +import Servant.API + +-- servant-server +import Servant + +-- ocaml-export +import OCaml.Export hiding (mkGoldenFiles) +import Util + + +type SumPackage + = OCamlPackage "sum" NoDependency :> + (OCamlModule '["OnOrOff"] :> OnOrOff + :<|> OCamlModule '["NameOrIdNumber"] :> NameOrIdNumber + :<|> OCamlModule '["SumVariant"] :> SumVariant + :<|> OCamlModule '["WithTuple"] :> WithTuple + :<|> OCamlModule '["SumWithRecord"] :> SumWithRecord + :<|> OCamlModule '["Result"] :> Result TypeParameterRef0 TypeParameterRef1 + :<|> OCamlModule '["NewType"] :> NewType) + +compareInterfaceFiles = compareFiles "test/interface" "sum" True + +compareNoInterfaceFiles = compareFiles "test/nointerface" "sum" False + +mkGolden :: forall a. (ToADTArbitrary a, ToJSON a) => Proxy a -> IO () +mkGolden Proxy = mkGoldenFileForType 10 (Proxy :: Proxy a) "test/interface/golden/golden/sum" + +mkGoldenFiles :: IO () +mkGoldenFiles = do + mkGolden (Proxy :: Proxy OnOrOff) + mkGolden (Proxy :: Proxy NameOrIdNumber) + mkGolden (Proxy :: Proxy SumVariant) + mkGolden (Proxy :: Proxy WithTuple) + mkGolden (Proxy :: Proxy SumWithRecord) + mkGolden (Proxy :: Proxy (Result TypeParameterRef0 TypeParameterRef1)) + mkGolden (Proxy :: Proxy NewType) + +spec :: Spec +spec = do + runIO mkGoldenFiles + let dir = "test/interface/temp" + runIO $ mkPackage (Proxy :: Proxy SumPackage) (PackageOptions dir "sum" Map.empty True $ Just $ SpecOptions "__tests__/sum" "golden/sum" "http://localhost:8082") + + describe "OCaml Declaration with Interface: Sum Types" $ do + compareInterfaceFiles "OnOrOff" + compareInterfaceFiles "NameOrIdNumber" + compareInterfaceFiles "SumVariant" + compareInterfaceFiles "WithTuple" + 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) + +instance Arbitrary OnOrOff where + arbitrary = elements [On, Off] + +instance ToADTArbitrary OnOrOff + +data NameOrIdNumber = Name String | IdNumber Int + deriving (Show, Eq, Generic, OCamlType,ToJSON,FromJSON) + +instance Arbitrary NameOrIdNumber where + arbitrary = oneof [Name <$> arbitrary, IdNumber <$> arbitrary] + +instance ToADTArbitrary NameOrIdNumber + +data Result a b + = Success a + | Error b + deriving (Show, Eq, Generic, OCamlType, ToJSON, FromJSON) + +instance Arbitrary (Result TypeParameterRef0 TypeParameterRef1) where + arbitrary = oneof [Success <$> arbitrary, Error <$> arbitrary] + +instance ToADTArbitrary (Result TypeParameterRef0 TypeParameterRef1) + +data SumVariant + = HasNothing + | HasSingleInt Int + | HasSingleTuple (Int,Int) + | HasMultipleInts Int Int + | HasMultipleTuples (Int,Int) (Int,Int) + | HasMixed Int String Double + deriving (Show,Eq,Generic, OCamlType, ToJSON, FromJSON) + +instance Arbitrary SumVariant where + arbitrary = + oneof + [ pure HasNothing + , HasSingleInt <$> arbitrary + , HasSingleTuple <$> arbitrary + , HasMultipleInts <$> arbitrary <*> arbitrary + , HasMultipleTuples <$> arbitrary <*> arbitrary + , HasMixed <$> arbitrary <*> arbitrary <*> arbitrary + ] + +instance ToADTArbitrary SumVariant + + +type Tuple + = (Int,Int) + +data WithTuple = WithTuple Tuple + deriving (Show,Eq,Generic, OCamlType, ToJSON, FromJSON) + +instance Arbitrary WithTuple where + arbitrary = WithTuple <$> arbitrary + +instance ToADTArbitrary WithTuple + +data SumWithRecord + = A1 {a1 :: Int} + | B2 {b2 :: String, b3 :: Int} + deriving (Show,Eq,Generic, OCamlType, ToJSON, FromJSON) + +instance Arbitrary SumWithRecord where + arbitrary = + oneof + [ A1 <$> arbitrary + , B2 <$> arbitrary <*> arbitrary + ] + +instance ToADTArbitrary SumWithRecord + +newtype NewType + = NewType Int + deriving (Show,Eq,Generic,OCamlType, ToJSON, FromJSON) + +instance Arbitrary NewType where + arbitrary = NewType <$> arbitrary + +instance ToADTArbitrary NewType diff --git a/test/SumApp.hs b/test/SumApp.hs new file mode 100644 --- /dev/null +++ b/test/SumApp.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module SumApp where + +import OCaml.Export +import Sum + +$(mkOCamlSpecServer "SumPackage" (Proxy :: Proxy SumPackage)) diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -0,0 +1,91 @@ +module Util where + +-- base +import Data.Monoid ((<>)) +import Data.Time + +-- text +import qualified Data.Text.IO as T + +-- ocaml-export +import OCaml.Export hiding (Options) + + +import System.Directory (doesFileExist) + +-- filepath +import System.FilePath.Posix (()) + +-- hspec +import Test.Hspec + +-- QuickCheck +import Test.QuickCheck + +-- quickcheck-arbitrary-adt +import Test.QuickCheck.Arbitrary.ADT +import Test.Aeson.Internal.ADT.GoldenSpecs + +instance Arbitrary UTCTime where + arbitrary = + UTCTime <$> (ModifiedJulianDay <$> (2000 +) <$> arbitrary) + <*> pure 1.011 +-- <*> (fromRational . toRational . (\f -> fromInteger $ round $ f * (10^2) / (10.0^^2)) <$> choose (0:: Double, 86400)) + +data ADT + = Options + +adtToPath :: ADT -> FilePath +adtToPath Options = "options" + + +compareFiles :: FilePath -> FilePath -> Bool -> FilePath -> SpecWith () +compareFiles rootDir categoryDir compareInterfaceAndSpecFiles typeName = + it typeName $ do + automated <- T.readFile (testPath typeName <> ".ml") + handWritten <- T.readFile (goldenPath typeName <> ".ml") + automated `shouldBe` handWritten + if compareInterfaceAndSpecFiles + then do + automatedI <- T.readFile (testPath typeName <> ".mli") + handWrittenI <- T.readFile (goldenPath typeName <> ".mli") + automatedI `shouldBe` handWrittenI + + automatedS <- T.readFile (testSpecPath typeName <> "_spec" <> ".ml") + handWrittenS <- T.readFile (goldenSpecPath typeName <> "_spec" <> ".ml") + automatedS `shouldBe` handWrittenS + else pure () + where + testPath = rootDir "temp" categoryDir + goldenPath = rootDir "golden" categoryDir + testSpecPath = rootDir "temp" "__tests__" categoryDir + goldenSpecPath = rootDir "golden" "__tests__" categoryDir + +{- +testOCamlTypeWithInterface :: ADT -> FilePath -> OCamlInterface -> SpecWith () +testOCamlTypeWithInterface adt typeName ocamlFile = + it typeName $ do + createOCamlFileWithInterface testPath specPath typeName ocamlFile + automated <- T.readFile (testPath <> "/" <> typeName <> ".ml") + handWritten <- T.readFile (goldenPath <> "/" <> typeName <> ".ml") + + automated2 <- T.readFile (testPath <> "/" <> typeName <> ".mli") + handWritten2 <- T.readFile (goldenPath <> "/" <> typeName <> ".mli") + + automated `shouldBe` handWritten + automated2 `shouldBe` handWritten2 + + fe <- doesFileExist (specGoldenPath <> "/" <> typeName <> "_spec.ml") + if fe + then do + automated3 <- T.readFile (specPath <> "/" <> typeName <> "_spec.ml") + handWritten3 <- T.readFile (specGoldenPath <> "/" <> typeName <> "_spec.ml") + automated3 `shouldBe` handWritten3 + else pure () + where + adtPath = adtToPath adt + testPath = "test/interface/temp/" <> adtPath + goldenPath = "test/interface/golden/" <> adtPath + specPath = "test/interface/temp/__tests__/" <> adtPath + specGoldenPath = "test/interface/golden/__tests__/" <> adtPath +-}