a178e07 · rowtype-yoga/purescript-native

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

on golang help sign in

Reinstate -Wall, fix warnings.

a178e07Phil Freeman13 years ago

purescript.cabal+1

compare with golang

unifiedsplit

@@ -74,6 +74,7 @@ library

74 buildable: True

75 hs-source-dirs: src

76 other-modules:

77+ ghc-options: -Wall -O2

78executable psc

79executable psc

79 build-depends: base >=4 && <5, cmdtheline -any, containers -any,

80 build-depends: base >=4 && <5, cmdtheline -any, containers -any,

src/Data/Generics/Extras.hs−1

@@ -18,7 +18,6 @@

18module Data.Generics.Extras where

20import Data.Data

21−import Data.Maybe (fromMaybe)

23-- |

22-- |

24-- Apply a top-down monadic transformation everywhere

23-- Apply a top-down monadic transformation everywhere

src/Language/PureScript.hs+1−1

@@ -64,7 +64,7 @@ compile opts ms = do

64 Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls <*> pure exps

65 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

66 let entryPoints = moduleNameFromString `map` optionsModules opts

67− let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped

67+ let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped

68 let js = mapMaybe (flip (moduleToJs opts) env) elim

69 let exts = intercalate "\n" . map (`moduleToPs` env) $ elim

70 js' <- case mainModuleIdent of

src/Language/PureScript/CodeGen/Externs.hs+1−1

@@ -30,7 +30,7 @@ import Data.List (intercalate)

30-- TODO: only expose items listed in "exps"

31--

32moduleToPs :: Module -> Environment -> String

33−moduleToPs (Module mn decls exps) env =

33+moduleToPs (Module mn decls _) env =

34 "module " ++ runModuleName mn ++ " where\n" ++

35 (intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)

src/Language/PureScript/CodeGen/JS.hs+2−3

@@ -24,8 +24,6 @@ module Language.PureScript.CodeGen.JS (

25import Data.Maybe (fromMaybe, mapMaybe)

26import Data.Function (on)

27−import Data.Data (Data)

28−import Data.Generics (mkQ, everything)

30import Control.Arrow (second)

28import Control.Arrow (second)

31import Control.Monad (replicateM, forM)

29import Control.Monad (replicateM, forM)

@@ -50,7 +48,7 @@ import Language.PureScript.Prim

50-- module.

48-- module.

51--

49--

52moduleToJs :: Options -> Module -> Environment -> Maybe JS

50moduleToJs :: Options -> Module -> Environment -> Maybe JS

53−moduleToJs opts (Module name decls exps) env =

51+moduleToJs opts (Module name decls _) env =

54 case jsDecls of

52 case jsDecls of

55 [] -> Nothing

53 [] -> Nothing

56 _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $

54 _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $

@@ -73,6 +71,7 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =

73 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

71 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

74 export (Escaped ctor) $ JSVariableIntroduction ctor (Just (go pn 0 tys []))

72 export (Escaped ctor) $ JSVariableIntroduction ctor (Just (go pn 0 tys []))

75 where

73 where

74+ go :: ProperName -> Integer -> [Type] -> [JS] -> JS

76 go pn _ [] values =

75 go pn _ [] values =

77 JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]

76 JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]

