diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,11 +1,18 @@ # Changelog for purescript-tsd-gen -## 0.2.0.0 +## 0.3.0.0 (2019-06-22) +* Works with PureScript v0.13.0. +* Support `Foreign.Object.Object` from [purescript-foreign-object](https://github.com/purescript/purescript-foreign-object). +* Support `Effect.Uncurried` from purescript-effect. +* Add `--version` option. + +## 0.2.0.0 (2018-06-08) + * Support for PureScript v0.12.0. * Support `Data.Variant.Variant` from [purescript-variant](https://github.com/natefaubion/purescript-variant). * Support `Data.Nullable.Nullable` from [purescript-nullable](https://github.com/purescript-contrib/purescript-nullable). -## 0.1.0.0 +## 0.1.0.0 (2018-02-19) Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -75,21 +75,29 @@ Some modules get special handling: - `Data.Function.Uncurried` - - `Fn0 r` --> `() => r` - - `Fn2 a0 a1 r` --> `(_0: a0, _1: a2) => r` - - `Fn3 a0 a1 a2 r` --> `(_0: a0, _1: a1, _2: a2) => r` - - ... - - `Fn10 a0 a1 .. a9 r` --> `(_0: a0, ..., _9: a9) => r` -- `Effect` - - `Effect a` -> `() => a` -- `Control.Monad.Eff` - - `Eff e r` -> `() => r` -- `Data.StrMap.StrMap` - - `StrMap t` --> `{[_: string]: t}` + - `Fn0 r` --> `() => r` + - `Fn2 a0 a1 r` --> `(_0: a0, _1: a2) => r` + - `Fn3 a0 a1 a2 r` --> `(_0: a0, _1: a1, _2: a2) => r` + - ... + - `Fn10 a0 a1 ... a9 r` --> `(_0: a0, _1: a1, ..., _9: a9) => r` +- `Effect` (from [purescript-effect](https://github.com/purescript/purescript-effect)) + - `Effect a` -> `() => a` +- `Effect.Uncurried` (from purescript-effect) + - `EffectFn1 a0 r ` -> `(_0: a0) => r` + - `EffectFn2 a0 a1 r` -> `(_0: a0, _1: a1) => r` + - `EffectFn3 a0 a1 a2 r` -> `(_0: a0, _1: a1, _2: a2) => r` + - ... + - `EffectFn10 a0 a1 ... a9 r` -> `(_0: a0, _1: a1, ..., _9: a9) => r` - `Data.Variant` (from [purescript-variant](https://github.com/natefaubion/purescript-variant)) - - `Variant (tag1 :: Type1, tag2 :: Type2)` --> `{type: "tag1", value: Type1} | {type: "tag2", value: Type2}` + - `Variant (tag1 :: Type1, tag2 :: Type2)` --> `{type: "tag1", value: Type1} | {type: "tag2", value: Type2}` - `Data.Nullable` (from [purescript-nullable](https://github.com/purescript-contrib/purescript-nullable)) - - `Nullable a` --> `a | null` + - `Nullable a` --> `a | null` +- `Foreign.Object` (from [purescript-foreign-object](https://github.com/purescript/purescript-foreign-object)) + - `Object t` --> `{[_: string]: t}` +- `Control.Monad.Eff` (deprecated) + - `Eff e r` -> `() => r` +- `Data.StrMap` (deprecated) + - `StrMap t` --> `{[_: string]: t}` ## User-defined Data Types diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -16,6 +16,7 @@ import System.FilePath (()) import System.Directory (createDirectoryIfMissing,listDirectory) import Options.Applicative +import qualified Language.PureScript (version) import Language.PureScript.Externs import Language.PureScript.Environment import Language.PureScript.Names @@ -41,12 +42,12 @@ data TsdOutput = TsdOutputDirectory FilePath | StdOutput | SameAsInput -data PursTsdGen = PursTsdGen - { pursOutputDirectory :: FilePath - , tsdOutput :: TsdOutput - , importAll :: Bool - , moduleNames :: [String] - } +data PursTsdGen = PursTsdGen { pursOutputDirectory :: FilePath + , tsdOutput :: TsdOutput + , importAll :: Bool + , moduleNames :: [String] + } + | ShowVersion tsdOutputParser :: Parser TsdOutput tsdOutputParser = (TsdOutputDirectory <$> strOption (long "tsd-directory" <> metavar "" <> help "Where to write .d.ts files; same as --directory by default")) @@ -59,6 +60,7 @@ <*> tsdOutputParser <*> switch (long "import-all" <> help "Import dependent modules even if not referenced") <*> (many (strArgument (metavar "" <> help "List of modules to export (all if omitted). Glob-like patterns '*' and '**' are parsed."))) + <|> flag' ShowVersion (long "version" <> short 'v' <> help "Show version") -- | -- >>> filter (testModuleGlob "Foo.*") ["FooBar","Foo.Bar","Foo.Bar.Baz"] @@ -88,20 +90,25 @@ main :: IO () main = do - PursTsdGen{..} <- execParser opts - allModules <- listDirectory pursOutputDirectory - let selectedModules = case moduleNames of - [] -> allModules - _ -> let (patterns,literals) = List.partition isGlobPattern moduleNames - in List.nub $ filter (\t -> any (flip testModuleGlob t) patterns) allModules ++ literals - let tsdOutputDirectory = case tsdOutput of - TsdOutputDirectory dir -> Just dir - StdOutput -> Nothing - SameAsInput -> Just pursOutputDirectory - result <- runExceptT $ processModules pursOutputDirectory tsdOutputDirectory selectedModules importAll - case result of - Left err -> hPutStr stderr (show err) -- TODO: Better error handling - Right _ -> return () + p <- execParser opts + case p of + PursTsdGen{..} -> do + allModules <- listDirectory pursOutputDirectory + let selectedModules = case moduleNames of + [] -> allModules + _ -> let (patterns,literals) = List.partition isGlobPattern moduleNames + in List.nub $ filter (\t -> any (flip testModuleGlob t) patterns) allModules ++ literals + let tsdOutputDirectory = case tsdOutput of + TsdOutputDirectory dir -> Just dir + StdOutput -> Nothing + SameAsInput -> Just pursOutputDirectory + result <- runExceptT $ processModules pursOutputDirectory tsdOutputDirectory selectedModules importAll + case result of + Left err -> hPutStr stderr (show err) -- TODO: Better error handling + Right _ -> return () + ShowVersion -> do + putStrLn $ "purs-tsd-gen " <> showVersion version + <> " (works with purescript " <> showVersion Language.PureScript.version <> ")" where opts = info (pursTsdGen <**> helper) (fullDesc diff --git a/purescript-tsd-gen.cabal b/purescript-tsd-gen.cabal --- a/purescript-tsd-gen.cabal +++ b/purescript-tsd-gen.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 1aedd6caf4264346ee5c05b61e9cafec76a70631574a1ea5be5042588780f16f +-- hash: 287b1661719991819e5751d4564b07dbeb5b78f004d95ea30b63b2a134487e21 name: purescript-tsd-gen -version: 0.2.0.0 +version: 0.3.0.0 synopsis: TypeScript Declaration File (.d.ts) generator for PureScript description: Please see the README on Github at category: Language @@ -13,14 +15,13 @@ bug-reports: https://github.com/minoki/purescript-tsd-gen/issues author: ARATA Mizuki maintainer: ARATA Mizuki -copyright: 2018 ARATA Mizuki +copyright: 2018-2019 ARATA Mizuki license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 extra-source-files: - ChangeLog.md README.md + ChangeLog.md source-repository head type: git @@ -37,7 +38,7 @@ , directory , filepath , mtl - , purescript >=0.12.0 + , purescript ==0.13.0 , text exposed-modules: Language.PureScript.TsdGen.Module @@ -60,7 +61,7 @@ , filepath , mtl , optparse-applicative - , purescript >=0.12.0 + , purescript ==0.13.0 , purescript-tsd-gen , text other-modules: diff --git a/src/Language/PureScript/TsdGen/Module.hs b/src/Language/PureScript/TsdGen/Module.hs --- a/src/Language/PureScript/TsdGen/Module.hs +++ b/src/Language/PureScript/TsdGen/Module.hs @@ -74,7 +74,7 @@ emitInterface :: Text -> [Text] -> [Field] -> ModuleWriter () emitInterface name tyParams fields = do let tyParamsText | null tyParams = mempty - | otherwise = "<" <> TB.fromText (T.intercalate ", " $ map properToJs tyParams) <> ">" + | otherwise = "<" <> TB.fromText (T.intercalate ", " $ map anyNameToJs tyParams) <> ">" tell $ "interface " <> TB.fromText name <> tyParamsText <> " {\n" <> TB.fromText (T.concat (map (\f -> " " <> showField f <> ";\n") fields)) <> "}\n" emitTypeDeclaration :: Maybe Text -> Text -> [Text] -> TSType -> ModuleWriter () @@ -83,7 +83,7 @@ Just commentText -> "/*" <> TB.fromText commentText <> "*/ " Nothing -> mempty let tyParamsText | null tyParams = mempty - | otherwise = "<" <> TB.fromText (T.intercalate ", " $ map properToJs tyParams) <> ">" + | otherwise = "<" <> TB.fromText (T.intercalate ", " $ map anyNameToJs tyParams) <> ">" tell $ "export type " <> commentPart <> TB.fromText name <> tyParamsText <> " = " <> TB.fromText (showTSType ty) <> ";\n" emitValueDeclaration :: Maybe Text -> Text -> TSType -> ModuleWriter () @@ -157,7 +157,7 @@ makeContext :: [Text] -> TypeTranslationContext ModuleWriter makeContext typeVariables = TypeTranslationContext typeVariables [] Nothing getModuleId env currentModuleName - pursTypeToTSTypeX :: [Text] -> Type -> ModuleWriter TSType + pursTypeToTSTypeX :: [Text] -> SourceType -> ModuleWriter TSType pursTypeToTSTypeX ctx ty = do e <- runExceptT $ runReaderT (pursTypeToTSType ty) (makeContext ctx) case e of @@ -220,7 +220,7 @@ -- Data.Unit emitTypeDeclaration (Just "builtin") "Unit" [] (TSRecord [(mkOptionalField "$$pursType" (TSStringLit "Data.Unit.Unit"))]) | qTypeName `List.elem` builtins -> do - pst <- pursTypeToTSTypeX typeParameters (foldl TypeApp (TypeConstructor qTypeName) (map TypeVar typeParameters)) + pst <- pursTypeToTSTypeX typeParameters (foldl (TypeApp nullSourceAnn) (TypeConstructor nullSourceAnn qTypeName) (map (TypeVar nullSourceAnn) typeParameters)) emitTypeDeclaration (Just "builtin") name typeParameters pst | otherwise -> do -- Foreign type: just use 'any' type. @@ -286,8 +286,8 @@ , Just (_synonymParams,_synonymType) <- Map.lookup qDictTypeName (typeSynonyms env) = do -- TODO: This code depends on the undocumented implementation-details... let {-synonymInstance = replaceAllTypeVars (zip (freeTypeVariables synonymType) edInstanceTypes) synonymType-} - dictTy = foldl TypeApp (TypeConstructor qDictTypeName) edInstanceTypes - desugaredInstanceType = quantify (foldr ConstrainedType dictTy constraints) + dictTy = foldl (TypeApp nullSourceAnn) (TypeConstructor nullSourceAnn qDictTypeName) edInstanceTypes + desugaredInstanceType = quantify (foldr (ConstrainedType nullSourceAnn) dictTy constraints) instanceTy <- pursTypeToTSTypeX [] desugaredInstanceType emitValueDeclaration (Just "instance") name instanceTy | otherwise = emitComment ("invalid instance declaration '" <> name <> "'") diff --git a/src/Language/PureScript/TsdGen/Types.hs b/src/Language/PureScript/TsdGen/Types.hs --- a/src/Language/PureScript/TsdGen/Types.hs +++ b/src/Language/PureScript/TsdGen/Types.hs @@ -63,7 +63,7 @@ qnUnit = Qualified (Just (moduleNameFromString "Data.Unit")) (ProperName "Unit") -- Data.Function.Uncurried -tyFn0, tyFn2, tyFn3, tyFn4, tyFn5, tyFn6, tyFn7, tyFn8, tyFn9, tyFn10 :: Type +tyFn0, tyFn2, tyFn3, tyFn4, tyFn5, tyFn6, tyFn7, tyFn8, tyFn9, tyFn10 :: SourceType modDataFunctionUncurried = Just (moduleNameFromString "Data.Function.Uncurried") qnFn0 = Qualified modDataFunctionUncurried (ProperName "Fn0") qnFn2 = Qualified modDataFunctionUncurried (ProperName "Fn2") @@ -75,48 +75,77 @@ qnFn8 = Qualified modDataFunctionUncurried (ProperName "Fn8") qnFn9 = Qualified modDataFunctionUncurried (ProperName "Fn9") qnFn10 = Qualified modDataFunctionUncurried (ProperName "Fn10") -tyFn0 = TypeConstructor qnFn0 -tyFn2 = TypeConstructor qnFn2 -tyFn3 = TypeConstructor qnFn3 -tyFn4 = TypeConstructor qnFn4 -tyFn5 = TypeConstructor qnFn5 -tyFn6 = TypeConstructor qnFn6 -tyFn7 = TypeConstructor qnFn7 -tyFn8 = TypeConstructor qnFn8 -tyFn9 = TypeConstructor qnFn9 -tyFn10 = TypeConstructor qnFn10 +tyFn0 = TypeConstructor nullSourceAnn qnFn0 +tyFn2 = TypeConstructor nullSourceAnn qnFn2 +tyFn3 = TypeConstructor nullSourceAnn qnFn3 +tyFn4 = TypeConstructor nullSourceAnn qnFn4 +tyFn5 = TypeConstructor nullSourceAnn qnFn5 +tyFn6 = TypeConstructor nullSourceAnn qnFn6 +tyFn7 = TypeConstructor nullSourceAnn qnFn7 +tyFn8 = TypeConstructor nullSourceAnn qnFn8 +tyFn9 = TypeConstructor nullSourceAnn qnFn9 +tyFn10 = TypeConstructor nullSourceAnn qnFn10 +-- Effect.Uncurried +tyEffectFn1, tyEffectFn2, tyEffectFn3, tyEffectFn4, tyEffectFn5, tyEffectFn6, tyEffectFn7, tyEffectFn8, tyEffectFn9, tyEffectFn10 :: SourceType +modEffectUncurried = Just (moduleNameFromString "Effect.Uncurried") +qnEffectFn1 = Qualified modEffectUncurried (ProperName "EffectFn1") +qnEffectFn2 = Qualified modEffectUncurried (ProperName "EffectFn2") +qnEffectFn3 = Qualified modEffectUncurried (ProperName "EffectFn3") +qnEffectFn4 = Qualified modEffectUncurried (ProperName "EffectFn4") +qnEffectFn5 = Qualified modEffectUncurried (ProperName "EffectFn5") +qnEffectFn6 = Qualified modEffectUncurried (ProperName "EffectFn6") +qnEffectFn7 = Qualified modEffectUncurried (ProperName "EffectFn7") +qnEffectFn8 = Qualified modEffectUncurried (ProperName "EffectFn8") +qnEffectFn9 = Qualified modEffectUncurried (ProperName "EffectFn9") +qnEffectFn10 = Qualified modEffectUncurried (ProperName "EffectFn10") +tyEffectFn1 = TypeConstructor nullSourceAnn qnEffectFn1 +tyEffectFn2 = TypeConstructor nullSourceAnn qnEffectFn2 +tyEffectFn3 = TypeConstructor nullSourceAnn qnEffectFn3 +tyEffectFn4 = TypeConstructor nullSourceAnn qnEffectFn4 +tyEffectFn5 = TypeConstructor nullSourceAnn qnEffectFn5 +tyEffectFn6 = TypeConstructor nullSourceAnn qnEffectFn6 +tyEffectFn7 = TypeConstructor nullSourceAnn qnEffectFn7 +tyEffectFn8 = TypeConstructor nullSourceAnn qnEffectFn8 +tyEffectFn9 = TypeConstructor nullSourceAnn qnEffectFn9 +tyEffectFn10 = TypeConstructor nullSourceAnn qnEffectFn10 + -- Data.StrMap (from purescript-maps) -- foreign import data StrMap :: Type -> Type qnStrMap = Qualified (Just (moduleNameFromString "Data.StrMap")) (ProperName "StrMap") -tyStrMap :: Type -tyStrMap = TypeConstructor qnStrMap +tyStrMap :: SourceType +tyStrMap = TypeConstructor nullSourceAnn qnStrMap -- Control.Monad.Eff -- foreign import data Eff :: # Effect -> Type -> Type -tyEff = TypeConstructor (Qualified (Just (moduleNameFromString "Control.Monad.Eff")) (ProperName "Eff")) +tyEff = TypeConstructor nullSourceAnn (Qualified (Just (moduleNameFromString "Control.Monad.Eff")) (ProperName "Eff")) -- Effect (from purescript-effect) -- foreign import data Effect :: Type -> Type qnEffect = Qualified (Just (moduleNameFromString "Effect")) (ProperName "Effect") -tyEffect = TypeConstructor qnEffect +tyEffect = TypeConstructor nullSourceAnn qnEffect -- Data.Variant (from purescript-variant) -- foreign import data Variant :: # Type -> Type -tyVariant = TypeConstructor (Qualified (Just (moduleNameFromString "Data.Variant")) (ProperName "Variant")) +tyVariant = TypeConstructor nullSourceAnn (Qualified (Just (moduleNameFromString "Data.Variant")) (ProperName "Variant")) -- Data.Nullable (from purescript-nullable) -- foreign import data Nullable :: Type -> Type qnNullable = Qualified (Just (moduleNameFromString "Data.Nullable")) (ProperName "Nullable") -tyNullable = TypeConstructor qnNullable +tyNullable = TypeConstructor nullSourceAnn qnNullable -constraintToType :: Constraint -> Type -constraintToType ct = foldl TypeApp (TypeConstructor qDictTypeName) (constraintArgs ct) +-- Foreign.Object (from purescript-foreign-object) +-- foreign import data Object :: Type -> Type +qnForeignObject = Qualified (Just (moduleNameFromString "Foreign.Object")) (ProperName "Object") +tyForeignObject = TypeConstructor nullSourceAnn qnForeignObject + +constraintToType :: SourceConstraint -> SourceType +constraintToType ct = foldl (TypeApp nullSourceAnn) (TypeConstructor nullSourceAnn qDictTypeName) (constraintArgs ct) where qDictTypeName = fmap coerceProperName (constraintClass ct) data TypeTranslationContext f = TypeTranslationContext { ttcBoundTyVars :: [Text] , ttcUnboundTyVars :: [Text] - , ttcScopedVarKinds :: Maybe [(Text,Kind)] + , ttcScopedVarKinds :: Maybe [(Text,SourceKind)] , ttcGetModuleId :: ModuleName -> f (Maybe Text) , ttcEnvironment :: Environment , ttcCurrentModuleName :: ModuleName @@ -124,73 +153,73 @@ type TypeTranslationT f = ReaderT (TypeTranslationContext f) (ExceptT MultipleErrors f) -tsFunction :: forall f. Monad f => (Type -> TypeTranslationT f TSType) -> [Type] -> Type -> TypeTranslationT f TSType +tsFunction :: forall f. Monad f => (SourceType -> TypeTranslationT f TSType) -> [SourceType] -> SourceType -> TypeTranslationT f TSType tsFunction go args ret = do unbound <- asks ttcUnboundTyVars withReaderT (\r -> r { ttcBoundTyVars = ttcBoundTyVars r ++ unbound, ttcUnboundTyVars = [] }) $ TSFunction unbound <$> traverse go args <*> go ret -pursTypeToTSType :: forall f. Monad f => Type -> TypeTranslationT f TSType +pursTypeToTSType :: forall f. Monad f => SourceType -> TypeTranslationT f TSType pursTypeToTSType = go where - go :: Type -> TypeTranslationT f TSType - go (TypeApp (TypeApp tcon a0) r) - | tcon == tyFunction = tsFunction go [a0] r + go :: SourceType -> TypeTranslationT f TSType + go (TypeApp _ (TypeApp _ tcon a0) r) + | tcon == tyFunction || tcon == tyEffectFn1 = tsFunction go [a0] r | tcon == tyEff = tsFunction go [] r - go (TypeApp (TypeApp (TypeApp tcon a0) a1) r) - | tcon == tyFn2 = tsFunction go [a0,a1] r - go (TypeApp (TypeApp (TypeApp (TypeApp tcon a0) a1) a2) r) - | tcon == tyFn3 = tsFunction go [a0,a1,a2] r - go (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp tcon a0) a1) a2) a3) r) - | tcon == tyFn4 = tsFunction go [a0,a1,a2,a3] r - go (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp tcon a0) a1) a2) a3) a4) r) - | tcon == tyFn5 = tsFunction go [a0,a1,a2,a3,a4] r - go (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp tcon a0) a1) a2) a3) a4) a5) r) - | tcon == tyFn6 = tsFunction go [a0,a1,a2,a3,a4,a5] r - go (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp tcon a0) a1) a2) a3) a4) a5) a6) r) - | tcon == tyFn7 = tsFunction go [a0,a1,a2,a3,a4,a5,a6] r - go (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp tcon a0) a1) a2) a3) a4) a5) a6) a7) r) - | tcon == tyFn8 = tsFunction go [a0,a1,a2,a3,a4,a5,a6,a7] r - go (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp tcon a0) a1) a2) a3) a4) a5) a6) a7) a8) r) - | tcon == tyFn9 = tsFunction go [a0,a1,a2,a3,a4,a5,a6,a7,a8] r - go (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp (TypeApp tcon a0) a1) a2) a3) a4) a5) a6) a7) a8) a9) r) - | tcon == tyFn10 = tsFunction go [a0,a1,a2,a3,a4,a5,a6,a7,a8,a9] r - go (TypeApp tcon a0) + go (TypeApp _ (TypeApp _ (TypeApp _ tcon a0) a1) r) + | tcon == tyFn2 || tcon == tyEffectFn2 = tsFunction go [a0,a1] r + go (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ tcon a0) a1) a2) r) + | tcon == tyFn3 || tcon == tyEffectFn3 = tsFunction go [a0,a1,a2] r + go (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ tcon a0) a1) a2) a3) r) + | tcon == tyFn4 || tcon == tyEffectFn4 = tsFunction go [a0,a1,a2,a3] r + go (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ tcon a0) a1) a2) a3) a4) r) + | tcon == tyFn5 || tcon == tyEffectFn5 = tsFunction go [a0,a1,a2,a3,a4] r + go (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ tcon a0) a1) a2) a3) a4) a5) r) + | tcon == tyFn6 || tcon == tyEffectFn6 = tsFunction go [a0,a1,a2,a3,a4,a5] r + go (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ tcon a0) a1) a2) a3) a4) a5) a6) r) + | tcon == tyFn7 || tcon == tyEffectFn7 = tsFunction go [a0,a1,a2,a3,a4,a5,a6] r + go (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ tcon a0) a1) a2) a3) a4) a5) a6) a7) r) + | tcon == tyFn8 || tcon == tyEffectFn8 = tsFunction go [a0,a1,a2,a3,a4,a5,a6,a7] r + go (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ tcon a0) a1) a2) a3) a4) a5) a6) a7) a8) r) + | tcon == tyFn9 || tcon == tyEffectFn9 = tsFunction go [a0,a1,a2,a3,a4,a5,a6,a7,a8] r + go (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ (TypeApp _ tcon a0) a1) a2) a3) a4) a5) a6) a7) a8) a9) r) + | tcon == tyFn10 || tcon == tyEffectFn10 = tsFunction go [a0,a1,a2,a3,a4,a5,a6,a7,a8,a9] r + go (TypeApp _ tcon a0) | tcon == tyArray = TSArray <$> go a0 - | tcon == tyStrMap = TSStrMap <$> go a0 + | tcon == tyStrMap || tcon == tyForeignObject = TSStrMap <$> go a0 | tcon == tyRecord = case rowToList a0 of - (pairs, _) -> TSRecord <$> traverse (\(label,ty) -> mkField label <$> go ty) pairs + (pairs, _) -> TSRecord <$> traverse (\(RowListItem { rowListLabel = label, rowListType = ty }) -> mkField label <$> go ty) pairs | tcon == tyFn0 = tsFunction go [] a0 | tcon == tyEffect = tsFunction go [] a0 | tcon == tyVariant = case rowToList a0 of - (pairs, _) -> TSUnion <$> traverse (\(label,ty) -> (\ty' -> TSRecord [mkField "type" (TSStringLit $ runLabel label), mkField "value" ty']) <$> go ty) pairs + (pairs, _) -> TSUnion <$> traverse (\(RowListItem { rowListLabel = label, rowListType = ty }) -> (\ty' -> TSRecord [mkField "type" (TSStringLit $ runLabel label), mkField "value" ty']) <$> go ty) pairs | tcon == tyNullable = (\ty -> TSUnion [ty, TSNull]) <$> go a0 - go ty@(ForAll name inner _) = getKindsIn ty $ \kinds -> + go ty@(ForAll _ name _kind inner _) = getKindsIn ty $ \kinds -> if List.lookup name kinds == Just kindType then withReaderT (\r -> r { ttcUnboundTyVars = name : ttcUnboundTyVars r }) (go inner) else go inner - go (TypeVar name) = do + go (TypeVar _ name) = do isBound <- asks (\r -> List.elem name (ttcBoundTyVars r)) if isBound then pure (TSTyVar name) else pure (TSUnknown $ T.pack $ "type variable " ++ T.unpack name) - go ty@(TypeConstructor _qName) + go ty@(TypeConstructor _ _qName) | ty == tyString = pure TSString | ty == tyChar = pure TSString | ty == tyNumber = pure TSNumber | ty == tyInt = pure TSNumber | ty == tyBoolean = pure TSBoolean - go ty@(TypeApp s t) = do + go ty@(TypeApp _ s t) = do s' <- go s t' <- go t case s' of TSNamed m n a -> pure (TSNamed m n (a ++ [t'])) _ -> pure (TSUnknown $ T.pack $ show ty) - go ty@(TypeConstructor (Qualified (Just (ModuleName [ProperName prim])) typeName)) | prim == C.prim = do + go ty@(TypeConstructor _ (Qualified (Just (ModuleName [ProperName prim])) typeName)) | prim == C.prim = do case typeName of ProperName "Partial" -> pure (TSUnknown "Prim.Partial") _ -> pure (TSUnknown $ T.pack $ show ty) - go ty@(TypeConstructor qName@(Qualified (Just moduleName) typeName)) = do + go ty@(TypeConstructor _ qName@(Qualified (Just moduleName) typeName)) = do ti <- asks (Map.lookup qName . types . ttcEnvironment) case ti of Just (k, _) | isSimpleKind k -> do @@ -198,10 +227,10 @@ moduleId <- lift (lift (getModuleId moduleName)) pure (TSNamed moduleId (runProperName typeName) []) _ -> pure (TSUnknown $ T.pack $ show ty) - go (ConstrainedType ct inner) = tsFunction go [constraintToType ct] inner + go (ConstrainedType _ ct inner) = tsFunction go [constraintToType ct] inner go ty = pure (TSUnknown $ T.pack $ show ty) - getKindsIn :: Type -> ([(Text,Kind)] -> TypeTranslationT f r) -> TypeTranslationT f r + getKindsIn :: SourceType -> ([(Text,SourceKind)] -> TypeTranslationT f r) -> TypeTranslationT f r getKindsIn ty m = do mkinds <- asks ttcScopedVarKinds case mkinds of @@ -229,7 +258,7 @@ where optionalMarker | fieldIsOptional field = "?" | otherwise = "" showField (NewSignature [] params result) = "new (" <> showFunctionParameters params <> "): " <> showTSType result -showField (NewSignature tp params result) = "new <" <> T.intercalate ", " (map properToJs tp) <> ">(" <> showFunctionParameters params <> "): " <> showTSType result +showField (NewSignature tp params result) = "new <" <> T.intercalate ", " (map anyNameToJs tp) <> ">(" <> showFunctionParameters params <> "): " <> showTSType result showFunctionParameters :: [TSType] -> Text showFunctionParameters [] = "" @@ -238,7 +267,7 @@ objectPropertyToString :: PSString -> Text objectPropertyToString ps = case decodeString ps of - Just t | not (identNeedsEscaping t) -> t + Just t | not (isValidJsIdentifier t) -> t _ -> prettyPrintStringJS ps isIdentifierStart, isIdentifierPart :: Char -> Bool @@ -260,7 +289,7 @@ TSBoolean -> "boolean" TSString -> "string" TSFunction [] params ret -> showParenIf (prec > 0) $ "(" <> showFunctionParameters params <> ") => " <> showTSType ret - TSFunction tp params ret -> showParenIf (prec > 0) $ "<" <> T.intercalate ", " (map properToJs tp) <> ">(" <> showFunctionParameters params <> ") => " <> showTSType ret + TSFunction tp params ret -> showParenIf (prec > 0) $ "<" <> T.intercalate ", " (map anyNameToJs tp) <> ">(" <> showFunctionParameters params <> ") => " <> showTSType ret TSArray elemTy -> "Array< " <> showTSType elemTy <> " >" -- TODO: Use ReadonlyArray? TSStrMap elemTy -> "{[_: string]: " <> showTSType elemTy <> "}" TSRecord [] -> "{}" @@ -269,9 +298,9 @@ TSStringLit s -> prettyPrintStringJS s TSUnion [] -> "never" -- uninhabitated type TSUnion members -> showParenIf (prec > 1) $ T.intercalate " | " (map (showTSTypePrec 1) members) - TSIntersection [] -> "{}" -- universal type + TSIntersection [] -> "{}" -- universal type. TODO: use 'unknown' type? TSIntersection members -> T.intercalate " & " (map (showTSTypePrec 2) members) - TSTyVar name -> properToJs name + TSTyVar name -> anyNameToJs name TSNamed moduleid name tyArgs -> mid <> name <> ta where mid | Just m <- moduleid = m <> "." | otherwise = "" @@ -281,25 +310,25 @@ TSCommented inner desc -> showTSTypePrec prec inner <> " /* " <> desc <> " */" -- SimpleKind :: (Type -> )* Type -isSimpleKind :: Kind -> Bool +isSimpleKind :: SourceKind -> Bool isSimpleKind k | k == kindType = True -isSimpleKind (FunKind s t) = s == kindType && isSimpleKind t +isSimpleKind (FunKind _ s t) = s == kindType && isSimpleKind t isSimpleKind _ = False -numberOfTypeParams :: Kind -> Int +numberOfTypeParams :: SourceKind -> Int numberOfTypeParams k | k == kindType = 0 -numberOfTypeParams (FunKind s t) | s == kindType = numberOfTypeParams t + 1 +numberOfTypeParams (FunKind _ s t) | s == kindType = numberOfTypeParams t + 1 numberOfTypeParams _ = 0 -- invalid -- LessSimpleKind :: (SimpleKind -> )* Type -isLessSimpleKind :: Kind -> Bool +isLessSimpleKind :: SourceKind -> Bool isLessSimpleKind k | k == kindType = True -isLessSimpleKind (FunKind s t) = isSimpleKind s && isLessSimpleKind t +isLessSimpleKind (FunKind _ s t) = isSimpleKind s && isLessSimpleKind t isLessSimpleKind _ = False -extractTypes :: Kind -> [(a,Maybe Kind)] -> Maybe [a] +extractTypes :: SourceKind -> [(a,Maybe SourceKind)] -> Maybe [a] extractTypes k [] | k == kindType = return [] -extractTypes (FunKind kind1 r) ((name,kind2):xs) +extractTypes (FunKind _ kind1 r) ((name,kind2):xs) | kind1 == kindType && (kind2 == Just kindType || kind2 == Nothing) = (name :) <$> extractTypes r xs | otherwise = extractTypes r xs -- ?? extractTypes _ _ = Nothing