Adding intersection types

proda-ai · Sep 16, 2022 · d1a3c42 · d1a3c42
1 parent fafccad
commit d1a3c42
Show file tree

Hide file tree

Showing 3 changed files with 11 additions and 2 deletions.
diff --git a/src/Servant/TS/Core.hs b/src/Servant/TS/Core.hs
@@ -60,6 +60,7 @@ data TsTypeBase a = TsVoid
                   | TsString
                   | TsStringLiteral Text
                   | TsUnion [TsTypeBase a]
+                  | TsIntersection [TsTypeBase a]
                   | TsMap (TsTypeBase a)
                   | TsNullable (TsTypeBase a)
                   | TsArray (TsTypeBase a)
@@ -80,6 +81,7 @@ data TsTypeBaseF a r = TsVoidF
                      | TsStringF
                      | TsStringLiteralF Text
                      | TsUnionF [r]
+                     | TsIntersectionF [r]
                      | TsMapF r
                      | TsNullableF r
                      | TsArrayF r
@@ -104,6 +106,7 @@ instance Recursive TsType where
     project TsString = TsStringF
     project (TsStringLiteral a) = TsStringLiteralF a
     project (TsUnion a) = TsUnionF a
+    project (TsIntersection a) = TsIntersectionF a
     project (TsMap a) = TsMapF a
     project (TsNullable a) = TsNullableF a
     project (TsArray a) = TsArrayF a
@@ -121,6 +124,7 @@ instance Corecursive TsType where
     embed TsStringF = TsString
     embed (TsStringLiteralF a) = TsStringLiteral a
     embed (TsUnionF a) = TsUnion a
+    embed (TsIntersectionF a) = TsIntersection a
     embed (TsMapF a) = TsMap a
     embed (TsNullableF a) = TsNullable a
     embed (TsArrayF a) = TsArray a
@@ -200,9 +204,10 @@ flatten t = cata f t $ Set.empty
           f TsStringF _ = pure TsString
           f (TsStringLiteralF a) _ = pure (TsStringLiteral a)
           f (TsUnionF a) s = TsUnion <$> mapM ($ s) a
+          f (TsIntersectionF a) s = TsIntersection <$> mapM ($ s) a
           f (TsMapF a) s = TsMap <$> a s
           f (TsNullableF a) s = TsNullable <$> a s
           f (TsArrayF a) s = TsArray <$> a s
           f (TsObjectF a) s = TsObject <$> mapM ($ s) a
           f (TsTupleF a) s = TsTuple <$> mapM ($ s) a
-          f (TsGenericArgF i) _ = pure (TsGenericArg i)
+          f (TsGenericArgF i) _ = pure (TsGenericArg i)
diff --git a/src/Servant/TS/Gen.hs b/src/Servant/TS/Gen.hs
@@ -87,6 +87,8 @@ tsTypeName TsNull = "null"
 tsTypeName (TsStringLiteral n) = "\"" <> n <> "\""
 tsTypeName (TsUnion []) = error "invalid empty TsUnion"
 tsTypeName (TsUnion ts) = Text.intercalate " | " (tsTypeName <$> ts)
+tsTypeName (TsIntersect []) = error "invalid empty TsIntersect"
+tsTypeName (TsIntersect ts) = Text.intercalate " & " (tsTypeName <$> ts)
 tsTypeName (TsNullable t) = tsTypeName t <> " | null"
 tsTypeName (TsNamedType n as _) = tsCustomTypeName n as
 tsTypeName (TsArray t) = "Array<" <> tsTypeName t <> ">"
@@ -174,6 +176,7 @@ writeCustomType opts (tr, t) = let prefix = "export type " <> typeName
 
           writeCustomTypeDef :: Int -> TsRefType -> Text
           writeCustomTypeDef i (TsUnion ts) = Text.intercalate ("\n" <> i' <> Text.replicate i " " <> " | ") (writeCustomTypeDef i <$> ts)
+          writeCustomTypeDef i (TsIntersect ts) = Text.intercalate ("\n" <> i' <> Text.replicate i " " <> " & ") (writeCustomTypeDef i <$> ts)
 
           writeCustomTypeDef i (TsObject ts) = "{ " <> Text.intercalate ", " ((\(n, t) -> n <> ": " <> writeCustomTypeDef i t) <$> sortOn fst (HashMap.toList ts)) <> " }"
 

diff --git a/test/Servant/TS/TestHelpers.hs b/test/Servant/TS/TestHelpers.hs
@@ -81,6 +81,7 @@ tsTypecheck t v = para f t $ ([], v)
           f (TsNullableF (_, f')) x = f' x
           f (TsArrayF (_, f')) (gs, Array vs) = firstError $ f' . (gs,) <$> Vector.toList vs
           f t@(TsUnionF ts) x = if any isNothing $ ($ x) . snd <$> ts then Nothing else mkError t (snd x)
+          f t@(TsIntersectF ts) x = if any isNothing $ ($ x) . snd <$> ts then Nothing else mkError t (snd x)
           f t@(TsObjectF ts) (gs, v@(Object m)) = if (Set.fromList . HashMap.keys) ts == (Set.fromList . HashMap.keys) m 
                                                   then firstError $ (\((_, f), v) -> f (gs, v)) <$> (HashMap.elems $ HashMap.intersectionWith (,) ts m)
                                                   else mkError t v
@@ -189,4 +190,4 @@ makeTests_G1_TH opts xs = [testGroup (n xs) $ makeSingleDefinitionTest (unwrapTs
                     test_TH = testCase "TH <-> Aeson" $ makeTestInternal v (tsTypeRep p) (toJSON v)
                     test_G0 = testCase "G0 <-> Aeson" $ makeTestInternal v (genericTsTypeable opts p) (genericToJSON opts v)
                     test_G = testCase "G1 <-> Aeson" $ makeTestInternal v (generic1TsTypeable opts p) (genericToJSON opts v)
-                    test_EQ1 = testCase "G1 = TH" ((tsTypeRep p) @=? (generic1TsTypeable opts p))
+                    test_EQ1 = testCase "G1 = TH" ((tsTypeRep p) @=? (generic1TsTypeable opts p))