78 go pn index (_ : tys') values =

77 go pn index (_ : tys') values =

src/Language/PureScript/CodeGen/Optimize.hs+37−42

@@ -46,8 +46,6 @@ import Language.PureScript.Names

46import Language.PureScript.CodeGen.JS.AST

47import Language.PureScript.Options

48import Language.PureScript.CodeGen.Common (identToJs)

49−import Language.PureScript.Types

50−import Language.PureScript.Prim

52-- |

50-- |

53-- Apply a series of optimizer passes to simplified Javascript code

51-- Apply a series of optimizer passes to simplified Javascript code

@@ -311,9 +309,6 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

311 -- Check if an expression represents a function in the Ef module

309 -- Check if an expression represents a function in the Ef module

312 isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True

310 isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True

313 isEffFunc _ _ = False

311 isEffFunc _ _ = False

314− -- Module names

315− prelude = ModuleName [ProperName "Prelude"]

316− effModule = ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"]

317 -- The name of the type class dictionary for the Monad Eff instance

312 -- The name of the type class dictionary for the Monad Eff instance

318 effDictName = "monadEff"

313 effDictName = "monadEff"

319 -- Check if an expression represents the Monad Eff dictionary

314 -- Check if an expression represents the Monad Eff dictionary

@@ -402,62 +397,62 @@ inlineOperator op f = everywhere (mkT convert)

402

397

403inlineCommonOperators :: JS -> JS

398inlineCommonOperators :: JS -> JS

404inlineCommonOperators = applyAll

399inlineCommonOperators = applyAll

405− [ binary "numNumber" "+" "Num" tyNumber Add

400+ [ binary "numNumber" "+" Add

406− , binary "numNumber" "-" "Num" tyNumber Subtract

401+ , binary "numNumber" "-" Subtract

407− , binary "numNumber" "*" "Num" tyNumber Multiply

402+ , binary "numNumber" "*" Multiply

408− , binary "numNumber" "/" "Num" tyNumber Divide

403+ , binary "numNumber" "/" Divide

409− , binary "numNumber" "%" "Num" tyNumber Modulus

404+ , binary "numNumber" "%" Modulus

410− , unary "numNumber" "negate" "Num" tyNumber Negate

405+ , unary "numNumber" "negate" Negate

411

406

412− , binary "ordNumber" "<" "Ord" tyNumber LessThan

407+ , binary "ordNumber" "<" LessThan

413− , binary "ordNumber" ">" "Ord" tyNumber GreaterThan

408+ , binary "ordNumber" ">" GreaterThan

414− , binary "ordNumber" "<=" "Ord" tyNumber LessThanOrEqualTo

409+ , binary "ordNumber" "<=" LessThanOrEqualTo

415− , binary "ordNumber" ">=" "Ord" tyNumber GreaterThanOrEqualTo

410+ , binary "ordNumber" ">=" GreaterThanOrEqualTo

416

411

417− , binary "eqNumber" "==" "Eq" tyNumber EqualTo

412+ , binary "eqNumber" "==" EqualTo

418− , binary "eqNumber" "/=" "Eq" tyNumber NotEqualTo

413+ , binary "eqNumber" "/=" NotEqualTo

419− , binary "eqString" "==" "Eq" tyString EqualTo

414+ , binary "eqString" "==" EqualTo

420− , binary "eqString" "/=" "Eq" tyString NotEqualTo

415+ , binary "eqString" "/=" NotEqualTo

421− , binary "eqBoolean" "==" "Eq" tyBoolean EqualTo

416+ , binary "eqBoolean" "==" EqualTo

422− , binary "eqBoolean" "/=" "Eq" tyBoolean NotEqualTo

417+ , binary "eqBoolean" "/=" NotEqualTo

423

418

424− , binaryFunction "bitsNumber" "shl" "Bits" tyNumber ShiftLeft

419+ , binaryFunction "bitsNumber" "shl" ShiftLeft

425− , binaryFunction "bitsNumber" "shr" "Bits" tyNumber ShiftRight

420+ , binaryFunction "bitsNumber" "shr" ShiftRight

426− , binaryFunction "bitsNumber" "zshr" "Bits" tyNumber ZeroFillShiftRight

421+ , binaryFunction "bitsNumber" "zshr" ZeroFillShiftRight

427− , binary "bitsNumber" "&" "Bits" tyNumber BitwiseAnd

422+ , binary "bitsNumber" "&" BitwiseAnd

428− , binary "bitsNumber" "|" "Bits" tyNumber BitwiseOr

423+ , binary "bitsNumber" "|" BitwiseOr

429− , binary "bitsNumber" "^" "Bits" tyNumber BitwiseXor

424+ , binary "bitsNumber" "^" BitwiseXor

430− , unary "bitsNumber" "complement" "Bits" tyNumber BitwiseNot

425+ , unary "bitsNumber" "complement" BitwiseNot

431

426

432− , binary "boolLikeBoolean" "&&" "BoolLike" tyBoolean And

427+ , binary "boolLikeBoolean" "&&" And

433− , binary "boolLikeBoolean" "||" "BoolLike" tyBoolean Or

428+ , binary "boolLikeBoolean" "||" Or

434− , unary "boolLikeBoolean" "not" "BoolLike" tyBoolean Not

429+ , unary "boolLikeBoolean" "not" Not

435 ]

430 ]

436 where

431 where

437− binary :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS

432+ binary :: String -> String -> BinaryOperator -> JS -> JS

438− binary dictName opString className classTy op = everywhere (mkT convert)

433+ binary dictName opString op = everywhere (mkT convert)

439 where

434 where

440 convert :: JS -> JS

435 convert :: JS -> JS

441− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y

436+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

442 convert other = other

437 convert other = other

443 isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True

438 isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True

444 isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True

439 isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True

445 isOp _ = False

440 isOp _ = False

446− binaryFunction :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS

441+ binaryFunction :: String -> String -> BinaryOperator -> JS -> JS

447− binaryFunction dictName fnName className classTy op = everywhere (mkT convert)

442+ binaryFunction dictName fnName op = everywhere (mkT convert)

448 where

443 where

449 convert :: JS -> JS

444 convert :: JS -> JS

450− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y

445+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

451 convert other = other

446 convert other = other

452 isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True

447 isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True

453 isOp _ = False

448 isOp _ = False

454− unary :: String -> String -> String -> Type -> UnaryOperator -> JS -> JS

449+ unary :: String -> String -> UnaryOperator -> JS -> JS

455− unary dictName fnName className classTy op = everywhere (mkT convert)

450+ unary dictName fnName op = everywhere (mkT convert)

456 where

451 where

457 convert :: JS -> JS

452 convert :: JS -> JS

458− convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName className classTy dict = JSUnary op x

453+ convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x

459 convert other = other

454 convert other = other

460 isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True

455 isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True

461 isOp _ = False

456 isOp _ = False

462− isOpDict dictName className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True

457+ isOpDict dictName (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True

463− isOpDict _ _ _ _ = False

458+ isOpDict _ _ = False

src/Language/PureScript/DeadCodeElimination.hs+5−6

@@ -25,22 +25,21 @@ import Data.Maybe (mapMaybe)

25import Language.PureScript.Names

26import Language.PureScript.Values

27import Language.PureScript.Declarations

28−import Language.PureScript.TypeChecker.Monad

30-- |

29-- |

31-- Eliminate all declarations which are not a transitive dependency of the entry point module

30-- Eliminate all declarations which are not a transitive dependency of the entry point module

32--

31--

33−eliminateDeadCode :: Environment -> [ModuleName] -> [Module] -> [Module]

32+eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]

34−eliminateDeadCode env entryPoints ms =

33+eliminateDeadCode entryPoints ms =

35− let declarations = concatMap (declarationsByModule env) ms

34+ let declarations = concatMap declarationsByModule ms

36 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

35 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

37 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

36 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

38 in flip map ms $ \(Module moduleName ds exps) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds) exps

37 in flip map ms $ \(Module moduleName ds exps) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds) exps

