5fe25aa · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Check that FFI imports match with implementations

5fe25aaHarry Garrood11 years ago

src/Language/PureScript/Bundle.hs+103−44

compare with golang

unifiedsplit

@@ -27,6 +27,7 @@ module Language.PureScript.Bundle (

27 , ModuleType(..)

28 , ErrorMessage(..)

29 , printErrorMessage

30+ , getExportedIdentifiers

30) where

31) where

32import Prelude ()

33import Prelude ()

@@ -229,53 +230,20 @@ toModule requirePath mids mid top

229 err = throwError . ErrorInModule mid

230 err = throwError . ErrorInModule mid

230

231

231 toModuleElement :: JSStatement -> m ModuleElement

232 toModuleElement :: JSStatement -> m ModuleElement

232− -- var ModuleName = require("file");

233 toModuleElement stmt

234− | JSVariable _ jsInit _ <- stmt

235− , [JSVarInitExpression var varInit] <- commaList jsInit

236− , JSIdentifier _ importName <- var

237− , JSVarInit _ jsInitEx <- varInit

238− , JSMemberExpression req _ argsE _ <- jsInitEx

239− , JSIdentifier _ "require" <- req

240− , [ Just importPath ] <- map fromStringLiteral (commaList argsE)

241− , importPath' <- checkImportPath requirePath importPath mid mids

234+ | Just (importName, importPath) <- matchRequire requirePath mids mid stmt

242− = pure (Require stmt importName importPath')

235+ = pure (Require stmt importName importPath)

243− -- var foo = expr;

244− toModuleElement stmt

245− | JSVariable _ jsInit _ <- stmt

246− , [JSVarInitExpression var varInit] <- commaList jsInit

247− , JSIdentifier _ name <- var

248− , JSVarInit _ decl <- varInit

249− = pure (Member stmt False name decl [])

250− -- exports.foo = expr; exports["foo"] = expr;

251 toModuleElement stmt

236 toModuleElement stmt

252− | JSAssignStatement e (JSAssign _) decl _ <- stmt

237+ | Just (exported, name, decl) <- matchMember stmt

253− , Just name <- accessor e

254− = pure (Member stmt True name decl [])

238+ = pure (Member stmt exported name decl [])

255− where

256− accessor :: JSExpression -> Maybe String

257− accessor (JSMemberDot exports _ nm)

258− | JSIdentifier _ "exports" <- exports

259− , JSIdentifier _ name <- nm

260− = Just name

261− accessor (JSMemberSquare exports _ nm _)

262− | JSIdentifier _ "exports" <- exports

263− , Just name <- fromStringLiteral nm

264− = Just name

265− accessor _ = Nothing

266− -- module.exports = { ... }

267 toModuleElement stmt

239 toModuleElement stmt

268− | JSAssignStatement e (JSAssign _) decl _ <- stmt

240+ | Just props <- matchExportsAssignment stmt

269− , JSMemberDot module' _ exports <- e

270− , JSIdentifier _ "module" <- module'

271− , JSIdentifier _ "exports" <- exports

272− , JSObjectLiteral _ props _ <- decl

273 = (ExportsList <$> traverse toExport (trailingCommaList props))

241 = (ExportsList <$> traverse toExport (trailingCommaList props))

274 where

242 where

275 toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])

243 toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key])

276 toExport (JSPropertyNameandValue name _ [val]) =

244 toExport (JSPropertyNameandValue name _ [val]) =

277 (,,val,[]) <$> exportType val

245 (,,val,[]) <$> exportType val

278− <*> extractLabel name

246+ <*> extractLabel' name

279 toExport _ = err UnsupportedExport

247 toExport _ = err UnsupportedExport

280

248

281 exportType :: JSExpression -> m ExportType

249 exportType :: JSExpression -> m ExportType

@@ -287,14 +255,105 @@ toModule requirePath mids mid top

287 = pure ForeignReexport

255 = pure ForeignReexport

288 exportType (JSIdentifier _ s) = pure (RegularExport s)

256 exportType (JSIdentifier _ s) = pure (RegularExport s)

289 exportType _ = err UnsupportedExport

257 exportType _ = err UnsupportedExport

290−--

258+

291− extractLabel :: JSPropertyName -> m String

292− extractLabel (JSPropertyString _ nm) = pure (trimStringQuotes nm)

293− extractLabel (JSPropertyIdent _ nm) = pure nm

294− extractLabel _ = err UnsupportedExport

259+ extractLabel' = maybe (err UnsupportedExport) pure . extractLabel

295

260

296 toModuleElement other = pure (Other other)

261 toModuleElement other = pure (Other other)

297

262

263+-- Get a list of all the exported identifiers from a foreign module.

264+--

265+-- TODO: what if we assign to exports.foo and then later assign to

