add naive schema comparison

autotypes/src/AutoTypes.hs

@@ -4,7 +4,6 @@ module AutoTypes
   )
 where
 
-import Debug.Trace
 import qualified AutoTypes.Unify as U
 import Data.Aeson (Value, decodeFileStrict', encode)
 import Data.Maybe (fromJust)
@@ -17,7 +16,7 @@ autoTypes fp fps = autoTypes' <$> go fp <*> mapM go (fp : fps)
 
 autoTypes' :: Value -> [Value] -> U.T
 autoTypes' t' ts' =
-  let types = map U.fromJson (Debug.Trace.traceShowId (t' : ts'))
+  let types = map U.fromJson (t' : ts')
    in head
         ( foldr1
             (\ls rs -> (concat [U.unify1 l r | l <- ls, r <- rs]))

backend/app/Main.hs

@@ -69,7 +69,7 @@ data Commit = Commit
 data Collection = Collection
   { path :: FilePath,
     files :: [FilePath],
-    schema :: Schema
+    schema :: U.T
   }
   deriving (Show)
 
@@ -130,10 +130,10 @@ initRepo root ref = do
               (value : values) <- do
                 liftIO $ Q.withStore root ref do
                   mapM (Q.withCommit cid . Q.readFile) (file : files)
-              let schema = fromAutoTypes path $ U.autoTypes' value values
+              let schema = U.autoTypes' value values
               pure $ Collection path files schema
             let schemaVersion =
-                  case lastMay cs of
+                  case headMay cs of
                     Nothing -> Version 1 0 0
                     Just c' ->
                       let Version major' minor' patch' = c'.schemaVersion
@@ -159,8 +159,8 @@ initRepo root ref = do
         cs
 
 compareSchemas ::
-  M.Map String Schema ->
+  M.Map String U.T ->
-  M.Map String Schema ->
+  M.Map String U.T ->
   Maybe SchemaDifference
 compareSchemas schemas' schemas =
   maximumMay
@@ -174,19 +174,24 @@ compareSchemas schemas' schemas =
       schemas'
       schemas
   where
-    compareSchemas' Nothing (Just _) = Just Patch
+    compareSchemas' Nothing Nothing = Nothing
-    compareSchemas' (Just _) Nothing = Just Patch
+    compareSchemas' Nothing (Just _) = Just Minor
+    compareSchemas' (Just _) Nothing = Just Major
     compareSchemas' (Just schema') (Just schema) = compareSchema schema' schema
 
--- TODO
+compareSchema :: U.T -> U.T -> Maybe SchemaDifference
-compareSchema :: Schema -> Schema -> Maybe SchemaDifference
+compareSchema (U.Object kts') (U.Object kts) = compareSchemas kts' kts
-compareSchema schema' schema = Nothing
+compareSchema t' t
+  | t' == t = Nothing
+  | t' `elem` (U.unify1 t' t) = Just Patch
+  | t `elem` U.unify1 t' t = Just Minor
+  | otherwise = Just Major
 
 data SchemaDifference
   = Major
   | Minor
   | Patch
-  deriving (Eq, Ord)
+  deriving (Show, Eq, Ord)
 
 main :: IO ()
 main = do
@@ -202,7 +207,8 @@ main = do
           Right (SchemaJson path) -> do
             repo <- atomically (readTMVar repoT)
             let [c] = filter ((== path) . (.path)) (last repo.commits).collections
-            respond $ W.responseLBS W.status200 [] (J.encode c.schema)
+            respond . W.responseLBS W.status200 [] $
+              J.encode (fromAutoTypes path c.schema)
           Right Query -> do
             q <-
               fromString @Q.Query . LB.toString

default.nix

@@ -32,6 +32,7 @@ rec {
     ];
     buildInputs = [
       haskellPackages.astore
+      haskellPackages.autotypes
       haskellPackages.cabal-install
       haskellPackages.ormolu
       (pkgs.writeScriptBin "reload" ''