40type Key = (ModuleName, Either Ident ProperName)

39type Key = (ModuleName, Either Ident ProperName)

42−declarationsByModule :: Environment -> Module -> [(Key, [Key])]

41+declarationsByModule :: Module -> [(Key, [Key])]

43−declarationsByModule env (Module moduleName ds _) = concatMap go ds

42+declarationsByModule (Module moduleName ds _) = concatMap go ds

44 where

43 where

45 go :: Declaration -> [(Key, [Key])]

44 go :: Declaration -> [(Key, [Key])]

46 go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]

45 go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]

src/Language/PureScript/Sugar/DoNotation.hs−2

@@ -34,8 +34,6 @@ desugarDo = everywhereM (mkM replace)

34 where

35 prelude :: ModuleName

36 prelude = ModuleName [ProperName "Prelude"]

37− ret :: Value

38− ret = Var (Qualified (Just prelude) (Ident "ret"))

39 bind :: Value

37 bind :: Value

40 bind = Var (Qualified (Just prelude) (Op ">>="))

38 bind = Var (Qualified (Just prelude) (Op ">>="))

41 replace :: Value -> Either String Value

39 replace :: Value -> Either String Value

src/Language/PureScript/Sugar/Names.hs+50−52

@@ -17,13 +17,10 @@ module Language.PureScript.Sugar.Names (

17) where

19import Data.Maybe (fromMaybe)

20−import Data.Data

21import Data.Generics (extM, mkM, everywhereM)

20import Data.Generics (extM, mkM, everywhereM)

22import Data.Generics.Extras (mkS, extS, everywhereWithContextM')

21import Data.Generics.Extras (mkS, extS, everywhereWithContextM')

23−import Data.List (find)

25import Control.Applicative (Applicative(..), (<$>), (<*>))

23import Control.Applicative (Applicative(..), (<$>), (<*>))

26−import Control.Monad (foldM)

27import Control.Monad.Error

24import Control.Monad.Error

29import qualified Data.Map as M

26import qualified Data.Map as M

@@ -163,9 +160,9 @@ renameInModule imports exports (Module mn decls exps) =

163 updateVars (ValueDeclaration name [] Nothing val) =

160 updateVars (ValueDeclaration name [] Nothing val) =

164 ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

161 ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val

165 where

162 where

166− bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)

163+ bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')

167− bindFunctionArgs bound (Var name@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name)

164+ bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name')

168− bindFunctionArgs bound (Var name@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name)

165+ bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name')

169 bindFunctionArgs bound other = return (bound, other)

166 bindFunctionArgs bound other = return (bound, other)

170 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

167 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)

171 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

168 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)

@@ -182,25 +179,25 @@ renameInModule imports exports (Module mn decls exps) =

182 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

179 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

183

180

184 updateTypeName (Qualified Nothing name) = update "type" importedTypes name

181 updateTypeName (Qualified Nothing name) = update "type" importedTypes name

185− updateTypeName (Qualified (Just mn) name) = do

182+ updateTypeName (Qualified (Just mn') name) = do

186− modExports <- getExports mn

183+ modExports <- getExports mn'

187 case name `lookup` exportedTypes modExports of

184 case name `lookup` exportedTypes modExports of

188− Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn) name) ++ "'"

185+ Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn') name) ++ "'"

189− _ -> return $ Qualified (Just mn) name

186+ _ -> return $ Qualified (Just mn') name

190

187

191 updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name

188 updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name

192− updateDataConstructorName (Qualified (Just mn) name) = do

189+ updateDataConstructorName (Qualified (Just mn') name) = do

193− modExports <- getExports mn

190+ modExports <- getExports mn'

194 let allDcons = join $ snd `map` exportedTypes modExports

191 let allDcons = join $ snd `map` exportedTypes modExports

195 if name `elem` allDcons

192 if name `elem` allDcons

196− then return $ Qualified (Just mn) name

193+ then return $ Qualified (Just mn') name

197− else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn) name) ++ "'"

194+ else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn') name) ++ "'"

198−

195+

199 updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name

196 updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name

200− updateClassName (Qualified (Just mn) name) = check "type class" exportedTypeClasses mn name

197+ updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name

201−

198+

202 updateValueName (Qualified Nothing name) = update "value" importedValues name

199 updateValueName (Qualified Nothing name) = update "value" importedValues name

203− updateValueName (Qualified (Just mn) name) = check "value" exportedValues mn name

200+ updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name

204

201

205 -- Replace an unqualified name with a qualified

202 -- Replace an unqualified name with a qualified

206 update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)

203 update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)

@@ -208,15 +205,15 @@ renameInModule imports exports (Module mn decls exps) =

208

205

209 -- Check that a qualified name is valid

206 -- Check that a qualified name is valid

210 check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)

207 check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)

211− check t get mn name = do

208+ check t get mn' name = do