266+-- module.exports (presumably overwriting exports.foo)?

267+getExportedIdentifiers :: (MonadError ErrorMessage m)

268+ => String

269+ -> JSAST

270+ -> m [String]

271+getExportedIdentifiers mname top

272+ | JSAstProgram stmts _ <- top = concat <$> traverse go stmts

273+ | otherwise = err InvalidTopLevel

274+ where

275+ err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)

276+

277+ go stmt

278+ | Just props <- matchExportsAssignment stmt

279+ = traverse toIdent (trailingCommaList props)

280+ | Just (True, name, _) <- matchMember stmt

281+ = pure [name]

282+ | otherwise

283+ = pure []

284+

285+ toIdent (JSPropertyNameandValue name _ [_]) =

286+ extractLabel' name

287+ toIdent _ =

288+ err UnsupportedExport

289+

290+ extractLabel' = maybe (err UnsupportedExport) pure . extractLabel

291+

292+-- Matches JS statements like this:

293+-- var ModuleName = require("file");

294+matchRequire :: Maybe FilePath

295+ -> S.Set String

296+ -> ModuleIdentifier

297+ -> JSStatement

298+ -> Maybe (String, Either String ModuleIdentifier)

299+matchRequire requirePath mids mid stmt

300+ | JSVariable _ jsInit _ <- stmt

301+ , [JSVarInitExpression var varInit] <- commaList jsInit

302+ , JSIdentifier _ importName <- var

303+ , JSVarInit _ jsInitEx <- varInit

304+ , JSMemberExpression req _ argsE _ <- jsInitEx

305+ , JSIdentifier _ "require" <- req

306+ , [ Just importPath ] <- map fromStringLiteral (commaList argsE)

307+ , importPath' <- checkImportPath requirePath importPath mid mids

308+ = Just (importName, importPath')

309+ | otherwise

310+ = Nothing

311+

312+-- Matches JS member declarations.

313+matchMember :: JSStatement -> Maybe (Bool, String, JSExpression)

314+matchMember stmt

315+ -- var foo = expr;

316+ | JSVariable _ jsInit _ <- stmt

317+ , [JSVarInitExpression var varInit] <- commaList jsInit

318+ , JSIdentifier _ name <- var

319+ , JSVarInit _ decl <- varInit

320+ = Just (False, name, decl)

321+ -- exports.foo = expr; exports["foo"] = expr;

322+ | JSAssignStatement e (JSAssign _) decl _ <- stmt

323+ , Just name <- accessor e

324+ = Just (True, name, decl)

325+ | otherwise

326+ = Nothing

327+ where

328+ accessor :: JSExpression -> Maybe String

329+ accessor (JSMemberDot exports _ nm)

330+ | JSIdentifier _ "exports" <- exports

331+ , JSIdentifier _ name <- nm

332+ = Just name

333+ accessor (JSMemberSquare exports _ nm _)

334+ | JSIdentifier _ "exports" <- exports

335+ , Just name <- fromStringLiteral nm

336+ = Just name

337+ accessor _ = Nothing

338+

339+-- Matches assignments to module.exports, like this:

340+-- module.exports = { ... }

341+matchExportsAssignment :: JSStatement -> Maybe JSObjectPropertyList

342+matchExportsAssignment stmt

343+ | JSAssignStatement e (JSAssign _) decl _ <- stmt

344+ , JSMemberDot module' _ exports <- e

345+ , JSIdentifier _ "module" <- module'

346+ , JSIdentifier _ "exports" <- exports

347+ , JSObjectLiteral _ props _ <- decl

348+ = Just props

349+ | otherwise

350+ = Nothing

351+

352+extractLabel :: JSPropertyName -> Maybe String

353+extractLabel (JSPropertyString _ nm) = Just (trimStringQuotes nm)

354+extractLabel (JSPropertyIdent _ nm) = Just nm

355+extractLabel _ = Nothing

356+

298-- | Eliminate unused code based on the specified entry point set.

357-- | Eliminate unused code based on the specified entry point set.

299compile :: [Module] -> [ModuleIdentifier] -> [Module]

358compile :: [Module] -> [ModuleIdentifier] -> [Module]

300compile modules [] = modules

359compile modules [] = modules

src/Language/PureScript/Errors.hs+20−5

@@ -12,6 +12,7 @@ import Data.Char (isSpace)

12import Data.Either (lefts, rights)

13import Data.List (intercalate, transpose, nub, nubBy, sortBy)

14import Data.Foldable (fold)

15+import Data.Maybe (maybeToList)

16import qualified Data.Map as M

17import qualified Data.Map as M

@@ -28,6 +29,7 @@ import Language.PureScript.Pretty.Common (before)

28import Language.PureScript.Types

29import Language.PureScript.Types

29import Language.PureScript.Names

30import Language.PureScript.Names

30import Language.PureScript.Kinds

31import Language.PureScript.Kinds

32+import qualified Language.PureScript.Bundle as Bundle

32import qualified Text.PrettyPrint.Boxes as Box

34import qualified Text.PrettyPrint.Boxes as Box

@@ -37,11 +39,13 @@ import Text.Parsec.Error (Message(..))

38-- | A type of error messages

40-- | A type of error messages

39data SimpleErrorMessage

41data SimpleErrorMessage

40− = ErrorParsingFFIModule FilePath

42+ = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)

