diff options
| -rw-r--r-- | autotypes/autotypes.cabal | 1 | ||||
| -rw-r--r-- | autotypes/src/AutoTypes/Unify.hs | 44 | ||||
| -rw-r--r-- | backend/app/Main.hs | 7 |
3 files changed, 35 insertions, 17 deletions
diff --git a/autotypes/autotypes.cabal b/autotypes/autotypes.cabal index c81abd0..d7d60b6 100644 --- a/autotypes/autotypes.cabal +++ b/autotypes/autotypes.cabal @@ -39,6 +39,7 @@ library containers, filepath, text, + time, vector hs-source-dirs: src default-language: Haskell2010 diff --git a/autotypes/src/AutoTypes/Unify.hs b/autotypes/src/AutoTypes/Unify.hs index 3622cba..5d611d3 100644 --- a/autotypes/src/AutoTypes/Unify.hs +++ b/autotypes/src/AutoTypes/Unify.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} module AutoTypes.Unify ( T (..), @@ -20,26 +21,44 @@ import Data.Map (Map) import qualified Data.Map as M import qualified Data.Map.Merge.Lazy as M import qualified Data.Text as T +import Data.Time.Clock +import Data.Time.Format.ISO8601 import qualified Data.Vector as V import Debug.Trace import System.FilePath (takeDirectory) import Prelude hiding (null) +data ScalarType + = String + | Number + | DateTime + | Bool + deriving (Eq, Show) + +scalarTypeString :: ScalarType -> String +scalarTypeString String = "string" +scalarTypeString Number = "number" +scalarTypeString DateTime = "datetime" +scalarTypeString Bool = "bool" + data T = List (Maybe T) | Object (Map String T) | Option (Maybe T) - | Scalar String + | Scalar ScalarType | Union [T] | Reference String deriving (Eq, Show) instance A.ToJSON T where - toJSON (List t) = A.toJSON t - toJSON (Object ts) = A.toJSON ts + toJSON (List t) = A.object [K.fromString "type" A..= "array", K.fromString "items" A..= A.toJSON t] + toJSON (Object ts) = A.object [K.fromString "type" A..= "object", K.fromString "properties" A..= A.toJSON ts] toJSON (Option t) = A.toJSON t - toJSON (Scalar s) = A.toJSON s - toJSON (Union ts) = A.toJSON ts + toJSON (Scalar DateTime) = A.object [K.fromString "type" A..= "string", K.fromString "format" A..= "date-time"] + toJSON (Scalar String) = A.object [K.fromString "type" A..= "string"] + toJSON (Scalar Bool) = A.object [K.fromString "type" A..= "bool"] + toJSON (Scalar Number) = A.object [K.fromString "type" A..= "number"] + toJSON (Union ts) = A.object [K.fromString "oneOf" A..= A.toJSON ts] toJSON (Reference i) = A.object [K.fromString "$ref" A..= A.String (T.pack i)] toString :: T -> String @@ -53,7 +72,7 @@ toString_ n (Object kvs) = M.mapWithKey (\s t -> (n + 1, s) : toString_ (n + 2) t) kvs, [(n, "}")] ] -toString_ n (Scalar s) = [(n, s)] +toString_ n (Scalar s) = [(n, scalarTypeString s)] toString_ n (Union ts) = concatMap (toString_ n) ts toString_ n (Option Nothing) = [(n, "null")] toString_ n (Option (Just t)) = map (second (++ "?")) (toString_ n t) @@ -175,10 +194,11 @@ object = Object list :: Maybe T -> T list = List -string, number, bool, null :: T -string = Scalar "string" -number = Scalar "number" -bool = Scalar "bool" +string, number, bool, dateTime, null :: T +string = Scalar String +number = Scalar Number +bool = Scalar Bool +dateTime = Scalar DateTime null = Option Nothing data InferException = InferException [T] @@ -197,7 +217,9 @@ fromJson t@(A.Array vs) = [] -> list Nothing [t] -> list (Just t) _ -> throw (InferException ts) -fromJson (A.String _) = string +fromJson (A.String s) + | Just _ <- iso8601ParseM @Maybe @UTCTime (T.unpack s) = dateTime + | otherwise = string fromJson (A.Number _) = number fromJson (A.Bool _) = bool fromJson A.Null = null diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 063bb1a..24a110f 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -108,17 +108,12 @@ fromAutoTypes path (U.Object ps) = ("$id", J.toJSON @String (path <> ".schema.json")), ("title", J.toJSON @String path), ("type", J.toJSON @String "object"), - ("properties", J.toJSON (M.map toProperty ps)), + ("properties", J.toJSON ps), ("required", J.toJSON (M.keys (M.filter isRequired ps))) ] where isRequired (U.Option _) = False isRequired _ = True - toProperty :: U.T -> M.Map String String - toProperty (U.Scalar "string") = M.fromList [("type", "string")] - toProperty (U.Option (Just (U.Scalar "string"))) = M.fromList [("type", "string")] - toProperty (U.Reference i) = M.fromList [("$ref", i)] - toProperty x = error ("unhandled type: " <> show x) fromAutoTypes _ _ = error "Only JSON objects are supported." watch :: TMVar Repo -> FilePath -> G.RefName -> IO () |