212− modExports <- getExports mn

209+ modExports <- getExports mn'

213 if name `elem` get modExports

210 if name `elem` get modExports

214− then return $ Qualified (Just mn) name

211+ then return $ Qualified (Just mn') name

215− else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn) name) ++ "'"

212+ else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"

216

213

217 -- Gets the exports for a module, or an error message if the module doesn't exist

214 -- Gets the exports for a module, or an error message if the module doesn't exist

218 getExports :: ModuleName -> Either String Exports

215 getExports :: ModuleName -> Either String Exports

219− getExports mn = maybe (throwError $ "Unknown module '" ++ show mn ++ "'") return $ M.lookup mn exports

216+ getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports

220

217

221-- |

218-- |

222-- Finds all exported declarations in a set of modules.

219-- Finds all exported declarations in a set of modules.

@@ -256,13 +253,13 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri

256filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment

253filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment

257filterExports mn exps env = do

254filterExports mn exps env = do

258 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

255 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

259− moduleExports' <- filterModule exps moduleExports

256+ moduleExports' <- filterModule moduleExports

260 return $ M.insert mn moduleExports' env

257 return $ M.insert mn moduleExports' env

261 where

258 where

262

259

263 -- Filter the exports for the specific module

260 -- Filter the exports for the specific module

264− filterModule :: [DeclarationRef] -> Exports -> Either String Exports

261+ filterModule :: Exports -> Either String Exports

265− filterModule exps exported = do

262+ filterModule exported = do

266 types <- foldM (filterTypes $ exportedTypes exported) [] exps

263 types <- foldM (filterTypes $ exportedTypes exported) [] exps

267 values <- foldM (filterValues $ exportedValues exported) [] exps

264 values <- foldM (filterValues $ exportedValues exported) [] exps

268 classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps

265 classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps

@@ -271,34 +268,34 @@ filterExports mn exps env = do

271 -- Ensure the exported types and data constructors exist in the module and add them to the set of

268 -- Ensure the exported types and data constructors exist in the module and add them to the set of

272 -- exports

269 -- exports

273 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either String [(ProperName, [ProperName])]

270 filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either String [(ProperName, [ProperName])]

274− filterTypes exps result (TypeRef name expDcons) = do

271+ filterTypes expTys result (TypeRef name expDcons) = do

275− dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` exps

272+ dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` expTys

276 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

273 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

277 return $ (name, dcons') : result

274 return $ (name, dcons') : result

278− filterTypes exps result _ = return result

275+ filterTypes _ result _ = return result

279

276

280 -- Ensure the exported data constructors exists for a type and add them to the list of exports

277 -- Ensure the exported data constructors exists for a type and add them to the list of exports

281 filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName]

278 filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName]

282− filterDcons tcon exps result name =

279+ filterDcons tcon exps' result name =

283− if name `elem` exps

280+ if name `elem` exps'

284 then return $ name : result

281 then return $ name : result

285 else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'"

282 else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'"

286

283

287 -- Ensure the exported classes exist in the module and add them to the set of exports

284 -- Ensure the exported classes exist in the module and add them to the set of exports

288 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either String [ProperName]

285 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either String [ProperName]

289− filterClasses exps result (TypeClassRef name) =

286+ filterClasses exps' result (TypeClassRef name) =

290− if name `elem` exps

287+ if name `elem` exps'

291 then return $ name : result

288 then return $ name : result

292 else throwError $ "Cannot export undefined type class '" ++ show name ++ "'"

289 else throwError $ "Cannot export undefined type class '" ++ show name ++ "'"

293− filterClasses exps result _ = return result

290+ filterClasses _ result _ = return result

294

291

295 -- Ensure the exported values exist in the module and add them to the set of exports

292 -- Ensure the exported values exist in the module and add them to the set of exports

296 filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either String [Ident]

293 filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either String [Ident]

297− filterValues exps result (ValueRef name) =

294+ filterValues exps' result (ValueRef name) =

298− if name `elem` exps

295+ if name `elem` exps'

299 then return $ name : result

296 then return $ name : result

300 else throwError $ "Cannot export undefined value '" ++ show name ++ "'"

297 else throwError $ "Cannot export undefined value '" ++ show name ++ "'"

301− filterValues exps result _ = return result

298+ filterValues _ result _ = return result

302

299

303-- |

300-- |

304-- Type representing a set of declarations being explicitly imported from a module

301-- Type representing a set of declarations being explicitly imported from a module

@@ -333,53 +330,54 @@ resolveImports env (Module currentModule decls _) =

333-- Extends the local environment for a module by resolving an import of another module.

330-- Extends the local environment for a module by resolving an import of another module.

334--

331--

335resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment

332resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment

336−resolveImport currentModule importModule exp imp i = case i of

333+resolveImport currentModule importModule exps imps i = case i of

337− Nothing -> importAll imp

334+ Nothing -> importAll

338− (Just expl) -> foldM importExplicit imp expl

335+ Just expl -> foldM importExplicit imps expl

339 where

336 where

340

337

341 -- Import everything from a module

338 -- Import everything from a module

342− importAll :: ImportEnvironment -> Either String ImportEnvironment

339+ importAll :: Either String ImportEnvironment

343− importAll imp = do

340+ importAll = do

344− imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imp (exportedTypes exp)

341+ imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imps (exportedTypes exps)

345− imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exp)

342+ imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps)

346− foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exp)

343+ foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

347

344

348 -- Import something explicitly

345 -- Import something explicitly

349 importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment

346 importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment

350 importExplicit imp (ValueRef name) = do

347 importExplicit imp (ValueRef name) = do

351− checkImportExists "value" values name

348+ _ <- checkImportExists "value" values name

352 values' <- updateImports (importedValues imp) name

349 values' <- updateImports (importedValues imp) name

353 return $ imp { importedValues = values' }

350 return $ imp { importedValues = values' }

354 importExplicit imp (TypeRef name dctors) = do

351 importExplicit imp (TypeRef name dctors) = do

355− checkImportExists "type" types name

352+ _ <- checkImportExists "type" types name

356 types' <- updateImports (importedTypes imp) name

353 types' <- updateImports (importedTypes imp) name

357 let allDctors = allExportedDataConstructors name

354 let allDctors = allExportedDataConstructors name

358 dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

355 dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

359 dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'

356 dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'

360 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }

357 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }

361 importExplicit imp (TypeClassRef name) = do

358 importExplicit imp (TypeClassRef name) = do

362− checkImportExists "type class" classes name

359+ _ <- checkImportExists "type class" classes name

363 typeClasses' <- updateImports (importedTypeClasses imp) name

360 typeClasses' <- updateImports (importedTypeClasses imp) name

364 return $ imp { importedTypeClasses = typeClasses' }

361 return $ imp { importedTypeClasses = typeClasses' }

365

362

366 -- Find all exported data constructors for a given type

363 -- Find all exported data constructors for a given type

367 allExportedDataConstructors :: ProperName -> [ProperName]

364 allExportedDataConstructors :: ProperName -> [ProperName]

368− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exp

365+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps

369

366

370 -- Add something to the ImportEnvironment if it does not already exist there

367 -- Add something to the ImportEnvironment if it does not already exist there

371 updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))

368 updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))

372 updateImports m name = case M.lookup name m of

369 updateImports m name = case M.lookup name m of

373 Nothing -> return $ M.insert name (Qualified (Just importModule) name) m

370 Nothing -> return $ M.insert name (Qualified (Just importModule) name) m

371+ Just (Qualified Nothing _) -> error "Invalid state in updateImports"

374 Just x@(Qualified (Just mn) _) -> throwError $

372 Just x@(Qualified (Just mn) _) -> throwError $

375 if mn == currentModule || importModule == currentModule

373 if mn == currentModule || importModule == currentModule

376 then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"

374 then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"

377 else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"

375 else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"

378

376

379 -- The available values, types, and classes in the module being imported

377 -- The available values, types, and classes in the module being imported

380− values = exportedValues exp

378+ values = exportedValues exps

381− types = fst `map` exportedTypes exp

379+ types = fst `map` exportedTypes exps

382− classes = exportedTypeClasses exp

380+ classes = exportedTypeClasses exps

383

381

384 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

382 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

385 -- from

383 -- from

src/Language/PureScript/Sugar/TypeClasses.hs+1−5

@@ -33,8 +33,7 @@ import Control.Applicative

33import Control.Monad.State

34import Control.Arrow (second)

36−import Data.List (intercalate)

37−import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)

36+import Language.PureScript.CodeGen.Common (identToJs)

39type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])

38type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])

@@ -155,9 +154,6 @@ typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclarat

155 lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members

154 lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members

156typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"

155typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"

157

156

158−qualifiedToString :: ModuleName -> Qualified ProperName -> String

159−qualifiedToString mn (Qualified _ pn) = moduleNameToJs mn ++ "_" ++ runProperName pn

160−

161-- |

157-- |

162-- Generate a name for a type class dictionary member, based on the module name, class name, type name and

158-- Generate a name for a type class dictionary member, based on the module name, class name, type name and

163-- member name

159-- member name

src/Language/PureScript/TypeChecker.hs+2−6

@@ -29,14 +29,12 @@ import Data.Maybe

29import qualified Data.Map as M

30import Control.Monad.State

31import Control.Monad.Error

32−import Data.Either (rights, lefts)

34import Language.PureScript.Types

33import Language.PureScript.Types

35import Language.PureScript.Names

34import Language.PureScript.Names

36import Language.PureScript.Values

35import Language.PureScript.Values

37import Language.PureScript.Kinds

36import Language.PureScript.Kinds

38import Language.PureScript.Declarations

37import Language.PureScript.Declarations

39−import Language.PureScript.Sugar.TypeClasses

40import Language.PureScript.Prim

38import Language.PureScript.Prim

42addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

40addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()

@@ -79,7 +77,7 @@ addTypeClassDictionaries entries =

80checkTypeClassInstance :: ModuleName -> Type -> Check ()

78checkTypeClassInstance :: ModuleName -> Type -> Check ()

81checkTypeClassInstance _ (TypeVar _) = return ()

79checkTypeClassInstance _ (TypeVar _) = return ()

82−checkTypeClassInstance m (TypeConstructor ctor) = do

80+checkTypeClassInstance _ (TypeConstructor ctor) = do

83 env <- getEnv

81 env <- getEnv

84 when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"

82 when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"

85 return ()

83 return ()

@@ -170,7 +168,7 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d

170 env <- getEnv

168 env <- getEnv

171 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env

169 guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env

172 return $ d : ds