41 | ErrorParsingModule P.ParseError

43 | ErrorParsingModule P.ParseError

42 | MissingFFIModule ModuleName

44 | MissingFFIModule ModuleName

43 | MultipleFFIModules ModuleName [FilePath]

45 | MultipleFFIModules ModuleName [FilePath]

44 | UnnecessaryFFIModule ModuleName FilePath

46 | UnnecessaryFFIModule ModuleName FilePath

47+ | MissingFFIImplementations ModuleName [Ident]

48+ | UnusedFFIImplementations ModuleName [Ident]

45 | CannotGetFileInfo FilePath

49 | CannotGetFileInfo FilePath

46 | CannotReadFile FilePath

50 | CannotReadFile FilePath

47 | CannotWriteFile FilePath

51 | CannotWriteFile FilePath

@@ -224,6 +228,8 @@ errorCode em = case unwrapErrorMessage em of

224 MissingFFIModule{} -> "MissingFFIModule"

228 MissingFFIModule{} -> "MissingFFIModule"

225 MultipleFFIModules{} -> "MultipleFFIModules"

229 MultipleFFIModules{} -> "MultipleFFIModules"

226 UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"

230 UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"

231+ MissingFFIImplementations{} -> "MissingFFIImplementations"

232+ UnusedFFIImplementations{} -> "UnusedFFIImplementations"

227 CannotGetFileInfo{} -> "CannotGetFileInfo"

233 CannotGetFileInfo{} -> "CannotGetFileInfo"

228 CannotReadFile{} -> "CannotReadFile"

234 CannotReadFile{} -> "CannotReadFile"

229 CannotWriteFile{} -> "CannotWriteFile"

235 CannotWriteFile{} -> "CannotWriteFile"

@@ -525,10 +531,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

525 paras [ line "Unable to write file: "

531 paras [ line "Unable to write file: "

526 , indent . line $ path

532 , indent . line $ path

527 ]

533 ]

528− renderSimpleErrorMessage (ErrorParsingFFIModule path) =

534+ renderSimpleErrorMessage (ErrorParsingFFIModule path extra) =

529− paras [ line "Unable to parse foreign module:"

535+ paras $ [ line "Unable to parse foreign module:"

530− , indent . line $ path

536+ , indent . line $ path

531− ]

537+ ] ++

538+ (map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra)))

532 renderSimpleErrorMessage (ErrorParsingModule err) =

539 renderSimpleErrorMessage (ErrorParsingModule err) =

533 paras [ line "Unable to parse module: "

540 paras [ line "Unable to parse module: "

534 , prettyPrintParseError err

541 , prettyPrintParseError err

@@ -540,6 +547,14 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

540 , indent . line $ path

547 , indent . line $ path

541 , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary."

548 , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary."

542 ]

549 ]

550+ renderSimpleErrorMessage (MissingFFIImplementations mn idents) =

551+ paras [ line $ "The following values are not defined in the foreign module for module " ++ runModuleName mn ++ ": "

552+ , indent . paras $ map (line . runIdent) idents

553+ ]

554+ renderSimpleErrorMessage (UnusedFFIImplementations mn idents) =

555+ paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: "

556+ , indent . paras $ map (line . runIdent) idents

557+ ]

543 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

558 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

544 paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "

559 paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "

545 , indent . paras $ map line paths

560 , indent . paras $ map line paths

src/Language/PureScript/Make.hs+57−4

@@ -25,6 +25,7 @@ module Language.PureScript.Make

25import Prelude ()

26import Prelude.Compat

28+import Control.Applicative ((<|>))

28import Control.Monad hiding (sequence)

29import Control.Monad hiding (sequence)

29import Control.Monad.Error.Class (MonadError(..))

30import Control.Monad.Error.Class (MonadError(..))

30import Control.Monad.Writer.Class (MonadWriter(..))

31import Control.Monad.Writer.Class (MonadWriter(..))

@@ -52,6 +53,8 @@ import qualified Data.ByteString.UTF8 as BU8

52import qualified Data.Set as S

53import qualified Data.Set as S

53import qualified Data.Map as M

54import qualified Data.Map as M

56+import qualified Text.Parsec as Parsec

57+

55import SourceMap.Types

58import SourceMap.Types

