purescript-tsd-gen (empty) → 0.1.0.0
raw patch · 8 files changed
+999/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, directory, filepath, mtl, optparse-applicative, purescript, purescript-tsd-gen, text
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +192/−0
- Setup.hs +2/−0
- app/Main.hs +109/−0
- purescript-tsd-gen.cabal +69/−0
- src/Language/PureScript/TsdGen/Module.hs +307/−0
- src/Language/PureScript/TsdGen/Types.hs +285/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for purescript-tsd-gen++## 0.1.0.0++Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright ARATA Mizuki (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of ARATA Mizuki nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,192 @@+# purescript-tsd-gen++This is a TypeScript Declaration File (.d.ts) generator for PureScript.++This tool helps you use PureScript modules from TypeScript.++# How to build++```sh+$ git clone https://github.com/minoki/purescript-tsd-gen.git+$ cd purescript-tsd-gen+$ stack install+```++# How to use++Assuming you have compiled PureScript modules into `./output`:++```sh+$ tree output/+output/+├── Control.Alt+│ ├── externs.json+│ └── index.js+├── Control.Alternative+│ ├── externs.json+│ └── index.js+...+└── YourFancyModuleInPurs+ ├── externs.json+ └── index.js+```++Run the following to get the declaration files:++```sh+$ purs-tsd-gen -d output/ YourFancyModuleInPurs+```++Now you get `index.d.ts` alongside each module's `index.js`:++```sh+$ tree output/+output/+├── Control.Alt+│ ├── externs.json+│ ├── index.d.ts+│ └── index.js+├── Control.Alternative+│ ├── externs.json+│ ├── index.d.ts+│ └── index.js+...+└── YourFancyModuleInPurs+ ├── externs.json+ ├── index.d.ts+ └── index.js+```++# Mapping of types++## Builtin++Primitive types translates as one would imagine:++- `Function s t` (`s -> t`) --> `(_: s) => t`+- `Array t` --> `Array<t>`+ - TODO: Add an option to emit `ReadonlyArray<t>`.+- `Record { key1 :: Type1, key2 :: Type2 }` --> `{ key1: Type1, key2: Type2 }`+ - TODO: Add an option to make fields `readonly`.+- `Number`, `Int` --> `number`+- `String`, `Char` --> `string`+- `Boolean` --> `boolean`++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`+- `Control.Monad.Eff`+ - `Eff e r` -> `() => r`+- `Data.StrMap.StrMap`+ - `StrMap t` --> `{[_: string]: t}`++## User-defined Data Types++Data type `SomeFancyDataType :: Type -> ... -> Type -> Type` is translated to `SomeFancyDataType<a0, ..., an>`.++In contrast to usual TypeScript's structual subtyping, the translated types mimicks nominal typing with extra dummy fields.++Sum types are translated to discriminated union types, with a dummy tag field. Type guards with `instanceof` should work.++Data constructors are typed as an object type with `new` signature and `create` or `value` field.++Types whose data constructors are not exposed, i.e. abstract types, are translated to an object type which contains `never` as a field, so that you cannot accidentally create a value of abstract types in TypeScript world.++Let's see some examples:++- Tuple++```purescript+data Tuple a b = Tuple a b+```++compiles to:++```typescript+export type /*data*/ Tuple<a, b> = Tuple$$Tuple< a, b >;+interface Tuple$$Tuple<a, b> {+ "$$pursType"?: "Data.Tuple.Tuple";+ "$$pursTag"?: "Tuple";+ value0: a;+ value1: b;+}+export const /*data ctor*/ Tuple: { create: <a, b>(_: a) => (_: b) => Tuple< a, b >; new <a, b>(_0: a, _1: b): Tuple$$Tuple< a, b > };+```++- Maybe++```purescript+data Maybe a = Nothing | Just a+```++compiles to:++```typescript+export type /*data*/ Maybe<a> = Maybe$$Nothing | Maybe$$Just< a >;+interface Maybe$$Nothing {+ "$$pursType": "Data.Maybe.Maybe";+ "$$pursTag": "Nothing";+}+export const /*data ctor*/ Nothing: { value: Maybe< any /* type variable a */ >; new (): Maybe$$Nothing };+interface Maybe$$Just<a> {+ "$$pursType": "Data.Maybe.Maybe";+ "$$pursTag": "Just";+ value0: a;+}+export const /*data ctor*/ Just: { create: <a>(_: a) => Maybe< a >; new <a>(_: a): Maybe$$Just< a > };+```++- Either++```purescript+data Either a b = Left a | Right b+```++compiles to:++```typescript+export type /*data*/ Either<a, b> = Either$$Left< a > | Either$$Right< b >;+interface Either$$Left<a> {+ "$$pursType": "Data.Either.Either";+ "$$pursTag": "Left";+ value0: a;+}+export const /*data ctor*/ Left: { create: <a, b>(_: a) => Either< a, b >; new <a>(_: a): Either$$Left< a > };+interface Either$$Right<b> {+ "$$pursType": "Data.Either.Either";+ "$$pursTag": "Right";+ value0: b;+}+export const /*data ctor*/ Right: { create: <a, b>(_: b) => Either< a, b >; new <b>(_: b): Either$$Right< b > };+```++## Newtypes++Newtypes are translated to a type synonym. The nominal property in PureScript is lost.++## `foreign import data`++`foreign import data` are translated to `any`.++Maybe there should be a way for PS-library authors to provide corresponding `.d.ts` for foreign JavaScript modules.++## Universally Quantified Types++Simple polymorphic functions translate to generic functions.++If the type is too complex, there may situations where the emitted declarations contain undue `any` type.++## Higher-Kinded Types++Not supported.++TODO: Investigate if we can reasonably emulate higher-kinded types in TypeScript.++## Type Classes++Need more work.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+module Main where+import Prelude hiding (elem,notElem,lookup)+import Data.Maybe+import Data.Monoid ((<>))+import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.Text.Lazy.IO as TL+import qualified Data.Text.Lazy.Builder as TB+import Control.Monad.State+import Control.Monad.Except+import System.IO (hPutStr,stderr)+import System.FilePath ((</>))+import System.Directory (createDirectoryIfMissing,listDirectory)+import Options.Applicative+import Language.PureScript.Externs+import Language.PureScript.Environment+import Language.PureScript.Names+import Language.PureScript.TsdGen.Module+import Data.Version (showVersion)+import Paths_purescript_tsd_gen (version)++processModules :: FilePath -> Maybe FilePath -> [String] -> Bool -> ExceptT ModuleProcessingError IO ()+processModules inputDir mOutputDir modules importAll = do+ let loadOneModule = recursivelyLoadExterns inputDir . moduleNameFromString . T.pack+ -- TODO: Check efVersion+ (env,m) <- execStateT (mapM_ loadOneModule modules) (initEnvironment, Map.empty)+ forM_ (catMaybes $ Map.elems m) $ \ef -> do+ let moduleName = runModuleName (efModuleName ef)+ modTsd <- processLoadedModule env ef importAll+ liftIO $ case mOutputDir of+ Just outputDir -> do+ let moduleDir = outputDir </> T.unpack moduleName+ createDirectoryIfMissing True moduleDir+ TL.writeFile (moduleDir </> "index.d.ts") (TB.toLazyText modTsd)+ Nothing -> do -- write to stdout+ TL.putStr (TB.toLazyText modTsd)++data TsdOutput = TsdOutputDirectory FilePath | StdOutput | SameAsInput++data PursTsdGen = PursTsdGen+ { pursOutputDirectory :: FilePath+ , tsdOutput :: TsdOutput+ , importAll :: Bool+ , moduleNames :: [String]+ }++tsdOutputParser :: Parser TsdOutput+tsdOutputParser = (TsdOutputDirectory <$> strOption (long "tsd-directory" <> metavar "<dir>" <> help "Where to write .d.ts files; same as --directory by default"))+ <|> flag' StdOutput (long "stdout" <> help "Write to stdout (for dry-run)")+ <|> pure SameAsInput++pursTsdGen :: Parser PursTsdGen+pursTsdGen = PursTsdGen+ <$> strOption (long "directory" <> short 'd' <> metavar "<dir>" <> help "PureScript's output directory (typically ./output)")+ <*> tsdOutputParser+ <*> switch (long "import-all" <> help "Import dependent modules even if not referenced")+ <*> (many (strArgument (metavar "<modules>" <> help "List of modules to export (all if omitted). Glob-like patterns '*' and '**' are parsed.")))++-- |+-- >>> filter (testModuleGlob "Foo.*") ["FooBar","Foo.Bar","Foo.Bar.Baz"]+-- ["Foo.Bar"]+-- >>> filter (testModuleGlob "Foo*") ["Foo.Bar","FooBar"]+-- ["FooBar"]+-- >>> filter (testModuleGlob "Foo*Bar") ["FooBar","FooBazBar","FooBaz.Bar"]+-- ["FooBar","FooBazBar"]+-- >>> filter (testModuleGlob "Foo**Bar") ["FooBar","FooBazBar","FooBaz.Bar"]+-- ["FooBar","FooBazBar","FooBaz.Bar"]+testModuleGlob :: String -> String -> Bool+testModuleGlob [] [] = True+-- '**': wildcard, including '.'+testModuleGlob ('*':'*':xs) s = any (testModuleGlob xs) (List.tails s)+-- '*': wildcard, not including '.'+testModuleGlob ('*':xs) s = any (testModuleGlob xs) (tails' s)+ where+ tails' :: String -> [String]+ tails' [] = [[]]+ tails' t@(y:ys) | y == '.' = [t]+ | otherwise = t : tails' ys+testModuleGlob (x:xs) (y:ys) | x == y = testModuleGlob xs ys+testModuleGlob _ _ = False++isGlobPattern :: String -> Bool+isGlobPattern = List.elem '*'++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 ()+ where+ opts = info (pursTsdGen <**> helper)+ (fullDesc+ <> progDesc "Generate .d.ts files for PureScript modules"+ <> header ("purs-tsd-gen " <> showVersion version <> " - .d.ts generator for PureScript"))
+ purescript-tsd-gen.cabal view
@@ -0,0 +1,69 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4c7dc0f1a89f41905e8219c5421e4ecc369cef143207028e98886b4720c92c02++name: purescript-tsd-gen+version: 0.1.0.0+synopsis: TypeScript Declaration File (.d.ts) generator for PureScript+description: Please see the README on Github at <https://github.com/minoki/purescript-tsd-gen#readme>+category: Language+homepage: https://github.com/minoki/purescript-tsd-gen#readme+bug-reports: https://github.com/minoki/purescript-tsd-gen/issues+author: ARATA Mizuki <minorinoki@gmail.com>+maintainer: ARATA Mizuki <minorinoki@gmail.com>+copyright: 2018 ARATA Mizuki+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/minoki/purescript-tsd-gen++library+ hs-source-dirs:+ src+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , containers+ , directory+ , filepath+ , mtl+ , purescript+ , text+ exposed-modules:+ Language.PureScript.TsdGen.Module+ Language.PureScript.TsdGen.Types+ other-modules:+ Paths_purescript_tsd_gen+ default-language: Haskell2010++executable purs-tsd-gen+ main-is: Main.hs+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , containers+ , directory+ , filepath+ , mtl+ , optparse-applicative+ , purescript+ , purescript-tsd-gen+ , text+ other-modules:+ Paths_purescript_tsd_gen+ default-language: Haskell2010
+ src/Language/PureScript/TsdGen/Module.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+module Language.PureScript.TsdGen.Module where+import Prelude hiding (elem,notElem,lookup)+import Data.Maybe+import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.ByteString.Lazy as BS+import qualified Data.Aeson as JSON+import Control.Arrow (first,second)+import Control.Monad.State+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.RWS.Strict+import System.FilePath ((</>))+import Language.PureScript.Externs+import Language.PureScript.Environment+import Language.PureScript.Types+import Language.PureScript.Names+import Language.PureScript.Label+import Language.PureScript.Errors+import Language.PureScript.PSString+import Language.PureScript.Pretty.Kinds+import Language.PureScript.CodeGen.JS.Common+import qualified Language.PureScript.Constants as C+import Language.PureScript.TsdGen.Types+import Data.Version (showVersion)+import Paths_purescript_tsd_gen (version)++data ModuleProcessingError = FileReadError+ | JSONDecodeError String FilePath+ | PursTypeError ModuleName MultipleErrors+ deriving (Show)++data ModuleImport = ModuleImport { moduleImportIdent :: Maybe Text+ }++type ModuleImportMap = Map.Map ModuleName ModuleImport++type ModuleWriter = RWST () TB.Builder ModuleImportMap (ExceptT ModuleProcessingError IO)++readExternsForModule :: FilePath -> ModuleName -> ExceptT ModuleProcessingError IO ExternsFile+readExternsForModule dir moduleName = do+ let moduleNameText = T.unpack (runModuleName moduleName)+ externsPath = dir </> moduleNameText </> "externs.json"+ s <- liftIO $ BS.readFile externsPath+ case JSON.eitherDecode s of+ Left err -> throwError (JSONDecodeError err externsPath)+ Right result -> return result++recursivelyLoadExterns :: FilePath -> ModuleName -> StateT (Environment, Map.Map ModuleName (Maybe ExternsFile)) (ExceptT ModuleProcessingError IO) ()+recursivelyLoadExterns dir moduleName+ | moduleName == ModuleName [ProperName C.prim] = return ()+ | otherwise = do+ ef <- lift (readExternsForModule dir moduleName)+ modify (second (Map.insert moduleName (Just ef)))+ let imports = efImports ef+ forM_ (map eiModule imports) $ \importModuleName -> do+ alreadyLoading <- gets (Map.member importModuleName . snd)+ unless alreadyLoading $ do+ modify (second (Map.insert importModuleName Nothing))+ recursivelyLoadExterns dir importModuleName+ modify (first (applyExternsFileToEnvironment ef))++emitComment :: Text -> ModuleWriter ()+emitComment t = tell ("// " <> TB.fromText t <> "\n")++emitInterface :: Text -> [Text] -> [Field] -> ModuleWriter ()+emitInterface name tyParams fields = do+ let tyParamsText | null tyParams = mempty+ | otherwise = "<" <> TB.fromText (T.intercalate ", " $ map properToJs 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 ()+emitTypeDeclaration comment name tyParams ty = do+ let commentPart = case comment of+ Just commentText -> "/*" <> TB.fromText commentText <> "*/ "+ Nothing -> mempty+ let tyParamsText | null tyParams = mempty+ | otherwise = "<" <> TB.fromText (T.intercalate ", " $ map properToJs tyParams) <> ">"+ tell $ "export type " <> commentPart <> TB.fromText name <> tyParamsText <> " = " <> TB.fromText (showTSType ty) <> ";\n"++emitValueDeclaration :: Maybe Text -> Text -> TSType -> ModuleWriter ()+emitValueDeclaration comment name ty+ | nameIsJsReserved name = do+ let jsName = "$$" <> TB.fromText name+ tell $ "declare const " <> jsName <> ": " <> TB.fromText (showTSType ty) <> ";\nexport " <> commentPart <> "{ " <> jsName <> " as " <> TB.fromText name <> " };\n"+ | isIdentifierName name = do+ tell $ "export const " <> commentPart <> TB.fromText name <> ": " <> TB.fromText (showTSType ty) <> ";\n"+ | otherwise = do+ -- As of PureScript 0.11.7, the compiler emits symbols that contain prime symbol `'`;+ -- Such identifiers cannot be used in ES6 modules.+ -- See: https://github.com/purescript/purescript/issues/2558+ tell $ "// The identifier \"" <> TB.fromText name <> "\" cannot be expressed in JavaScript:\n// export const " <> commentPart <> TB.fromText name <> ": " <> TB.fromText (showTSType ty) <> ";\n"+ where commentPart = case comment of+ Just commentText -> "/*" <> TB.fromText commentText <> "*/ "+ Nothing -> mempty++emitNamespaceImport :: Monad m => Text -> ModuleName -> WriterT TB.Builder m ()+emitNamespaceImport ident moduleName = tell $ "import * as " <> TB.fromText ident <> " from \"../" <> TB.fromText (runModuleName moduleName) <> "\";\n"++emitImport :: Monad m => ModuleName -> WriterT TB.Builder m ()+emitImport moduleName = tell $ "import \"../" <> TB.fromText (runModuleName moduleName) <> "\";\n"++processLoadedModule :: Environment -> ExternsFile -> Bool -> ExceptT ModuleProcessingError IO TB.Builder+processLoadedModule env ef importAll = execWriterT $ do+ tell $ "// module " <> TB.fromText (runModuleName currentModuleName) <> ", generated by purescript-tsd-gen " <> TB.fromString (showVersion version) <> "\n"+ (moduleImportMap, moduleBody) <- lift (execRWST (mapM_ processDecl (efDeclarations ef)) () (Map.singleton currentModuleName (ModuleImport { moduleImportIdent = Nothing })))+ if importAll+ then do+ -- Emit 'import' statements for all modules referenced, whether or not they are actually used in the type declarations.+ let explicitlyImported = List.nub (map eiModule (efImports ef))+ allImports = Map.keys moduleImportMap+ forM_ (explicitlyImported `List.union` allImports) $+ \moduleName ->+ case Map.lookup moduleName moduleImportMap of+ Just (ModuleImport { moduleImportIdent = Just ident }) -> emitNamespaceImport ident moduleName+ Nothing | moduleName /= ModuleName [ProperName C.prim] ->+ emitImport moduleName+ _ -> return ()+ else+ -- Only emit 'import' statements for modules that are actually used in the type declarations.+ forM_ (Map.toList moduleImportMap) $+ \m -> case m of+ (moduleName, ModuleImport { moduleImportIdent = Just ident }) -> emitNamespaceImport ident moduleName+ _ -> return ()+ tell moduleBody++ -- TODO: module re-exports: dig efExports / ReExportRef++ where+ currentModuleName :: ModuleName+ currentModuleName = efModuleName ef++ qualCurrentModule :: a -> Qualified a+ qualCurrentModule = Qualified (Just currentModuleName)++ -- Get the JS identifier for given module+ getModuleId :: ModuleName -> ModuleWriter (Maybe Text)+ getModuleId (ModuleName [ProperName prim]) | prim == C.prim = return Nothing -- should not occur+ getModuleId moduleName@(ModuleName components) = do+ mid <- gets (Map.lookup moduleName)+ case mid of+ Nothing -> do -- not found+ let moduleId = Just $ T.intercalate "_" (runProperName <$> components)+ -- TODO: Make sure moduleId is unique+ modify (Map.insert moduleName (ModuleImport { moduleImportIdent = moduleId }))+ return moduleId+ Just ModuleImport{..} -> return moduleImportIdent++ makeContext :: [Text] -> TypeTranslationContext ModuleWriter+ makeContext typeVariables = TypeTranslationContext typeVariables [] Nothing getModuleId env currentModuleName++ pursTypeToTSTypeX :: [Text] -> Type -> ModuleWriter TSType+ pursTypeToTSTypeX ctx ty = do+ e <- runExceptT $ runReaderT (pursTypeToTSType ty) (makeContext ctx)+ case e of+ Left err -> throwError (PursTypeError currentModuleName err)+ Right tsty -> return tsty++ processDecl :: ExternsDeclaration -> ModuleWriter ()+ processDecl EDType{..} = do+ let name = runProperName edTypeName+ qTypeName = qualCurrentModule edTypeName+ if isSimpleKind edTypeKind+ then case edTypeDeclarationKind of+ -- newtype declaration:+ DataType params [(ctorPName,[member])]+ | Just (Newtype,_,_,_) <- Map.lookup (qualCurrentModule ctorPName) (dataConstructors env) -> do+ case extractTypes edTypeKind params of+ Just typeParameters -> do+ member' <- pursTypeToTSTypeX typeParameters member+ emitTypeDeclaration (Just "newtype") name typeParameters member'+ Nothing -> do+ emitComment $ "newtype " <> name <> ": kind annotation was not available"++ -- data declaration:+ DataType params ctors -> do+ case extractTypes edTypeKind params of+ Just typeParameters -> do+ let buildCtorType (ctorPName,members)+ -- the data constructor is exported:+ -- the data constructor should be defined somewhere in this module (see EDDataConstructor case),+ -- so just reference it.+ | qualCurrentModule ctorPName `Map.member` dataConstructors env+ = let fv = typeParameters `List.intersect` concatMap freeTypeVariables members+ in TSNamed Nothing (runProperName edTypeName <> "$$" <> runProperName ctorPName) (map TSTyVar fv)++ -- the data constructor is not exportd (i.e. abstract):+ -- the marker fields are non-optional, so that they cannot be implicitly casted from other types.+ | otherwise+ = TSRecord [ mkField "$$pursType" (TSStringLit $ mkString $ runModuleName currentModuleName <> "." <> runProperName edTypeName)+ , mkField "$$pursTag" (TSStringLit $ mkString $ runProperName ctorPName)+ , mkField "$$abstractMarker" TSNever+ ]+ emitTypeDeclaration (Just "data") name typeParameters (TSUnion $ map buildCtorType ctors)+ Nothing -> do+ emitComment $ "data " <> name <> ": kind annotation was not available"++ -- type synonym:+ TypeSynonym+ | Just (synonymArguments, synonymType) <- Map.lookup qTypeName (typeSynonyms env) -> do+ case extractTypes edTypeKind synonymArguments of+ Just typeParameters -> do+ tsty <- pursTypeToTSTypeX typeParameters synonymType+ emitTypeDeclaration (Just "synonym") name typeParameters tsty+ Nothing -> do+ emitComment $ "type synonym " <> name <> ": kind annotation was not available"+ | otherwise -> emitComment ("type (synonym) " <> name <> ": " <> prettyPrintKind edTypeKind)++ -- foreign import data:+ ExternData+ | qTypeName == qnUnit -> do+ -- 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))+ emitTypeDeclaration (Just "builtin") name typeParameters pst+ | otherwise -> do+ -- Foreign type: just use 'any' type.+ -- External '.d.ts' file needs to be supplied for better typing.+ emitTypeDeclaration (Just "foreign") name typeParameters (TSUnknown "foreign")+ where builtins = [qnFn0,qnFn2,qnFn3,qnFn4,qnFn5,qnFn6,qnFn7,qnFn8,qnFn9,qnFn10,qnStrMap]+ n = numberOfTypeParams edTypeKind+ typeParameters = map (\i -> "a" <> T.pack (show i)) [0..n-1]++ -- others:+ LocalTypeVariable -> emitComment ("unexpected local type variable: " <> name <> " :: " <> prettyPrintKind edTypeKind)+ ScopedTypeVar -> emitComment ("unexpected scoped type variable: " <> name <> " :: " <> prettyPrintKind edTypeKind)++ else emitComment ("type " <> name <> " :: " <> prettyPrintKind edTypeKind <> " : unsupported kind")++ processDecl EDDataConstructor{..} = do+ let name = runProperName edDataCtorName+ case Map.lookup (qualCurrentModule edDataCtorTypeCtor) (types env) of+ Just (k, DataType typeParameters constructors)+ | isSimpleKind k+ , Just fieldTypes <- List.lookup edDataCtorName constructors -> do+ tsty <- pursTypeToTSTypeX [] edDataCtorType+ case edDataCtorOrigin of+ Data -> do+ -- Data constructor for a 'data' declaration:+ -- Emit an interface so that type refinement via 'instanceof' works.+ let fieldTypeVars = map fst typeParameters `List.intersect` concatMap freeTypeVariables fieldTypes+ dataCtorSubtypeName = runProperName edDataCtorTypeCtor <> "$$" <> runProperName edDataCtorName+ dataCtorSubtype = TSNamed Nothing dataCtorSubtypeName (map TSTyVar fieldTypeVars)+ fieldTypesTS <- mapM (pursTypeToTSTypeX fieldTypeVars) fieldTypes+ let mkMarkerField | length constructors == 1 = mkOptionalField -- allow structural subtyping if there are only one constructor+ | otherwise = mkField -- nominal typing+ makerFields = [ mkMarkerField "$$pursType" (TSStringLit (mkString $ runModuleName currentModuleName <> "." <> runProperName edDataCtorTypeCtor))+ , mkMarkerField "$$pursTag" (TSStringLit (mkString $ runProperName edDataCtorName))+ ]+ dataFields = zipWith (\f ty -> mkField (Label $ mkString $ runIdent f) ty) edDataCtorFields fieldTypesTS+ emitInterface dataCtorSubtypeName fieldTypeVars (makerFields <> dataFields)++ -- The constructor function has a 'new' signature returning that interface.+ let ctorFieldName | null edDataCtorFields = "value"+ | otherwise = "create"+ ctorType = TSRecord [ mkField ctorFieldName tsty+ , NewSignature fieldTypeVars fieldTypesTS dataCtorSubtype+ ]+ emitValueDeclaration (Just "data ctor") name ctorType++ Newtype ->+ -- Data constructor for a 'newtype' declaration:+ -- No 'new' signature: just define a function.+ emitValueDeclaration (Just "newtype data ctor") name tsty++ Nothing -> emitComment $ "the type of an exported data constructor must be exported: " <> name+ Just (k, DataType _typeParameters _constructors) -> emitComment $ "unrecognized data constructor: " <> name <> " kind: " <> prettyPrintKind k+ _ -> emitComment $ "unrecognized data constructor: " <> name++ processDecl EDValue{..} = do+ let name = runIdent edValueName+ tsty <- pursTypeToTSTypeX [] edValueType+ emitValueDeclaration Nothing name tsty++ processDecl EDInstance{..}+ | Just constraints <- edInstanceConstraints+ , 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)+ instanceTy <- pursTypeToTSTypeX [] desugaredInstanceType+ emitValueDeclaration (Just "instance") name instanceTy+ | otherwise = emitComment ("invalid instance declaration '" <> name <> "'")+ where name = runIdent edInstanceName :: Text+ qDictTypeName = fmap coerceProperName edInstanceClassName :: Qualified (ProperName 'TypeName)++ processDecl EDKind{..} = do+ -- Do nothing for kind declarations: just put a comment.+ let name = runProperName edKindName+ emitComment ("kind " <> name)++ processDecl EDTypeSynonym{} = do+ -- Ignored: should be handled in EDType case.+ return ()++ processDecl EDClass{} = do+ -- Ignored: should be handled in EDType case.+ return ()
+ src/Language/PureScript/TsdGen/Types.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Language.PureScript.TsdGen.Types where+import Prelude hiding (elem,notElem,lookup)+import Language.PureScript.Environment+import Language.PureScript.Types+import Language.PureScript.Label+import Language.PureScript.PSString+import Language.PureScript.Kinds+import Language.PureScript.Names+import Language.PureScript.Errors+import Language.PureScript.TypeChecker.Kinds+import Language.PureScript.TypeChecker.Monad+import qualified Language.PureScript.Constants as C+import Language.PureScript.CodeGen.JS.Common+import qualified Data.Text as T+import Data.Text (Text)+import Control.Monad.State+import Control.Monad.Except+import qualified Data.Map as Map+import Control.Monad.Reader+import Data.Monoid ((<>))+import Data.Char (isLetter,isAlphaNum)+import qualified Data.List as List++data Field = Field { fieldLabel :: !Label+ , fieldType :: !TSType+ , fieldIsOptional :: !Bool+ -- Other options: readonly+ }+ | NewSignature {- type parameters -} [Text] [TSType] TSType+ deriving (Eq,Show)++mkField :: Label -> TSType -> Field+mkField label ty = Field label ty False++mkOptionalField :: Label -> TSType -> Field+mkOptionalField label ty = Field label ty True++-- TypeScript types+data TSType = TSAny+ | TSNever+ | TSNumber+ | TSBoolean+ | TSString+ | TSFunction {- type parameters -} [Text] {- parameter types -} [TSType] TSType+ | TSArray TSType+ | TSUndefined+ | TSRecord [Field]+ | TSStrMap TSType -- Data.StrMap.StrMap <=> {[_: string]: T}+ | TSTyVar Text+ | TSNamed {- module id -} (Maybe Text) {- name -} Text {- arguments -} [TSType]+ | TSStringLit PSString+ | TSUnion [TSType] -- empty = never+ | TSIntersection [TSType] -- empty = {} (all)+ | TSUnknown Text+ | TSCommented TSType Text+ deriving (Eq,Show)++-- Data.Unit+qnUnit = Qualified (Just (moduleNameFromString "Data.Unit")) (ProperName "Unit")++-- Data.Function.Uncurried+tyFn0, tyFn2, tyFn3, tyFn4, tyFn5, tyFn6, tyFn7, tyFn8, tyFn9, tyFn10 :: Type+modDataFunctionUncurried = Just (moduleNameFromString "Data.Function.Uncurried")+qnFn0 = Qualified modDataFunctionUncurried (ProperName "Fn0")+qnFn2 = Qualified modDataFunctionUncurried (ProperName "Fn2")+qnFn3 = Qualified modDataFunctionUncurried (ProperName "Fn3")+qnFn4 = Qualified modDataFunctionUncurried (ProperName "Fn4")+qnFn5 = Qualified modDataFunctionUncurried (ProperName "Fn5")+qnFn6 = Qualified modDataFunctionUncurried (ProperName "Fn6")+qnFn7 = Qualified modDataFunctionUncurried (ProperName "Fn7")+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++-- Data.StrMap:+-- foreign import data StrMap :: Type -> Type+qnStrMap = Qualified (Just (moduleNameFromString "Data.StrMap")) (ProperName "StrMap")+tyStrMap :: Type+tyStrMap = TypeConstructor qnStrMap++-- Control.Monad.Eff+-- foreign import data Eff :: # Effect -> Type -> Type+tyEff = TypeConstructor (Qualified (Just (moduleNameFromString "Control.Monad.Eff")) (ProperName "Eff"))++constraintToType :: Constraint -> Type+constraintToType ct = foldl TypeApp (TypeConstructor qDictTypeName) (constraintArgs ct)+ where qDictTypeName = fmap coerceProperName (constraintClass ct)++data TypeTranslationContext f = TypeTranslationContext { ttcBoundTyVars :: [Text]+ , ttcUnboundTyVars :: [Text]+ , ttcScopedVarKinds :: Maybe [(Text,Kind)]+ , ttcGetModuleId :: ModuleName -> f (Maybe Text)+ , ttcEnvironment :: Environment+ , ttcCurrentModuleName :: ModuleName+ }++type TypeTranslationT f = ReaderT (TypeTranslationContext f) (ExceptT MultipleErrors f)++tsFunction :: forall f. Monad f => (Type -> TypeTranslationT f TSType) -> [Type] -> Type -> 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 = go+ where+ go :: Type -> TypeTranslationT f TSType+ go (TypeApp (TypeApp tcon a0) r)+ | tcon == tyFunction = 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)+ | tcon == tyArray = TSArray <$> go a0+ | tcon == tyStrMap = TSStrMap <$> go a0+ | tcon == tyRecord = case rowToList a0 of+ (pairs, _) -> TSRecord <$> traverse (\(label,ty) -> mkField label <$> go ty) pairs+ | tcon == tyFn0 = tsFunction go [] a0+ go ty@(ForAll name 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+ 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)+ | 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+ 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+ case typeName of+ ProperName "Partial" -> pure (TSUnknown "Prim.Partial")+ _ -> pure (TSUnknown $ T.pack $ show ty)+ go ty@(TypeConstructor qName@(Qualified (Just moduleName) typeName)) = do+ ti <- asks (Map.lookup qName . types . ttcEnvironment)+ case ti of+ Just (k, _) | isSimpleKind k -> do+ getModuleId <- asks ttcGetModuleId+ 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 ty = pure (TSUnknown $ T.pack $ show ty)++ getKindsIn :: Type -> ([(Text,Kind)] -> TypeTranslationT f r) -> TypeTranslationT f r+ getKindsIn ty m = do+ mkinds <- asks ttcScopedVarKinds+ case mkinds of+ Just kinds -> m kinds+ Nothing -> do+ checkState <- asks (\TypeTranslationContext{..} ->+ let insertLocalTyVar env v = Map.insert (Qualified (Just ttcCurrentModuleName) (ProperName v)) (kindType, LocalTypeVariable) env+ env' = ttcEnvironment { types = foldl insertLocalTyVar (types ttcEnvironment) ttcBoundTyVars }+ in (emptyCheckState env') { checkCurrentModule = Just ttcCurrentModuleName })+ case runExcept (evalStateT (kindOfWithScopedVars ty) checkState) of+ Left err -> throwError err+ Right (kind,kinds)+ | kind == kindType -> withReaderT (\r -> r { ttcScopedVarKinds = Just kinds }) (m kinds)+ | otherwise -> throwError (errorMessage (ExpectedType ty kind))++showTSType :: TSType -> Text+showTSType = showTSTypePrec 0++showParenIf :: Bool -> Text -> Text+showParenIf True s = "(" <> s <> ")"+showParenIf False s = s++showField :: Field -> Text+showField field@Field{} = objectPropertyToString (runLabel (fieldLabel field)) <> optionalMarker <> ": " <> showTSType (fieldType field)+ 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++showFunctionParameters :: [TSType] -> Text+showFunctionParameters [] = ""+showFunctionParameters [ty] = "_: " <> showTSType ty+showFunctionParameters types = T.intercalate ", " $ zipWith (\n ty -> "_" <> T.pack (show (n :: Int)) <> ": " <> showTSType ty) [0..] types++objectPropertyToString :: PSString -> Text+objectPropertyToString ps = case decodeString ps of+ Just t | not (identNeedsEscaping t) -> t+ _ -> prettyPrintStringJS ps++isIdentifierStart, isIdentifierPart :: Char -> Bool+isIdentifierStart c = isLetter c || c == '$' || c == '_' -- TODO: Match with "ID_Start"+isIdentifierPart c = isAlphaNum c || c == '$' || c == '_' -- TODO: Match with "ID_Continue"++isIdentifierName :: Text -> Bool+isIdentifierName name = case T.uncons name of+ Just (head, tail) -> isIdentifierStart head && T.all isIdentifierPart tail+ _ -> False++showTSTypePrec :: Int -> TSType -> Text+showTSTypePrec prec ty = case ty of+ TSAny -> "any"+ TSNever -> "never"+ TSNumber -> "number"+ 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+ TSArray elemTy -> "Array< " <> showTSType elemTy <> " >" -- TODO: Use ReadonlyArray?+ TSStrMap elemTy -> "{[_: string]: " <> showTSType elemTy <> "}"+ TSUndefined -> "undefined"+ TSRecord [] -> "{}"+ TSRecord fields -> "{ " <> T.intercalate "; " (map showField fields) <> " }"+ TSUnknown desc -> "any /* " <> desc <> " */"+ TSStringLit s -> prettyPrintStringJS s+ TSUnion [] -> "never" -- uninhabitated type+ TSUnion members -> showParenIf (prec > 1) $ T.intercalate " | " (map (showTSTypePrec 1) members)+ TSIntersection [] -> "{}" -- universal type+ TSIntersection members -> T.intercalate " & " (map (showTSTypePrec 2) members)+ TSTyVar name -> properToJs name+ TSNamed moduleid name tyArgs -> mid <> name <> ta+ where mid | Just m <- moduleid = m <> "."+ | otherwise = ""+ ta | [] <- tyArgs = ""+ -- the space after '<' is needed to avoid parse error with types like Array<<a>(_: a) => a>+ | otherwise = "< " <> T.intercalate ", " (map showTSType tyArgs) <> " >"+ TSCommented inner desc -> showTSTypePrec prec inner <> " /* " <> desc <> " */"++-- SimpleKind :: (Type -> )* Type+isSimpleKind :: Kind -> Bool+isSimpleKind k | k == kindType = True+isSimpleKind (FunKind s t) = s == kindType && isSimpleKind t+isSimpleKind _ = False++numberOfTypeParams :: Kind -> Int+numberOfTypeParams k | k == kindType = 0+numberOfTypeParams (FunKind s t) | s == kindType = numberOfTypeParams t + 1+numberOfTypeParams _ = 0 -- invalid++-- LessSimpleKind :: (SimpleKind -> )* Type+isLessSimpleKind :: Kind -> Bool+isLessSimpleKind k | k == kindType = True+isLessSimpleKind (FunKind s t) = isSimpleKind s && isLessSimpleKind t+isLessSimpleKind _ = False++extractTypes :: Kind -> [(a,Maybe Kind)] -> Maybe [a]+extractTypes k [] | k == kindType = return []+extractTypes (FunKind kind1 r) ((name,kind2):xs)+ | kind1 == kindType && (kind2 == Just kindType || kind2 == Nothing) = (name :) <$> extractTypes r xs+ | otherwise = extractTypes r xs -- ??+extractTypes _ _ = Nothing