170 return $ d : ds

173−typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

171+typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _) : rest) = do

174 env <- getEnv

172 env <- getEnv

175 let instances = filter (\tcd ->

173 let instances = filter (\tcd ->

176 let Qualified (Just mn) _ = tcdName tcd in

174 let Qualified (Just mn) _ = tcdName tcd in

@@ -182,11 +180,9 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

182 ds <- typeCheckAll mainModuleName currentModule rest

180 ds <- typeCheckAll mainModuleName currentModule rest

183 return $ d : ds

181 return $ d : ds

184typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do

182typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do

185− env <- getEnv

186 ds <- typeCheckAll mainModuleName moduleName rest

183 ds <- typeCheckAll mainModuleName moduleName rest

187 return $ d : ds

184 return $ d : ds

188typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do

185typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do

189− env <- getEnv

190 mapM_ (checkTypeClassInstance moduleName) tys

186 mapM_ (checkTypeClassInstance moduleName) tys

191 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

187 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

192 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]

188 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]

src/Language/PureScript/TypeChecker/Kinds.hs−1

@@ -132,7 +132,6 @@ infer (TypeVar v) = do

132 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

133infer (TypeConstructor v) = do

134 env <- liftCheck getEnv

135− Just moduleName <- checkCurrentModule <$> get

136 case M.lookup v (types env) of

135 case M.lookup v (types env) of

137 Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'" ++ show (M.keys (types env))

136 Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'" ++ show (M.keys (types env))

138 Just kind -> return kind

137 Just kind -> return kind

src/Language/PureScript/TypeChecker/Monad.hs−2

@@ -25,9 +25,7 @@ import Language.PureScript.Names

25import Language.PureScript.Declarations

26import Language.PureScript.Prim

28−import Data.Data

29import Data.Maybe

28import Data.Maybe

30−import Data.Generics (mkT, everywhere)

32import Control.Applicative

30import Control.Applicative

33import Control.Monad.State

31import Control.Monad.State

src/Language/PureScript/TypeChecker/Synonyms.hs+7−8

@@ -20,7 +20,6 @@ module Language.PureScript.TypeChecker.Synonyms (

21import Language.PureScript.Types

22import Language.PureScript.Names

23−import Language.PureScript.TypeChecker.Monad (Environment(..))

25import Control.Applicative ((<$>))

24import Control.Applicative ((<$>))

26import Data.Maybe (fromMaybe)

25import Data.Maybe (fromMaybe)

@@ -33,8 +32,8 @@ import Control.Monad.Error

33-- |

32-- |

34-- Build a type substitution for a type synonym

33-- Build a type substitution for a type synonym

35--

34--

36−buildTypeSubstitution :: Environment -> ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type)

35+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)

37−buildTypeSubstitution env moduleName name n = go n []

36+buildTypeSubstitution name n = go n []

38 where

37 where

39 go :: Int -> [Type] -> Type -> Either String (Maybe Type)

38 go :: Int -> [Type] -> Type -> Either String (Maybe Type)

40 go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)

39 go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)

@@ -45,16 +44,16 @@ buildTypeSubstitution env moduleName name n = go n []

45-- |

44-- |

46-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor

45-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor

47--

46--

48−saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> Qualified ProperName -> Int -> d -> Either String d

47+saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d

49−saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)

48+saturateTypeSynonym name n = everywhereM' (mkM replace)

50 where

49 where

51− replace t = fromMaybe t <$> buildTypeSubstitution env moduleName name n t

50+ replace t = fromMaybe t <$> buildTypeSubstitution name n t

53-- |

52-- |

54-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor

53-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor

55--

54--

56−saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d

55+saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d

57−saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns

56+saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns

src/Language/PureScript/TypeChecker/Types.hs+19−46

@@ -107,9 +107,7 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

107 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

108 unifyTypes' (Object row1) (Object row2) = row1 =?= row2

109 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

110− unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

110+ unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =

111− env <- getEnv

112− Just moduleName <- checkCurrentModule <$> get

113 guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)

111 guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)

114 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

112 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

115 t3 `unifyTypes` t5

113 t3 `unifyTypes` t5

@@ -307,10 +305,10 @@ typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String

307typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []

305typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []

308typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)]

306typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)]

309typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

307typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

310−typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

308+typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

311typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

309typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

312typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

310typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

313−typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of

311+typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of

314 Left _ -> Nothing

312 Left _ -> Nothing

315 Right t1 -> typeHeadsAreEqual m e t1 t2

313 Right t1 -> typeHeadsAreEqual m e t1 t2

316typeHeadsAreEqual _ _ _ _ = Nothing

314typeHeadsAreEqual _ _ _ _ = Nothing

@@ -408,8 +406,6 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do

408 ty' <- replaceVarWithUnknown ident ty

406 ty' <- replaceVarWithUnknown ident ty

409 instantiatePolyTypeWithUnknowns val ty'

407 instantiatePolyTypeWithUnknowns val ty'

410instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

408instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

411− env <- getEnv

412− Just moduleName <- checkCurrentModule <$> get

413 dicts <- getTypeClassDictionaries

409 dicts <- getTypeClassDictionaries