56import SourceMap

59import SourceMap

@@ -61,6 +64,8 @@ import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise

61import System.IO.Error (tryIOError)

64import System.IO.Error (tryIOError)

62import System.IO.UTF8 (readUTF8File, writeUTF8File)

65import System.IO.UTF8 (readUTF8File, writeUTF8File)

67+import qualified Language.JavaScript.Parser as JS

68+

64import Language.PureScript.Crash

69import Language.PureScript.Crash

65import Language.PureScript.AST

70import Language.PureScript.AST

66import Language.PureScript.Externs

71import Language.PureScript.Externs

@@ -76,6 +81,8 @@ import Language.PureScript.Renamer

76import Language.PureScript.Sugar

81import Language.PureScript.Sugar

77import Language.PureScript.TypeChecker

82import Language.PureScript.TypeChecker

78import qualified Language.PureScript.Constants as C

83import qualified Language.PureScript.Constants as C

84+import qualified Language.PureScript.Bundle as Bundle

85+import qualified Language.PureScript.Parser as PSParser

80import qualified Language.PureScript.CodeGen.JS as J

87import qualified Language.PureScript.CodeGen.JS as J

81import qualified Language.PureScript.CoreFn as CF

88import qualified Language.PureScript.CoreFn as CF

@@ -331,7 +338,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

331 | not $ requiresForeign m -> do

338 | not $ requiresForeign m -> do

332 tell $ errorMessage $ UnnecessaryFFIModule mn path

339 tell $ errorMessage $ UnnecessaryFFIModule mn path

333 return Nothing

340 return Nothing

341+ | otherwise -> do

342+ checkForeignDecls m path

334− | otherwise -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]

343+ return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]

335 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn

344 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn

336 | otherwise -> return Nothing

345 | otherwise -> return Nothing

337 rawJs <- J.moduleToJs m foreignInclude

346 rawJs <- J.moduleToJs m foreignInclude

@@ -384,9 +393,6 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

384 exists <- doesFileExist path

393 exists <- doesFileExist path

385 traverse (const $ getModificationTime path) $ guard exists

394 traverse (const $ getModificationTime path) $ guard exists

386

395

387− readTextFile :: FilePath -> Make String

388− readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path

389−

390 writeTextFile :: FilePath -> String -> Make ()

396 writeTextFile :: FilePath -> String -> Make ()

391 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do

397 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do

392 mkdirp path

398 mkdirp path

@@ -397,3 +403,50 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

397

403

398 progress :: ProgressMessage -> Make ()

404 progress :: ProgressMessage -> Make ()

399 progress = liftIO . putStrLn . renderProgressMessage

405 progress = liftIO . putStrLn . renderProgressMessage

406+

407+readTextFile :: FilePath -> Make String

408+readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path

409+

410+-- |

411+-- Check that the declarations in a given PureScript module match with those

412+-- in its corresponding foreign module.

413+--

414+checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()

415+checkForeignDecls m path = do

416+ jsStr <- lift $ readTextFile path

417+ js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path

418+

419+ foreignIdentsStrs <- either errorParsingModule pure $ getExps js

420+ let foreignIdents =

421+ either

422+ (internalError . ("checkForeignDecls: unexpected idents: " ++) . show)

423+ S.fromList

424+ (traverse parseIdent foreignIdentsStrs)

425+ let importedIdents = S.fromList $ map fst (CF.moduleForeign m)

426+

427+ let unusedFFI = foreignIdents S.\\ importedIdents

428+ unless (null unusedFFI) $

429+ tell . errorMessage . UnusedFFIImplementations mname $

430+ S.toList unusedFFI

431+

432+ let missingFFI = importedIdents S.\\ foreignIdents

433+ unless (null missingFFI) $

434+ throwError . errorMessage . MissingFFIImplementations mname $

435+ S.toList missingFFI

436+

437+ where

438+ mname = CF.moduleName m

439+

440+ errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a

441+ errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just

442+

443+ getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]

444+ getExps = Bundle.getExportedIdentifiers (runModuleName mname)

445+

446+ -- TODO: Handling for parenthesised operators should be removed after 0.9.

447+ parseIdent :: String -> Either String Ident

448+ parseIdent str = try str <|> try ("(" ++ str ++ ")")

449+ where

450+ try s = either (Left . show) Right $ do

451+ ts <- PSParser.lex "" s

452+ PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts

src/Language/PureScript/Parser/JS.hs+1−1

@@ -43,7 +43,7 @@ parseForeignModulesFromFiles files = do

43 foreigns <- parU files $ \(path, file) ->

44 case findModuleName (lines file) of

45 Just name -> return (name, path)

46− Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path)

46+ Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path Nothing)

47 let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns

48 forM_ grouped $ \grp ->

49 when (length grp > 1) $ do