From 8a65a38a5d187a885325fa4d3ebf81f56feaecbb Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sun, 11 Oct 2026 19:08:11 -0700 Subject: [PATCH 1/5] Compute a mapped type family's image at the use site typeFamiliesToMapToTypeScript only handled a single-argument family with a concrete image, so a mode-indexed family whose result is one of its own arguments was rejected outright: type family IsHydrated (f :: Type -> Type) x y where IsHydrated Dry x y = x IsHydrated Wet x y = y The use site fixes those arguments, and then the image is concrete. Substituting them before tabulating turns such a record into one generic declaration indexed on the mode, rather than one specialized declaration per instantiation sharing a name. A variable that keys a mapped family is now an eligible generic variable whatever its kind, tables are named per use site so two sites of one family don't collide, and the placeholder each table generates is memoized per module. Still out of reach: a family whose choice type mentions another of the record's variables, and one whose keys aren't plain constructors (beam's Columnar). --- aeson-typescript.cabal | 3 +- src/Data/Aeson/TypeScript/Lookup.hs | 36 ++++++++- src/Data/Aeson/TypeScript/TH.hs | 11 ++- src/Data/Aeson/TypeScript/Transform.hs | 58 +++++++++---- src/Data/Aeson/TypeScript/TypeManipulation.hs | 24 +++--- src/Data/Aeson/TypeScript/Types.hs | 2 +- src/Data/Aeson/TypeScript/Util.hs | 27 +++++++ test/Spec.hs | 2 + test/UseSiteFamilyImage.hs | 81 +++++++++++++++++++ 9 files changed, 211 insertions(+), 33 deletions(-) create mode 100644 test/UseSiteFamilyImage.hs diff --git a/aeson-typescript.cabal b/aeson-typescript.cabal index 2387dd8..71f7518 100644 --- a/aeson-typescript.cabal +++ b/aeson-typescript.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.0. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack @@ -104,6 +104,7 @@ test-suite aeson-typescript-tests UntaggedNoTagSingleConstructors UntaggedTagSingleConstructors UnwrapUnaryRecords + UseSiteFamilyImage Util Util.Aeson Data.Aeson.TypeScript.Formatting diff --git a/src/Data/Aeson/TypeScript/Lookup.hs b/src/Data/Aeson/TypeScript/Lookup.hs index f51b2fd..617ecd4 100644 --- a/src/Data/Aeson/TypeScript/Lookup.hs +++ b/src/Data/Aeson/TypeScript/Lookup.hs @@ -11,9 +11,12 @@ import Data.Aeson.TypeScript.Instances () import Data.Aeson.TypeScript.Types import Data.Function import qualified Data.List as L +import qualified Data.Map as M import Data.Proxy import Data.String.Interpolate import Language.Haskell.TH hiding (stringE) +import Language.Haskell.TH.Datatype.TyVarBndr () +import Language.Haskell.TH.Datatype (applySubstitution) import qualified Language.Haskell.TH.Lib as TH @@ -32,8 +35,37 @@ deriveTypeScriptLookupType name declNameStr = do _ -> fail [i|Expected a closed type family; got #{info}|] +-- | Fix a family's trailing arguments to the types a use site applies it to, so that an +-- equation whose result is one of those arguments gets a concrete result. +-- +-- @Chosen f x y@, with @Chosen Terse x y = x@, has no image on its own. Applied to +-- @Chosen f Int String@ it becomes @Chosen Terse Int String = Int@, which does. +substituteTrailingArgs :: [Type] -> TySynEqn -> Q TySynEqn +#if MIN_VERSION_template_haskell(2,15,0) +substituteTrailingArgs [] eqn = return eqn +substituteTrailingArgs args (TySynEqn bndrs lhs result) = case splitLhs lhs of + Just (famName, key : rest) | length rest == length args -> do + let substitution = M.fromList [(n, t) | (VarT n, t) <- zip rest args] + return $ TySynEqn Nothing (AppT (ConT famName) key) (applySubstitution substitution result) + _ -> return (TySynEqn bndrs lhs result) + where + splitLhs :: Type -> Maybe (Name, [Type]) + splitLhs (ConT n) = Just (n, []) + splitLhs (AppT f x) = do + (n, xs) <- splitLhs f + return (n, xs <> [x]) + splitLhs (SigT t _) = splitLhs t + splitLhs (ParensT t) = splitLhs t + splitLhs _ = Nothing +#else +substituteTrailingArgs _ eqn = return eqn +#endif + getClosedTypeFamilyInterfaceDecl :: Name -> [TySynEqn] -> Q Exp -getClosedTypeFamilyInterfaceDecl name eqns = do +getClosedTypeFamilyInterfaceDecl name eqns = getClosedTypeFamilyInterfaceDecl' (nameBase name) eqns + +getClosedTypeFamilyInterfaceDecl' :: String -> [TySynEqn] -> Q Exp +getClosedTypeFamilyInterfaceDecl' name eqns = do fields <- forM eqns $ \case #if MIN_VERSION_template_haskell(2,15,0) TySynEqn Nothing (AppT (ConT _) (ConT arg)) result -> do @@ -46,7 +78,7 @@ getClosedTypeFamilyInterfaceDecl name eqns = do #endif x -> fail [i|aeson-typescript doesn't know yet how to handle this type family equation when generating interface declaration: '#{x}'|] - [| TSInterfaceDeclaration $(TH.stringE $ nameBase name) [] (L.sortBy (compare `on` fieldName) $(listE $ fmap return fields)) Nothing |] + [| TSInterfaceDeclaration $(TH.stringE name) [] (L.sortBy (compare `on` fieldName) $(listE $ fmap return fields)) Nothing |] getClosedTypeFamilyImage :: [TySynEqn] -> Q [Type] getClosedTypeFamilyImage eqns = do diff --git a/src/Data/Aeson/TypeScript/TH.hs b/src/Data/Aeson/TypeScript/TH.hs index e0ebbec..b1d04b5 100644 --- a/src/Data/Aeson/TypeScript/TH.hs +++ b/src/Data/Aeson/TypeScript/TH.hs @@ -183,9 +183,18 @@ deriveTypeScript' options name extraOptions = do datatypeInfo' <- reifyDatatype name assertExtensionsTurnedOn datatypeInfo' - -- Figure out what the generic variables are + -- Figure out what the generic variables are. A variable of kind * is one; so is one that + -- keys a mapped type family in some field, whatever its kind, since the family application + -- becomes an indexed access on it. + let fieldTypes = mconcat [constructorFields ci | ci <- datatypeCons datatypeInfo'] + let keysAMappedFamily n = or [True | typ <- fieldTypes + , (ConT famName, VarT keyVar : _) <- [splitAppsT typ] + , keyVar == n + , famName `L.elem` typeFamiliesToMapToTypeScript extraOptions] let eligibleGenericVars = catMaybes $ flip fmap (getDataTypeVars datatypeInfo') $ \case SigT (VarT n) StarT -> Just n + SigT (VarT n) _ | keysAMappedFamily n -> Just n + VarT n | keysAMappedFamily n -> Just n _ -> Nothing let varsAndTVars = case eligibleGenericVars of [] -> [] diff --git a/src/Data/Aeson/TypeScript/Transform.hs b/src/Data/Aeson/TypeScript/Transform.hs index 7e02879..4b334f1 100644 --- a/src/Data/Aeson/TypeScript/Transform.hs +++ b/src/Data/Aeson/TypeScript/Transform.hs @@ -12,9 +12,14 @@ module Data.Aeson.TypeScript.Transform ( import Control.Monad.Writer import Data.Aeson.TypeScript.Lookup import Data.Aeson.TypeScript.Types +import Data.Aeson.TypeScript.Util (splitAppsT, typeFamilyTableName) +import Control.Monad (unless) +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Set as S import qualified Data.List as L import Data.Typeable import Language.Haskell.TH hiding (stringE) +import Language.Haskell.TH.Syntax (getQ, putQ) import qualified Language.Haskell.TH.Lib as TH #if !MIN_VERSION_base(4,11,0) @@ -22,27 +27,48 @@ import Data.Monoid #endif +-- | Tables emitted so far in this module, so that repeated use sites of one family agree on +-- a single declaration. 'Q' state persists across splices within a module. +newtype EmittedFamilyTables = EmittedFamilyTables (S.Set String) + -- | Search the given type for type families. For each one found, emit a declaration for a new -- corresponding concrete type and a TypeScript instance for it which emits a lookup type. -- Then, replace all occurrences of the given type family with the concrete type in the return value. -- Thus the type becomes "de-family-ified". transformTypeFamilies :: ExtraTypeScriptOptions -> Type -> WriterT [ExtraDeclOrGenericInfo] Q Type -transformTypeFamilies eo@(ExtraTypeScriptOptions {..}) (AppT (ConT name) typ) - | name `L.elem` typeFamiliesToMapToTypeScript = lift (reify name) >>= \case - FamilyI (ClosedTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _) eqns) _ -> handle typeFamilyName eqns +transformTypeFamilies eo@(ExtraTypeScriptOptions {..}) wholeType + | (ConT name, keyArg : trailing) <- splitAppsT wholeType + , name `L.elem` typeFamiliesToMapToTypeScript = lift (reify name) >>= \case + FamilyI (ClosedTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _) eqns) _ -> handle name keyArg trailing typeFamilyName eqns #if MIN_VERSION_template_haskell(2,15,0) - FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) decs -> handle typeFamilyName [eqn | TySynInstD eqn <- decs] + FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) decs -> handle name keyArg trailing typeFamilyName [eqn | TySynInstD eqn <- decs] #else - FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) decs -> handle typeFamilyName [eqn | TySynInstD _name eqn <- decs] + FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) decs -> handle name keyArg trailing typeFamilyName [eqn | TySynInstD _name eqn <- decs] #endif - _ -> AppT (ConT name) <$> transformTypeFamilies eo typ - | otherwise = AppT (ConT name) <$> transformTypeFamilies eo typ - where - handle :: Name -> [TySynEqn] -> WriterT [ExtraDeclOrGenericInfo] Q Type - handle typeFamilyName eqns = do - name' <- lift $ newName (nameBase typeFamilyName <> "'") + _ -> descend wholeType + where + descend (AppT typ1 typ2) = AppT <$> transformTypeFamilies eo typ1 <*> transformTypeFamilies eo typ2 + descend (SigT typ kind) = flip SigT kind <$> transformTypeFamilies eo typ + descend (ParensT typ) = ParensT <$> transformTypeFamilies eo typ + descend typ = return typ + + handle :: Name -> Type -> [Type] -> Name -> [TySynEqn] -> WriterT [ExtraDeclOrGenericInfo] Q Type + handle name keyArg trailing typeFamilyName eqnsRaw = do + eqns <- lift $ mapM (substituteTrailingArgs trailing) eqnsRaw + let tableName = typeFamilyTableName typeFamilyName trailing + -- Deterministic and named after the table, so that repeated use sites of one + -- family agree on it rather than each declaring their own. + let name' = mkName (tableName <> "'") + alreadyDeclared <- lift $ do + inScope <- isJust <$> lookupTypeName (tableName <> "'") + EmittedFamilyTables emitted <- fromMaybe (EmittedFamilyTables mempty) <$> getQ + case inScope || S.member tableName emitted of + True -> return True + False -> do + putQ (EmittedFamilyTables (S.insert tableName emitted)) + return False f <- lift $ newName "f" #if MIN_VERSION_template_haskell(2,21,0) @@ -52,19 +78,19 @@ transformTypeFamilies eo@(ExtraTypeScriptOptions {..}) (AppT (ConT name) typ) #else let inst1 = DataD [] name' [PlainTV f] Nothing [] [] #endif - tell [ExtraTopLevelDecs [inst1]] + unless alreadyDeclared $ tell [ExtraTopLevelDecs [inst1]] imageTypes <- lift $ getClosedTypeFamilyImage eqns inst2 <- lift $ [d|instance (Typeable g, TypeScript g) => TypeScript ($(conT name') g) where - getTypeScriptType _ = $(TH.stringE $ nameBase name) <> "[" <> (getTypeScriptType (Proxy :: Proxy g)) <> "]" - getTypeScriptDeclarations _ = [$(getClosedTypeFamilyInterfaceDecl name eqns)] + getTypeScriptType _ = $(TH.stringE tableName) <> "[" <> (getTypeScriptType (Proxy :: Proxy g)) <> "]" + getTypeScriptDeclarations _ = [$(getClosedTypeFamilyInterfaceDecl' tableName eqns)] getParentTypes _ = $(listE [ [|TSType (Proxy :: Proxy $(return x))|] | x <- imageTypes]) |] - tell [ExtraTopLevelDecs inst2] + unless alreadyDeclared $ tell [ExtraTopLevelDecs inst2] tell [ExtraParentType (AppT (ConT name') (ConT ''T))] - ret <- transformTypeFamilies eo (AppT (ConT name') typ) + ret <- transformTypeFamilies eo (AppT (ConT name') keyArg) tell [ExtraConstraint (AppT (ConT ''TypeScript) ret)] return ret transformTypeFamilies eo (AppT typ1 typ2) = AppT <$> transformTypeFamilies eo typ1 <*> transformTypeFamilies eo typ2 diff --git a/src/Data/Aeson/TypeScript/TypeManipulation.hs b/src/Data/Aeson/TypeScript/TypeManipulation.hs index 9462d49..d9e2e65 100644 --- a/src/Data/Aeson/TypeScript/TypeManipulation.hs +++ b/src/Data/Aeson/TypeScript/TypeManipulation.hs @@ -12,6 +12,7 @@ module Data.Aeson.TypeScript.TypeManipulation ( import Control.Monad.Writer import Data.Aeson.TypeScript.Types +import Data.Aeson.TypeScript.Util (splitAppsT, typeFamilyTableName) import qualified Data.List as L import Language.Haskell.TH @@ -21,16 +22,15 @@ import Data.Monoid searchForConstraints :: ExtraTypeScriptOptions -> Type -> Name -> WriterT [GenericInfo] Q () -searchForConstraints eo@(ExtraTypeScriptOptions {..}) (AppT (ConT name) typ) var - | typ == VarT var && (name `L.elem` typeFamiliesToMapToTypeScript) = lift (reify name) >>= \case - FamilyI (ClosedTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _) _) _ -> do - tell [GenericInfo var (TypeFamilyKey typeFamilyName)] - searchForConstraints eo typ var - FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) _ -> do - tell [GenericInfo var (TypeFamilyKey typeFamilyName)] - searchForConstraints eo typ var - _ -> searchForConstraints eo typ var - | otherwise = searchForConstraints eo typ var +searchForConstraints eo@(ExtraTypeScriptOptions {..}) typ var + | (ConT name, VarT keyVar : trailing) <- splitAppsT typ + , keyVar == var + , name `L.elem` typeFamiliesToMapToTypeScript = lift (reify name) >>= \case + FamilyI (ClosedTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _) _) _ -> + tell [GenericInfo var (TypeFamilyKey (typeFamilyTableName typeFamilyName trailing))] + FamilyI (OpenTypeFamilyD (TypeFamilyHead typeFamilyName _ _ _)) _ -> + tell [GenericInfo var (TypeFamilyKey (typeFamilyTableName typeFamilyName trailing))] + _ -> return () searchForConstraints eo (AppT typ1 typ2) var = searchForConstraints eo typ1 var >> searchForConstraints eo typ2 var searchForConstraints eo (SigT typ _) var = searchForConstraints eo typ var searchForConstraints eo (InfixT typ1 _ typ2) var = searchForConstraints eo typ1 var >> searchForConstraints eo typ2 var @@ -56,6 +56,6 @@ hasFreeTypeVariable (ImplicitParamT _ typ) = hasFreeTypeVariable typ hasFreeTypeVariable _ = False unifyGenericVariable :: [GenericInfo] -> String -unifyGenericVariable genericInfos = case [nameBase name | GenericInfo _ (TypeFamilyKey name) <- genericInfos] of +unifyGenericVariable genericInfos = case L.nub [name | GenericInfo _ (TypeFamilyKey name) <- genericInfos] of [] -> "" - names -> " extends keyof " <> (L.intercalate " & " names) + names -> " extends " <> (L.intercalate " & " ["keyof " <> n | n <- names]) diff --git a/src/Data/Aeson/TypeScript/Types.hs b/src/Data/Aeson/TypeScript/Types.hs index 3caffe3..344f37a 100644 --- a/src/Data/Aeson/TypeScript/Types.hs +++ b/src/Data/Aeson/TypeScript/Types.hs @@ -250,5 +250,5 @@ data GenericInfo = GenericInfo Name GenericInfoExtra deriving Show data GenericInfoExtra = NormalStar - | TypeFamilyKey Name + | TypeFamilyKey String deriving Show diff --git a/src/Data/Aeson/TypeScript/Util.hs b/src/Data/Aeson/TypeScript/Util.hs index 29bff97..3925da4 100644 --- a/src/Data/Aeson/TypeScript/Util.hs +++ b/src/Data/Aeson/TypeScript/Util.hs @@ -169,6 +169,33 @@ contentsTupleTypeSubstituted genericVariables ci = let fields = constructorField [x] -> mapType genericVariables x xs -> applyToArgsT (ConT $ tupleTypeName (L.length xs)) (fmap (mapType genericVariables) xs) +-- | Split a type application into its head and arguments. +splitAppsT :: Type -> (Type, [Type]) +splitAppsT = go [] + where + go acc (AppT f x) = go (x : acc) f + go acc (SigT t _) = go acc t + go acc (ParensT t) = go acc t + go acc t = (t, acc) + +-- | Name for the lookup interface a mapped type family produces. A family applied to its key +-- alone keeps the family's own name; one applied to further arguments gets them appended, so +-- that two use sites of the same family don't share a table. +typeFamilyTableName :: Name -> [Type] -> String +typeFamilyTableName famName trailingArgs = nameBase famName <> concatMap typeNameFragment trailingArgs + +typeNameFragment :: Type -> String +typeNameFragment (ConT n) = nameBase n +typeNameFragment (VarT n) = nameBase n +typeNameFragment (PromotedT n) = nameBase n +typeNameFragment (SigT t _) = typeNameFragment t +typeNameFragment (ParensT t) = typeNameFragment t +typeNameFragment (AppT f x) = typeNameFragment f <> typeNameFragment x +typeNameFragment ListT = "List" +typeNameFragment (TupleT 0) = "Unit" +typeNameFragment (TupleT n) = "Tuple" <> show n +typeNameFragment _ = "" + mapType :: [(Name, (Suffix, Var))] -> Type -> Type mapType g x@(VarT name) = tryPromote x g name mapType g x@(ConT name) = tryPromote x g name diff --git a/test/Spec.hs b/test/Spec.hs index 11e0626..63f043f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -24,6 +24,7 @@ import qualified TwoElemArrayTagSingleConstructors import qualified UntaggedNoTagSingleConstructors import qualified UntaggedTagSingleConstructors import qualified UnwrapUnaryRecords +import qualified UseSiteFamilyImage main :: IO () @@ -50,3 +51,4 @@ main = hspec $ parallel $ do UntaggedNoTagSingleConstructors.tests UntaggedTagSingleConstructors.tests UnwrapUnaryRecords.allTests + UseSiteFamilyImage.tests diff --git a/test/UseSiteFamilyImage.hs b/test/UseSiteFamilyImage.hs new file mode 100644 index 0000000..c978723 --- /dev/null +++ b/test/UseSiteFamilyImage.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE UndecidableInstances #-} + +module UseSiteFamilyImage (tests) where + +import Data.Aeson as A +import Data.Aeson.TypeScript.Recursive +import Data.Aeson.TypeScript.TH +import Data.Aeson.TypeScript.Types +import Data.Kind (Type) +import Data.Proxy +import Data.String.Interpolate +import Prelude hiding (Double) +import Test.Hspec + + +-- A mode-indexed family: the result is one of the family's own arguments, so it has no image +-- on its own. The use site fixes those arguments, and then it does. +type family Chosen (f :: Type -> Type) x y where + Chosen Terse x y = x + Chosen Verbose x y = y + +data Terse (x :: Type) +instance TypeScript Terse where getTypeScriptType _ = "\"Terse\"" + +data Verbose (x :: Type) +instance TypeScript Verbose where getTypeScriptType _ = "\"Verbose\"" + +data Switched f = Switched { + switchedThing :: Chosen f Int Bool + , switchedPlain :: Bool + } +$(deriveTypeScript' A.defaultOptions ''Switched (defaultExtraTypeScriptOptions { typeFamiliesToMapToTypeScript = [''Chosen] })) + +-- Two use sites of the same family in one record, so the tables need distinct names. +data TwoSited f = TwoSited { + twoSitedFirst :: Chosen f Int Bool + , twoSitedSecond :: Chosen f Char Int + } +$(deriveTypeScript' A.defaultOptions ''TwoSited (defaultExtraTypeScriptOptions { typeFamiliesToMapToTypeScript = [''Chosen] })) + + +tests :: SpecWith () +tests = describe "Use-site type family image" $ do + it [i|makes one generic declaration, indexed on the mode|] $ do + (getTypeScriptDeclarations (Proxy :: Proxy (Switched Terse))) `shouldBe` ([ + TSTypeAlternatives "Switched" ["T extends keyof ChosenIntBool"] ["ISwitched"] Nothing + , TSInterfaceDeclaration "ISwitched" ["T extends keyof ChosenIntBool"] [ + TSField False "switchedThing" "ChosenIntBool[T]" Nothing + , TSField False "switchedPlain" "boolean" Nothing + ] Nothing + ]) + + it [i|tabulates the family against the arguments the use site fixed|] $ do + (getTypeScriptDeclarationsRecursively (Proxy :: Proxy (Switched Terse))) `shouldBe` ([ + TSInterfaceDeclaration "ChosenIntBool" [] [ + TSField False "\"Terse\"" "number" Nothing + , TSField False "\"Verbose\"" "boolean" Nothing + ] Nothing + , TSInterfaceDeclaration "ISwitched" ["T extends keyof ChosenIntBool"] [ + TSField False "switchedThing" "ChosenIntBool[T]" Nothing + , TSField False "switchedPlain" "boolean" Nothing + ] Nothing + , TSTypeAlternatives "Switched" ["T extends keyof ChosenIntBool"] ["ISwitched"] Nothing + ]) + + it [i|renders each instantiation as the matching key, from the one declaration|] $ do + (getTypeScriptType (Proxy :: Proxy (Switched Terse))) `shouldBe` "Switched<\"Terse\">" + (getTypeScriptType (Proxy :: Proxy (Switched Verbose))) `shouldBe` "Switched<\"Verbose\">" + + it [i|gives each use site of one family its own table|] $ do + (getTypeScriptDeclarations (Proxy :: Proxy (TwoSited Terse))) `shouldBe` ([ + TSTypeAlternatives "TwoSited" ["T extends keyof ChosenIntBool & keyof ChosenCharInt"] ["ITwoSited"] Nothing + , TSInterfaceDeclaration "ITwoSited" ["T extends keyof ChosenIntBool & keyof ChosenCharInt"] [ + TSField False "twoSitedFirst" "ChosenIntBool[T]" Nothing + , TSField False "twoSitedSecond" "ChosenCharInt[T]" Nothing + ] Nothing + ]) + + +main :: IO () +main = hspec tests From ae73afc5c86a4ed68d95aa438feb0729d8902707 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Tue, 13 Oct 2026 18:05:33 -0700 Subject: [PATCH 2/5] Fixups --- src/Data/Aeson/TypeScript/Util.hs | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/src/Data/Aeson/TypeScript/Util.hs b/src/Data/Aeson/TypeScript/Util.hs index 3925da4..89e3acb 100644 --- a/src/Data/Aeson/TypeScript/Util.hs +++ b/src/Data/Aeson/TypeScript/Util.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} module Data.Aeson.TypeScript.Util where @@ -178,23 +178,21 @@ splitAppsT = go [] go acc (ParensT t) = go acc t go acc t = (t, acc) --- | Name for the lookup interface a mapped type family produces. A family applied to its key --- alone keeps the family's own name; one applied to further arguments gets them appended, so --- that two use sites of the same family don't share a table. +-- | Name for the lookup interface a mapped type family produces typeFamilyTableName :: Name -> [Type] -> String typeFamilyTableName famName trailingArgs = nameBase famName <> concatMap typeNameFragment trailingArgs - -typeNameFragment :: Type -> String -typeNameFragment (ConT n) = nameBase n -typeNameFragment (VarT n) = nameBase n -typeNameFragment (PromotedT n) = nameBase n -typeNameFragment (SigT t _) = typeNameFragment t -typeNameFragment (ParensT t) = typeNameFragment t -typeNameFragment (AppT f x) = typeNameFragment f <> typeNameFragment x -typeNameFragment ListT = "List" -typeNameFragment (TupleT 0) = "Unit" -typeNameFragment (TupleT n) = "Tuple" <> show n -typeNameFragment _ = "" + where + typeNameFragment :: Type -> String + typeNameFragment (ConT n) = nameBase n + typeNameFragment (VarT n) = nameBase n + typeNameFragment (PromotedT n) = nameBase n + typeNameFragment (SigT t _) = typeNameFragment t + typeNameFragment (ParensT t) = typeNameFragment t + typeNameFragment (AppT f x) = typeNameFragment f <> typeNameFragment x + typeNameFragment ListT = "List" + typeNameFragment (TupleT 0) = "Unit" + typeNameFragment (TupleT n) = "Tuple" <> show n + typeNameFragment _ = "" mapType :: [(Name, (Suffix, Var))] -> Type -> Type mapType g x@(VarT name) = tryPromote x g name From 4fef5605bbdc17618a7a98b4a571abae054e61fc Mon Sep 17 00:00:00 2001 From: thomasjm Date: Wed, 14 Oct 2026 02:46:28 -0700 Subject: [PATCH 3/5] Extend a test --- test/UseSiteFamilyImage.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/UseSiteFamilyImage.hs b/test/UseSiteFamilyImage.hs index c978723..cb70cd7 100644 --- a/test/UseSiteFamilyImage.hs +++ b/test/UseSiteFamilyImage.hs @@ -35,6 +35,7 @@ $(deriveTypeScript' A.defaultOptions ''Switched (defaultExtraTypeScriptOptions { data TwoSited f = TwoSited { twoSitedFirst :: Chosen f Int Bool , twoSitedSecond :: Chosen f Char Int + , twoSitedThird :: Chosen f Char Int } $(deriveTypeScript' A.defaultOptions ''TwoSited (defaultExtraTypeScriptOptions { typeFamiliesToMapToTypeScript = [''Chosen] })) @@ -73,6 +74,7 @@ tests = describe "Use-site type family image" $ do , TSInterfaceDeclaration "ITwoSited" ["T extends keyof ChosenIntBool & keyof ChosenCharInt"] [ TSField False "twoSitedFirst" "ChosenIntBool[T]" Nothing , TSField False "twoSitedSecond" "ChosenCharInt[T]" Nothing + , TSField False "twoSitedThird" "ChosenCharInt[T]" Nothing ] Nothing ]) From 2d7d0592ffec2c4c0b1a15a17f1ef7b62950fe33 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Wed, 14 Oct 2026 02:51:38 -0700 Subject: [PATCH 4/5] Fixups --- src/Data/Aeson/TypeScript/Lookup.hs | 36 +++++--------------------- src/Data/Aeson/TypeScript/Transform.hs | 36 +++++++++++++++++++++++--- 2 files changed, 39 insertions(+), 33 deletions(-) diff --git a/src/Data/Aeson/TypeScript/Lookup.hs b/src/Data/Aeson/TypeScript/Lookup.hs index 617ecd4..a785d3a 100644 --- a/src/Data/Aeson/TypeScript/Lookup.hs +++ b/src/Data/Aeson/TypeScript/Lookup.hs @@ -4,19 +4,23 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} -module Data.Aeson.TypeScript.Lookup where +module Data.Aeson.TypeScript.Lookup ( + deriveTypeScriptLookupType + + , getClosedTypeFamilyImage + , getClosedTypeFamilyInterfaceDecl' + ) + where import Control.Monad import Data.Aeson.TypeScript.Instances () import Data.Aeson.TypeScript.Types import Data.Function import qualified Data.List as L -import qualified Data.Map as M import Data.Proxy import Data.String.Interpolate import Language.Haskell.TH hiding (stringE) import Language.Haskell.TH.Datatype.TyVarBndr () -import Language.Haskell.TH.Datatype (applySubstitution) import qualified Language.Haskell.TH.Lib as TH @@ -35,32 +39,6 @@ deriveTypeScriptLookupType name declNameStr = do _ -> fail [i|Expected a closed type family; got #{info}|] --- | Fix a family's trailing arguments to the types a use site applies it to, so that an --- equation whose result is one of those arguments gets a concrete result. --- --- @Chosen f x y@, with @Chosen Terse x y = x@, has no image on its own. Applied to --- @Chosen f Int String@ it becomes @Chosen Terse Int String = Int@, which does. -substituteTrailingArgs :: [Type] -> TySynEqn -> Q TySynEqn -#if MIN_VERSION_template_haskell(2,15,0) -substituteTrailingArgs [] eqn = return eqn -substituteTrailingArgs args (TySynEqn bndrs lhs result) = case splitLhs lhs of - Just (famName, key : rest) | length rest == length args -> do - let substitution = M.fromList [(n, t) | (VarT n, t) <- zip rest args] - return $ TySynEqn Nothing (AppT (ConT famName) key) (applySubstitution substitution result) - _ -> return (TySynEqn bndrs lhs result) - where - splitLhs :: Type -> Maybe (Name, [Type]) - splitLhs (ConT n) = Just (n, []) - splitLhs (AppT f x) = do - (n, xs) <- splitLhs f - return (n, xs <> [x]) - splitLhs (SigT t _) = splitLhs t - splitLhs (ParensT t) = splitLhs t - splitLhs _ = Nothing -#else -substituteTrailingArgs _ eqn = return eqn -#endif - getClosedTypeFamilyInterfaceDecl :: Name -> [TySynEqn] -> Q Exp getClosedTypeFamilyInterfaceDecl name eqns = getClosedTypeFamilyInterfaceDecl' (nameBase name) eqns diff --git a/src/Data/Aeson/TypeScript/Transform.hs b/src/Data/Aeson/TypeScript/Transform.hs index 4b334f1..dd0d096 100644 --- a/src/Data/Aeson/TypeScript/Transform.hs +++ b/src/Data/Aeson/TypeScript/Transform.hs @@ -9,18 +9,20 @@ module Data.Aeson.TypeScript.Transform ( transformTypeFamilies ) where +import Control.Monad (unless) import Control.Monad.Writer import Data.Aeson.TypeScript.Lookup import Data.Aeson.TypeScript.Types import Data.Aeson.TypeScript.Util (splitAppsT, typeFamilyTableName) -import Control.Monad (unless) +import qualified Data.List as L +import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) import qualified Data.Set as S -import qualified Data.List as L import Data.Typeable import Language.Haskell.TH hiding (stringE) -import Language.Haskell.TH.Syntax (getQ, putQ) +import Language.Haskell.TH.Datatype (applySubstitution) import qualified Language.Haskell.TH.Lib as TH +import Language.Haskell.TH.Syntax (getQ, putQ) #if !MIN_VERSION_base(4,11,0) import Data.Monoid @@ -55,7 +57,7 @@ transformTypeFamilies eo@(ExtraTypeScriptOptions {..}) wholeType descend typ = return typ handle :: Name -> Type -> [Type] -> Name -> [TySynEqn] -> WriterT [ExtraDeclOrGenericInfo] Q Type - handle name keyArg trailing typeFamilyName eqnsRaw = do + handle _name keyArg trailing typeFamilyName eqnsRaw = do eqns <- lift $ mapM (substituteTrailingArgs trailing) eqnsRaw let tableName = typeFamilyTableName typeFamilyName trailing -- Deterministic and named after the table, so that repeated use sites of one @@ -103,3 +105,29 @@ transformTypeFamilies eo (AppKindT typ kind) = flip AppKindT kind <$> transformT transformTypeFamilies eo (ImplicitParamT s typ) = ImplicitParamT s <$> transformTypeFamilies eo typ #endif transformTypeFamilies _ typ = return typ + +-- | Fix a family's trailing arguments to the types a use site applies it to, so that an +-- equation whose result is one of those arguments gets a concrete result. +-- +-- @Chosen f x y@, with @Chosen Terse x y = x@, has no image on its own. Applied to +-- @Chosen f Int String@ it becomes @Chosen Terse Int String = Int@, which does. +substituteTrailingArgs :: [Type] -> TySynEqn -> Q TySynEqn +#if MIN_VERSION_template_haskell(2,15,0) +substituteTrailingArgs [] eqn = return eqn +substituteTrailingArgs args (TySynEqn bndrs lhs result) = case splitLhs lhs of + Just (famName, key : rest) | length rest == length args -> do + let substitution = M.fromList [(n, t) | (VarT n, t) <- zip rest args] + return $ TySynEqn Nothing (AppT (ConT famName) key) (applySubstitution substitution result) + _ -> return (TySynEqn bndrs lhs result) + where + splitLhs :: Type -> Maybe (Name, [Type]) + splitLhs (ConT n) = Just (n, []) + splitLhs (AppT f x) = do + (n, xs) <- splitLhs f + return (n, xs <> [x]) + splitLhs (SigT t _) = splitLhs t + splitLhs (ParensT t) = splitLhs t + splitLhs _ = Nothing +#else +substituteTrailingArgs _ eqn = return eqn +#endif From bdb4a9665ed9812a294d6e2067d3da1de98d9795 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Wed, 14 Oct 2026 02:52:34 -0700 Subject: [PATCH 5/5] Fixups --- src/Data/Aeson/TypeScript/Lookup.hs | 2 +- src/Data/Aeson/TypeScript/Transform.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Aeson/TypeScript/Lookup.hs b/src/Data/Aeson/TypeScript/Lookup.hs index a785d3a..64a8599 100644 --- a/src/Data/Aeson/TypeScript/Lookup.hs +++ b/src/Data/Aeson/TypeScript/Lookup.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} module Data.Aeson.TypeScript.Lookup ( deriveTypeScriptLookupType diff --git a/src/Data/Aeson/TypeScript/Transform.hs b/src/Data/Aeson/TypeScript/Transform.hs index dd0d096..6c3d3d7 100644 --- a/src/Data/Aeson/TypeScript/Transform.hs +++ b/src/Data/Aeson/TypeScript/Transform.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} module Data.Aeson.TypeScript.Transform (