414 (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty

410 (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty

415 return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')

411 return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')

@@ -427,18 +423,17 @@ replaceVarWithUnknown ident ty = do

427-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

423-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

428-- better error messages during unification.

424-- better error messages during unification.

429--

425--

430−replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d

426+replaceAllTypeSynonyms' :: (D.Data d) => Environment -> d -> Either String d

431−replaceAllTypeSynonyms' env moduleName d =

427+replaceAllTypeSynonyms' env d =

432 let

428 let

433 syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

429 syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

434 in

430 in

435− saturateAllTypeSynonyms env moduleName syns d

431+ saturateAllTypeSynonyms syns d

436

432

437replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d

433replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d

438replaceAllTypeSynonyms d = do

434replaceAllTypeSynonyms d = do

439 env <- getEnv

435 env <- getEnv

440− Just moduleName <- checkCurrentModule <$> get

441− either throwError return $ replaceAllTypeSynonyms' env moduleName d

436+ either throwError return $ replaceAllTypeSynonyms' env d

442

437

443-- |

438-- |

444-- \"Desaturate\" @SaturatedTypeSynonym@s

439-- \"Desaturate\" @SaturatedTypeSynonym@s

@@ -452,19 +447,18 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

452-- |

447-- |

453-- Replace a type synonym and its arguments with the aliased type

448-- Replace a type synonym and its arguments with the aliased type

454--

449--

455−expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type

450+expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type

456−expandTypeSynonym' env moduleName name args =

451+expandTypeSynonym' env name args =

457 case M.lookup name (typeSynonyms env) of

452 case M.lookup name (typeSynonyms env) of

458 Just (synArgs, body) -> do

453 Just (synArgs, body) -> do

459 let repl = replaceAllTypeVars (zip synArgs args) body

454 let repl = replaceAllTypeVars (zip synArgs args) body

460− replaceAllTypeSynonyms' env moduleName repl

455+ replaceAllTypeSynonyms' env repl

461 Nothing -> error "Type synonym was not defined"

456 Nothing -> error "Type synonym was not defined"

462

457

463expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type

458expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type

464expandTypeSynonym name args = do

459expandTypeSynonym name args = do

465 env <- getEnv

460 env <- getEnv

466− Just moduleName <- checkCurrentModule <$> get

467− either throwError return $ expandTypeSynonym' env moduleName name args

461+ either throwError return $ expandTypeSynonym' env name args

468

462

469-- |

463-- |

470-- Ensure a set of property names and value does not contain duplicate labels

464-- Ensure a set of property names and value does not contain duplicate labels

@@ -531,13 +525,11 @@ infer' (Var var) = do

531 ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

525 ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var

532 case ty of

526 case ty of

533 ConstrainedType constraints ty' -> do

527 ConstrainedType constraints ty' -> do

534− env <- getEnv

535 dicts <- getTypeClassDictionaries

528 dicts <- getTypeClassDictionaries

536 return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'

529 return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'

537 _ -> return $ TypedValue True (Var var) ty

530 _ -> return $ TypedValue True (Var var) ty

538infer' v@(Constructor c) = do

531infer' v@(Constructor c) = do

539 env <- getEnv

532 env <- getEnv

540− Just moduleName <- checkCurrentModule <$> get

541 case M.lookup c (dataConstructors env) of

533 case M.lookup c (dataConstructors env) of

542 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

534 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

543 Just ty -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

535 Just ty -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

@@ -588,14 +580,13 @@ inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty

588inferBinder val (VarBinder name) = return $ M.singleton name val

580inferBinder val (VarBinder name) = return $ M.singleton name val

589inferBinder val (ConstructorBinder ctor binders) = do

581inferBinder val (ConstructorBinder ctor binders) = do

590 env <- getEnv

582 env <- getEnv

591− Just moduleName <- checkCurrentModule <$> get

592 case M.lookup ctor (dataConstructors env) of

583 case M.lookup ctor (dataConstructors env) of

593 Just ty -> do

584 Just ty -> do

594 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty

585 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty

595 go binders fn

586 go binders fn

596 where

587 where

597 go [] ty' = do

588 go [] ty' = do

598− subsumes Nothing val ty'

589+ _ <- subsumes Nothing val ty'

599 return M.empty

590 return M.empty

600 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =

591 go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =

601 M.union <$> inferBinder obj binder <*> go binders' ret

592 M.union <$> inferBinder obj binder <*> go binders' ret

@@ -648,17 +639,6 @@ checkBinders nvals ret (CaseAlternative binders grd val : bs) = do

648 rs <- checkBinders nvals ret bs

639 rs <- checkBinders nvals ret bs

649 return $ r : rs

640 return $ r : rs

650

641

651−-- |

652−-- Check that a local variable name is not already used

653−--

654−assignVariable :: Ident -> UnifyT Type Check ()

655−assignVariable name = do

656− env <- checkEnv <$> get

657− Just moduleName <- checkCurrentModule <$> get

658− case M.lookup (moduleName, name) (names env) of

659− Just _ -> UnifyT . lift . throwError $ "Variable with name " ++ show name ++ " already exists."

660− _ -> return ()

661−

662-- |

642-- |

663-- Generate a new skolem constant

643-- Generate a new skolem constant

664--

644--

@@ -711,8 +691,6 @@ check' val (ForAll ident ty _) = do

711 val' <- check val sk

691 val' <- check val sk

712 return $ TypedValue True val' (ForAll ident ty (Just scope))

692 return $ TypedValue True val' (ForAll ident ty (Just scope))

713check' val t@(ConstrainedType constraints ty) = do

693check' val t@(ConstrainedType constraints ty) = do

714− env <- getEnv

715− Just moduleName <- checkCurrentModule <$> get

716 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

694 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

717 n <- liftCheck freshDictionaryName

695 n <- liftCheck freshDictionaryName

718 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

696 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

@@ -747,7 +725,7 @@ check' (Abs (Right _) _) _ = error "Binder was not desugared"

747check' (App f arg) ret = do

725check' (App f arg) ret = do

748 f'@(TypedValue _ _ ft) <- infer f

726 f'@(TypedValue _ _ ft) <- infer f

749 (ret', app) <- checkFunctionApplication f' ft arg

727 (ret', app) <- checkFunctionApplication f' ft arg

750− subsumes Nothing ret' ret

728+ _ <- subsumes Nothing ret' ret

751 return $ TypedValue True app ret

729 return $ TypedValue True app ret

752check' v@(Var var) ty = do

730check' v@(Var var) ty = do

753 Just moduleName <- checkCurrentModule <$> get

731 Just moduleName <- checkCurrentModule <$> get

@@ -797,7 +775,6 @@ check' (Accessor prop val) ty = do

797 return $ TypedValue True (Accessor prop val') ty

775 return $ TypedValue True (Accessor prop val') ty

798check' (Constructor c) ty = do

776check' (Constructor c) ty = do

799 env <- getEnv

777 env <- getEnv

800− Just moduleName <- checkCurrentModule <$> get

801 case M.lookup c (dataConstructors env) of

778 case M.lookup c (dataConstructors env) of

802 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

779 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

803 Just ty1 -> do

780 Just ty1 -> do

@@ -875,9 +852,7 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg = do

875 ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

852 ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

876 checkFunctionApplication fn ty arg

853 checkFunctionApplication fn ty arg

877checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do

854checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do

878− env <- getEnv

879 dicts <- getTypeClassDictionaries

855 dicts <- getTypeClassDictionaries

880− Just moduleName <- checkCurrentModule <$> get

881 checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg

856 checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg

882checkFunctionApplication' _ fnTy arg = throwError $ "Cannot apply a function of type "

857checkFunctionApplication' _ fnTy arg = throwError $ "Cannot apply a function of type "

883 ++ prettyPrintType fnTy

858 ++ prettyPrintType fnTy

@@ -910,8 +885,8 @@ subsumes' val ty1 (ForAll ident ty2 sco) =

910 subsumes val ty1 sk

885 subsumes val ty1 sk

911 Nothing -> throwError "Skolem variable scope is unspecified"

886 Nothing -> throwError "Skolem variable scope is unspecified"

912subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

887subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

913− subsumes Nothing arg2 arg1

888+ _ <- subsumes Nothing arg2 arg1

914− subsumes Nothing ret1 ret2

889+ _ <- subsumes Nothing ret1 ret2

915 return val

890 return val

916subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do

891subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do

917 ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

892 ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

@@ -920,9 +895,7 @@ subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do

920 ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

895 ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

921 subsumes val ty1 ty2

896 subsumes val ty1 ty2

922subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

897subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

923− env <- getEnv

924 dicts <- getTypeClassDictionaries

898 dicts <- getTypeClassDictionaries

925− Just moduleName <- checkCurrentModule <$> get

926 _ <- subsumes' Nothing ty1 ty2

899 _ <- subsumes' Nothing ty1 ty2

927 return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)

900 return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)

928subsumes' val (Object r1) (Object r2) = do

901subsumes' val (Object r1) (Object r2) = do

@@ -937,14 +910,14 @@ subsumes' val (Object r1) (Object r2) = do

937 go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')

910 go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')

938 go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')

911 go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')

939 go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'

912 go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'

940− | p1 == p2 = do subsumes Nothing ty1 ty2

913+ | p1 == p2 = do _ <- subsumes Nothing ty1 ty2

941 go ts1 ts2 r1' r2'

914 go ts1 ts2 r1' r2'

942 | p1 < p2 = do rest <- fresh

915 | p1 < p2 = do rest <- fresh

943 r2' =?= RCons p1 ty1 rest

916 r2' =?= RCons p1 ty1 rest

944 go ts1 ((p2, ty2) : ts2) r1' rest

917 go ts1 ((p2, ty2) : ts2) r1' rest

945− | p1 > p2 = do rest <- fresh

918+ | otherwise = do rest <- fresh

946− r1' =?= RCons p2 ty2 rest

919+ r1' =?= RCons p2 ty2 rest

947− go ((p1, ty1) : ts1) ts2 rest r2'

920+ go ((p1, ty1) : ts1) ts2 rest r2'

948subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1

921subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1

949subsumes' val ty1 ty2 = do

922subsumes' val ty1 ty2 = do

950 ty1 =?= ty2

923 ty1 =?= ty2

src/Language/PureScript/Types.hs+1

@@ -146,6 +146,7 @@ replaceTypeVars = replaceTypeVars' []

146 go _ ty = ty

147 genName orig inUse = try 0

148 where

149+ try :: Integer -> String

149 try n | (orig ++ show n) `elem` inUse = try (n + 1)

150 try n | (orig ++ show n) `elem` inUse = try (n + 1)

150 | otherwise = orig ++ show n

151 | otherwise = orig ++ show n

151

152