495eeec · rowtype-yoga/purescript-native

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

Merge remote-tracking branch 'garyb/renaming' into renaming

Conflicts: prelude/prelude.purs

commit495eeec678e911e522ef74df5fbd623d7e2ed104 authorPhil Freeman <paf31@cantab.net> dateSun 2 Mar 2014, 11:07 (13 years ago) parentae55638 1029861

18 files changed+378−191

compare with golang

unifiedsplit

examples/failing/ImportExplicit.pursnew file+14

@@ -0,0 +1,14 @@

1+module M1 where

3+ data X = X | Y

4+ data Z = Z

6+module Main where

8+ import M1 (X)

10+ testX = X

11+ testY = Y

12+ testZ = Z

13+

14+ main = Debug.Trace.trace "Done"

examples/passing/ImportExplicit.pursnew file+13

@@ -0,0 +1,13 @@

1+module M1 where

3+ data X = X | Y

4+ data Z = Z

6+module Main where

8+ import M1 (X)

10+ testX = X

11+ testY = Y

12+

13+ main = Debug.Trace.trace "Done"

prelude/prelude.purs+19−16

@@ -42,7 +42,7 @@ module Prelude where

4242 \ return n.toString();\

4343 \}" :: Number -> String

4444

45− instance Prelude.Show Number where

45+ instance Show Number where

4646 show = showNumber

4747

4848 class Read a where

@@ -439,22 +439,22 @@ module Data.Maybe where

439439 maybe _ f (Just a) = f a

440440

441441 fromMaybe :: forall a. a -> Maybe a -> a

442− fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)

442+ fromMaybe a = maybe a (id :: forall a. a -> a)

443443

444− instance Prelude.Monad Maybe where

444+ instance Monad Maybe where

445445 return = Just

446446 (>>=) m f = maybe Nothing f m

447447

448− instance Prelude.Applicative Maybe where

448+ instance Applicative Maybe where

449449 pure = Just

450450 (<*>) (Just fn) x = fn <$> x

451451 (<*>) Nothing _ = Nothing

452452

453− instance Prelude.Functor Maybe where

453+ instance Functor Maybe where

454454 (<$>) fn (Just x) = Just (fn x)

455455 (<$>) _ _ = Nothing

456456

457− instance (Show a) => Prelude.Show (Maybe a) where

457+ instance (Show a) => Show (Maybe a) where

458458 show (Just x) = "Just " ++ (show x)

459459 show Nothing = "Nothing"

460460

@@ -468,20 +468,20 @@ module Data.Either where

468468 either f _ (Left a) = f a

469469 either _ g (Right b) = g b

470470

471− instance Prelude.Monad (Either e) where

471+ instance Monad (Either e) where

472472 return = Right

473473 (>>=) = either (\e _ -> Left e) (\a f -> f a)

474474

475− instance Prelude.Applicative (Either e) where

475+ instance Applicative (Either e) where

476476 pure = Right

477477 (<*>) (Left e) _ = Left e

478478 (<*>) (Right f) r = f <$> r

479479

480− instance Prelude.Functor (Either a) where

480+ instance Functor (Either a) where

481481 (<$>) _ (Left x) = Left x

482482 (<$>) f (Right y) = Right (f y)

483483

484− instance (Show a, Show b) => Prelude.Show (Either a b) where

484+ instance (Show a, Show b) => Show (Either a b) where

485485 show (Left x) = "Left " ++ (show x)

486486 show (Right y) = "Right " ++ (show y)

487487

@@ -662,16 +662,17 @@ module Data.Array where

662662 take n (x:xs) = x : take (n - 1) xs

663663

664664 instance (Prelude.Show a) => Prelude.Show [a] where

665+ instance (Show a) => Show [a] where

665666 show xs = "[" ++ joinWith (map show xs) "," ++ "]"

666667

667− instance Prelude.Functor [] where

668+ instance Functor [] where

668669 (<$>) = map

669670

670− instance Prelude.Monad [] where

671+ instance Monad [] where

671672 return = singleton

672673 (>>=) = concatMap

673674

674− instance Prelude.Alternative [] where

675+ instance Alternative [] where

675676 empty = []

676677 (<|>) = concat

677678

@@ -690,7 +691,7 @@ module Data.Tuple where

690691

691692 data Tuple a b = Tuple a b

692693

693− instance (Prelude.Show a, Prelude.Show b) => Prelude.Show (Tuple a b) where

694+ instance (Show a, Show b) => Show (Tuple a b) where

694695 show (Tuple a b) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"

695696

696697 curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c

@@ -944,6 +945,8 @@ module Math where

944945

945946module Control.Monad.Eff where

946947

948+ import Prelude

949+

947950 foreign import data Eff :: # ! -> * -> *

948951

949952 foreign import retEff "function retEff(a) {\

@@ -966,7 +969,7 @@ module Control.Monad.Eff where

966969 \ return f();\

967970 \}" :: forall a. Pure a -> a

968971

969− instance Prelude.Monad (Eff e) where

972+ instance Monad (Eff e) where

970973 return = retEff

971974 (>>=) = bindEff

972975

@@ -1109,7 +1112,7 @@ module Debug.Trace where

11091112 \ };\

11101113 \}" :: forall r. String -> Eff (trace :: Trace | r) {}

11111114

1112− print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}

1115+ print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}

11131116 print o = trace (show o)

11141117

11151118module Control.Monad.ST where

purescript.cabal+1

@@ -43,6 +43,7 @@ library

4343 Language.PureScript.Sugar.Operators

4444 Language.PureScript.Sugar.TypeClasses

4545 Language.PureScript.Sugar.Let

46+ Language.PureScript.Sugar.Names

4647 Language.PureScript.CodeGen

4748 Language.PureScript.CodeGen.Common

4849 Language.PureScript.CodeGen.Externs

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

@@ -42,7 +42,7 @@ declToPs path env (BindingGroupDeclaration vals) =

4242 (ty, _) <- M.lookup (path, name) $ names env

4343 return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

4444declToPs path env (DataDeclaration name _ _) = maybeToList $ do

45− (kind, _) <- M.lookup (path, name) $ types env

45+ kind <- M.lookup (Qualified (Just path) name) $ types env

4646 return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

4747declToPs _ _ (ExternDataDeclaration name kind) =

4848 return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

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

@@ -43,7 +43,6 @@ import Language.PureScript.CodeGen.JS.AST as AST

4343import Language.PureScript.Types

4444import Language.PureScript.CodeGen.Optimize

4545import Language.PureScript.CodeGen.Common

46−import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)

4746

4847-- |

4948-- Generate code in the simplified Javascript intermediate representation for all declarations in a

@@ -121,10 +120,6 @@ valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b

121120valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)

122121valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)

123122valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar "Object")) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]

124−valueToJs _ m e (Constructor (Qualified Nothing name)) =

125− case M.lookup (m, name) (dataConstructors e) of

126− Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS m id (Qualified (Just aliasModule) aliasIdent)

127− _ -> JSVar . runProperName $ name

128123valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name

129124valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)

130125valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)

@@ -262,7 +257,7 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do

262257 then

263258 return js

264259 else

265− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor))))

260+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ctor)))

266261 (JSBlock js)

267262 Nothing]

268263 where

@@ -313,10 +308,10 @@ binderToJs m e varName done (NamedBinder ident binder) = do

313308--

314309isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool

315310isOnlyConstructor m e ctor =

316− let (ty, _) = fromMaybe (error "Data constructor not found") $ qualify m ctor `M.lookup` dataConstructors e

311+ let ty = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

317312 in numConstructors ty == 1

318313 where

319− numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e

314+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.elems $ dataConstructors e

320315 typeConstructor (TypeConstructor qual) = qualify m qual

321316 typeConstructor (ForAll _ ty _) = typeConstructor ty

322317 typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty

src/Language/PureScript/DeadCodeElimination.hs+2−1

@@ -55,7 +55,8 @@ dependencies env moduleName = nub . everything (++) (mkQ [] values)

5555 where

5656 values :: Value -> [Key]

5757 values (Var ident) = let (mn, name) = canonicalize moduleName env ident in [(mn, Left name)]

58− values (Constructor pn) = let (mn, name) = canonicalizeDataConstructor moduleName env pn in [(mn, Right name)]

58+ values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]

59+ values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"

5960 values _ = []

6061

6162isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool

src/Language/PureScript/Declarations.hs+38−1

@@ -65,6 +65,20 @@ data ForeignImportType

6565 --

6666 | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)

6767

68+-- |

69+-- An item in a list of explicit imports

70+--

71+data ImportType

72+ -- |

73+ -- A type constructor import

74+ --

75+ = TypeImport ProperName

76+ -- |

77+ -- A declaration import

78+ --

79+ | NameImport Ident

80+ deriving (Show, D.Data, D.Typeable)

81+

6882-- |

6983-- The data type of declarations

7084--

@@ -108,7 +122,7 @@ data Declaration

108122 -- |

109123 -- A module import (module name, optional set of identifiers to import)

110124 --

111− | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])

125+ | ImportDeclaration ModuleName (Maybe [ImportType])

112126 -- |

113127 -- A type class declaration (name, argument, member declarations)

114128 --

@@ -169,3 +183,26 @@ isTypeClassDeclaration :: Declaration -> Bool

169183isTypeClassDeclaration TypeClassDeclaration{} = True

170184isTypeClassDeclaration TypeInstanceDeclaration{} = True

171185isTypeClassDeclaration _ = False

186+

187+-- |

188+-- Extracts names from a list of explicit imports.

189+--

190+nameImports :: [ImportType] -> [Ident]

191+nameImports ((NameImport ident):xs) = ident : nameImports xs

192+nameImports (_ : xs) = nameImports xs

193+nameImports _ = []

194+

195+-- |

196+-- Extracts types from a list of explicit imports.

197+--

198+typeImports :: [ImportType] -> [ProperName]

199+typeImports (TypeImport ident : xs) = ident : typeImports xs

200+typeImports (_ : xs) = typeImports xs

201+typeImports _ = []

202+

203+-- |

204+-- Extracts classes from a list of explicit imports.

205+-- note: class imports are indistinguishable from types at the moment

206+--

207+classImports :: [ImportType] -> [ProperName]

208+classImports = typeImports

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

@@ -88,7 +88,7 @@ parseImportDeclaration = do

8888 reserved "import"

8989 indented

9090 moduleName' <- moduleName

91− idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)

91+ idents <- P.optionMaybe $ parens $ commaSep1 (NameImport <$> parseIdent <|> TypeImport <$> properName)

9292 return $ ImportDeclaration moduleName' idents

9393

9494parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

src/Language/PureScript/Sugar.hs+3−1

@@ -27,6 +27,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S

2727import Language.PureScript.Sugar.BindingGroups as S

2828import Language.PureScript.Sugar.TypeClasses as S

2929import Language.PureScript.Sugar.Let as S

30+import Language.PureScript.Sugar.Names as S

3031

3132-- |

3233-- The desugaring pipeline proceeds as follows:

@@ -46,7 +47,8 @@ import Language.PureScript.Sugar.Let as S

4647-- * Group mutually recursive value and data declarations into binding groups.

4748--

4849desugar :: [Module] -> Either String [Module]

49−desugar = desugarTypeClasses

50+desugar = rename

51+ >=> desugarTypeClasses

5052 >=> rebracket

5153 >=> desugarDo

5254 >=> desugarLetBindings

src/Language/PureScript/Sugar/BindingGroups.hs+4−4

@@ -52,7 +52,7 @@ createBindingGroups moduleName ds = do

5252 let values = filter isValueDecl ds

5353 dataDecls = filter isDataDecl ds

5454 allProperNames = map getProperName dataDecls

55− dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls

55+ dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls

5656 dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

5757 let allIdents = map getIdent values

5858 valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values

@@ -83,11 +83,11 @@ usedIdents moduleName = nub . everything (++) (mkQ [] names)

8383 names (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

8484 names _ = []

8585

86−usedProperNames :: (Data d) => d -> [ProperName]

87−usedProperNames = nub . everything (++) (mkQ [] names)

86+usedProperNames :: (Data d) => ModuleName -> d -> [ProperName]

87+usedProperNames moduleName = nub . everything (++) (mkQ [] names)

8888 where

8989 names :: Type -> [ProperName]

90− names (TypeConstructor (Qualified Nothing name)) = [name]

90+ names (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

9191 names _ = []

9292

9393getIdent :: Declaration -> Ident

src/Language/PureScript/Sugar/Names.hsnew file+205

@@ -0,0 +1,205 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.Names

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.Sugar.Names (

16+ rename

17+) where

18+

19+import Control.Applicative ((<$>))

20+import Control.Monad (foldM, liftM)

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

22+import Data.List (intersect)

23+import qualified Data.Map as M

24+import qualified Data.Set as S

25+import Language.PureScript.Declarations

26+import Language.PureScript.Names

27+import Language.PureScript.Types

28+import Language.PureScript.Values

29+

30+-- |

31+-- The global export environment - every declaration exported from every module

32+--

33+data ExportEnvironment = ExportEnvironment

34+ -- |

35+ -- The types exported from each module

36+ --

37+ { exportedTypes :: M.Map ModuleName (S.Set ProperName)

38+ -- |

39+ -- The data constructors exported from each module, grouped by type constructor

40+ --

41+ , exportedDataConstructors :: M.Map ModuleName (S.Set (ProperName, [ProperName]))

42+ -- |

43+ -- The classes exported from each module

44+ --

45+ , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)

46+ } deriving (Show)

47+

48+-- |

49+-- An imported environment for a particular module. This also contains the module's own members.

50+--

51+data ImportEnvironment = ImportEnvironment

52+ -- |

53+ -- Local names for types within a module mapped to to their qualified names

54+ --

55+ { importedTypes :: M.Map ProperName (Qualified ProperName)

56+ -- |

57+ -- Local names for data constructors within a module mapped to to their qualified names

58+ --

59+ , importedDataConstructors :: M.Map ProperName (Qualified ProperName)

60+ -- |

61+ -- Local names for classes within a module mapped to to their qualified names

62+ --

63+ , importedTypeClasses :: M.Map ProperName (Qualified ProperName)

64+ } deriving (Show)

65+

66+-- |

67+-- Adds a type belonging to a module to the export environment.

68+--

69+addType :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment

70+addType env mn name = do

71+ types <- addExport (exportedTypes env) mn name

72+ return $ env { exportedTypes = types }

73+

74+-- |

75+-- Adds a group of data constructors with their associated type constructor the export environment.

76+--

77+addDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment

78+addDataConstructors env mn tcon dcons = do

79+ dataConstructors <- addExport (exportedDataConstructors env) mn (tcon, dcons)

80+ return $ env { exportedDataConstructors = dataConstructors }

81+

82+-- |

83+-- Adds a class to the export environment.

84+--

85+addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment

86+addTypeclass env mn name = do

87+ classes <- addExport (exportedTypeClasses env) mn name

88+ return $ env { exportedTypeClasses = classes }

89+

90+-- |

91+-- Adds an export to a map of exports of that type.

92+--

93+addExport :: (Ord s, Show s) => M.Map ModuleName (S.Set s) -> ModuleName -> s -> Either String (M.Map ModuleName (S.Set s))

94+addExport exports mn name = case M.lookup mn exports of

95+ Just s -> if S.member name s

96+ then Left $ "Module '" ++ show mn ++ "' has multiple definitions for '" ++ show name ++ "'"

97+ else Right $ M.insert mn (S.insert name s) exports

98+ Nothing -> Right $ M.insert mn (S.singleton name) exports

99+

100+-- |

101+-- Replaces all local names with qualified names within a set of modules.

102+--

103+rename :: [Module] -> Either String [Module]

104+rename modules = do

105+ exports <- findExports modules

106+ mapM (renameInModule' exports) modules

107+ where

108+ renameInModule' exports m = do

109+ imports <- resolveImports exports m

110+ renameInModule imports m

111+

112+-- |

113+-- Replaces all local names with qualified names within a module.

114+--

115+renameInModule :: ImportEnvironment -> Module -> Either String Module

116+renameInModule imports (Module mn decls) =

117+ Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

118+ where

119+ updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) = do

120+ cn' <- updateClassName cn

121+ cs' <- updateConstraints cs

122+ return $ TypeInstanceDeclaration cs' cn' ts ds

123+ updateDecl d = return d

124+ updateValue (Constructor (Qualified Nothing nm)) = liftM Constructor $ updateDataConstructorName nm

125+ updateValue v = return v

126+ updateBinder (ConstructorBinder (Qualified Nothing nm) b) = liftM (`ConstructorBinder` b) $ updateDataConstructorName nm

127+ updateBinder v = return v

128+ updateType (TypeConstructor (Qualified Nothing nm)) = liftM TypeConstructor $ updateTypeName nm

129+ updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) = do

130+ nm' <- updateTypeName nm

131+ tys' <- mapM updateType tys

132+ return $ SaturatedTypeSynonym nm' tys'

133+ updateType (ConstrainedType cs t) = liftM (`ConstrainedType` t) $ updateConstraints cs

134+ updateType t = return t

135+ updateConstraints = mapM updateConstraint

136+ updateConstraint (Qualified Nothing nm, ts) = do

137+ nm' <- updateClassName nm

138+ return (nm', ts)

139+ updateConstraint other = return other

140+ updateTypeName = update "type" importedTypes

141+ updateClassName = update "typeclass" importedTypeClasses

142+ updateDataConstructorName = update "data constructor" importedDataConstructors

143+ update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)

144+

145+-- |

146+-- Finds all exported declarations in a set of modules.

147+--

148+findExports :: [Module] -> Either String ExportEnvironment

149+findExports = foldM addModule (ExportEnvironment M.empty M.empty M.empty)

150+ where

151+ addModule env (Module mn ds) = foldM (addDecl mn) env ds

152+ addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn

153+ addDecl mn env (DataDeclaration tn _ dcs) = do

154+ env' <- addDataConstructors env mn tn (map fst dcs)

155+ addType env' mn tn

156+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn

157+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn

158+ addDecl _ env _ = return env

159+

160+-- |

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

162+--

163+type ExplicitImports = [ImportType]

164+

165+-- |

166+-- Finds the imports within a module, mapping the imported module name to an optional set of

167+-- explicitly imported declarations.

168+--

169+findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)

170+findImports = foldl findImports' M.empty

171+ where

172+ findImports' result (ImportDeclaration mn Nothing) = M.insert mn Nothing result

173+ findImports' result (ImportDeclaration mn (Just expl)) = M.insert mn (Just expl) result

174+ findImports' result _ = result

175+

176+-- |

177+-- Constructs a local environment for a module.

178+-- TODO: check explicit imports actually exist

179+--

180+resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment

181+resolveImports env (Module currentModule decls) = do

182+ types <- resolve exportedTypes (resolveDefs typeImports)

183+ dataConstructors <- resolve exportedDataConstructors resolveDcons

184+ typeClasses <- resolve exportedTypeClasses (resolveDefs classImports)

185+ return $ ImportEnvironment types dataConstructors typeClasses

186+ where

187+ scope = M.insert currentModule Nothing (findImports decls)

188+ resolve get f = foldM f M.empty (M.toList $ get env)

189+ resolveDefs filt result (mn, names) = case M.lookup mn scope of

190+ Just Nothing -> foldM (resolveDef mn) result (S.toList names)

191+ Just (Just expl) -> foldM (resolveDef mn) result (S.toList names `intersect` filt expl)

192+ Nothing -> Right result

193+ resolveDef mn result name = case M.lookup name result of

194+ Nothing -> return $ M.insert name (Qualified (Just mn) name) result

195+ Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++

196+ if mn' == currentModule || mn == currentModule

197+ then "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"

198+ else "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"

199+ resolveDcons result (mn, tcons) = case M.lookup mn scope of

200+ Just Nothing -> foldM (foldM $ resolveDef mn) result (snd `map` S.toList tcons)

201+ Just (Just expl) -> foldM (foldM $ resolveDef mn) result (snd `map` selectedTcons)

202+ where

203+ selectedTcons = filter ((`elem` explTypeImports) . fst) (S.toList tcons)

204+ explTypeImports = typeImports expl

205+ Nothing -> Right result

src/Language/PureScript/Sugar/TypeClasses.hs+8−7

@@ -92,7 +92,7 @@ desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]

9292desugarDecl mn d@(TypeClassDeclaration name args members) = do

9393 let tys = map memberToNameAndType members

9494 modify (M.insert (mn, name) (args, tys))

95− return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor name args) members

95+ return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members

9696desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do

9797 desugared <- lift $ desugarCases members

9898 entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared

@@ -108,12 +108,12 @@ typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Dec

108108typeClassDictionaryDeclaration name args members =

109109 TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty))

110110

111−typeClassMemberToDictionaryAccessor :: ProperName -> [String] -> Declaration -> Declaration

112−typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) =

111+typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration

112+typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

113113 ExternDeclaration TypeClassAccessorImport ident

114114 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))

115− (quantify (ConstrainedType [(Qualified Nothing name, map TypeVar args)] ty))

116−typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"

115+ (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))

116+typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

117117

118118typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

119119typeInstanceDictionaryDeclaration mn deps name tys decls = do

@@ -155,9 +155,10 @@ typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident

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

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

157157

158+

158159qualifiedToString :: ModuleName -> Qualified ProperName -> String

159−qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)

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

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

161+

161162

162163-- |

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

src/Language/PureScript/TypeChecker.hs+25−47

@@ -41,7 +41,7 @@ import Language.PureScript.Sugar.TypeClasses

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

4242addDataType moduleName name args dctors ctorKind = do

4343 env <- getEnv

44− putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }

44+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) ctorKind (types env) }

4545 forM_ dctors $ \(dctor, tys) ->

4646 rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $

4747 addDataConstructor moduleName name args dctor tys

@@ -49,29 +49,16 @@ addDataType moduleName name args dctors ctorKind = do

4949addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()

5050addDataConstructor moduleName name args dctor tys = do

5151 env <- getEnv

52− dataConstructorIsNotDefined moduleName dctor

5352 let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

5453 let dctorTy = foldr function retTy tys

5554 let polyType = mkForAll args dctorTy

56− putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }

55+ putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) polyType (dataConstructors env) }

5756

5857addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()

5958addTypeSynonym moduleName name args ty kind = do

6059 env <- getEnv

61− putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)

62− , typeSynonyms = M.insert (moduleName, name) (args, qualifyAllUnqualifiedNames moduleName env ty) (typeSynonyms env) }

63−

64−typeIsNotDefined :: ModuleName -> ProperName -> Check ()

65−typeIsNotDefined moduleName name = do

66− env <- getEnv

67− guardWith (show name ++ " is already defined") $

68− not $ M.member (moduleName, name) (types env)

69−

70−dataConstructorIsNotDefined :: ModuleName -> ProperName -> Check ()

71−dataConstructorIsNotDefined moduleName dctor = do

72− env <- getEnv

73− guardWith (show dctor ++ " is already defined") $

74− not $ M.member (moduleName, dctor) (dataConstructors env)

60+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env)

61+ , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }

7562

7663valueIsNotDefined :: ModuleName -> Ident -> Check ()

7764valueIsNotDefined moduleName name = do

@@ -83,7 +70,7 @@ valueIsNotDefined moduleName name = do

8370addValue :: ModuleName -> Ident -> Type -> Check ()

8471addValue moduleName name ty = do

8572 env <- getEnv

86− putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })

73+ putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })

8774

8875addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

8976addTypeClassDictionaries entries =

@@ -93,7 +80,7 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()

9380checkTypeClassInstance _ (TypeVar _) = return ()

9481checkTypeClassInstance m (TypeConstructor ctor) = do

9582 env <- getEnv

96− when (canonicalizeType m env ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"

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

9784 return ()

9885checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty

9986checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"

@@ -115,7 +102,6 @@ typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declar

115102typeCheckAll _ _ [] = return []

116103typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do

117104 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

118− typeIsNotDefined moduleName name

119105 ctorKind <- kindsOf moduleName name args (concatMap snd dctors)

120106 addDataType moduleName name args dctors ctorKind

121107 ds <- typeCheckAll mainModuleName moduleName rest

@@ -125,11 +111,9 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

125111 let syns = mapMaybe toTypeSynonym tys

126112 let dataDecls = mapMaybe toDataDecl tys

127113 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)

128− forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) -> do

129− typeIsNotDefined moduleName name

114+ forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) ->

130115 addDataType moduleName name args dctors ctorKind

131− forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do

132− typeIsNotDefined moduleName name

116+ forM_ (zip syns syn_ks) $ \((name, args, ty), kind) ->

133117 addTypeSynonym moduleName name args ty kind

134118 ds <- typeCheckAll mainModuleName moduleName rest

135119 return $ d : ds

@@ -140,7 +124,6 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

140124 toDataDecl _ = Nothing

141125typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

142126 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

143− typeIsNotDefined moduleName name

144127 kind <- kindsOf moduleName name args [ty]

145128 addTypeSynonym moduleName name args ty kind

146129 ds <- typeCheckAll mainModuleName moduleName rest

@@ -168,8 +151,7 @@ typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = d

168151 return $ d : ds

169152typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do

170153 env <- getEnv

171− guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)

172− putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }

154+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env) }

173155 ds <- typeCheckAll mainModuleName moduleName rest

174156 return $ d : ds

175157typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

@@ -179,7 +161,7 @@ typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty)

179161 guardWith "Expected kind *" $ kind == Star

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

181163 Just _ -> throwError $ show name ++ " is already defined"

182− Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern importTy) (names env) })

164+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })

183165 ds <- typeCheckAll mainModuleName moduleName rest

184166 return $ d : ds

185167typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do

@@ -194,17 +176,18 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

194176 case idents of

195177 Nothing -> do

196178 shadowIdents (map snd $ filterModule (names env)) env

197− shadowTypes (map snd $ filterModule (types env)) env

179+ shadowTypes (map (\(Qualified _ name) -> name) $ filterModuleQ (types env)) env

198180 Just idents' -> do

199− shadowIdents (lefts idents') env

200− shadowTypes (rights idents') env

181+ shadowIdents (nameImports idents') env

182+ shadowTypes (typeImports idents') env

201183 shadowTypeClassInstances env

202184 ds <- typeCheckAll mainModuleName currentModule rest

203185 return $ d : ds

204186 where

205187 errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

206188 filterModule = filter ((== moduleName) . fst) . M.keys

207− moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))

189+ filterModuleQ = filter (\(Qualified (Just mn) _) -> mn == moduleName) . M.keys

190+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModuleQ (types env)))

208191 shadowIdents idents' env =

209192 forM_ idents' $ \ident ->

210193 case (moduleName, ident) `M.lookup` names env of

@@ -215,19 +198,15 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

215198 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

216199 shadowTypes pns env =

217200 forM_ pns $ \pn ->

218− case (moduleName, pn) `M.lookup` types env of

201+ case Qualified (Just moduleName) pn `M.lookup` types env of

219202 Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")

220− Just (_, DataAlias _ _) -> return ()

221− Just (k, _) -> do

222− guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env

223− modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })

224− let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env

203+ Just k -> do

204+ modifyEnv (\e -> e { types = M.insert (Qualified (Just currentModule) pn) k (types e) })

205+ let keys = map fst . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env

225206 forM_ keys $ \dctor ->

226− case (moduleName, dctor) `M.lookup` dataConstructors env of

227− Just (_, Alias _ _) -> return ()

228− Just (ctorTy, _) -> do

229− guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env

230− modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })

207+ case dctor `M.lookup` dataConstructors env of

208+ Just ctorTy ->

209+ modifyEnv (\e -> e { dataConstructors = M.insert dctor ctorTy (dataConstructors e) })

231210 Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")

232211 shadowTypeClassInstances env = do

233212 let instances = filter (\tcd ->

@@ -246,13 +225,12 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

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

247226 env <- getEnv

248227 ds <- typeCheckAll mainModuleName moduleName rest

249− return $ qualifyAllUnqualifiedNames moduleName env d : ds

228+ return $ d : ds

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

251230 env <- getEnv

252231 dictName <- Check . lift $ mkDictionaryValueName moduleName className tys

253232 mapM_ (checkTypeClassInstance moduleName) tys

254233 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

255− addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env

256− [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular])

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

257235 ds <- typeCheckAll mainModuleName moduleName rest

258− return $ qualifyAllUnqualifiedNames moduleName env d : ds

236+ return $ d : ds

src/Language/PureScript/TypeChecker/Kinds.hs+3−3

@@ -133,9 +133,9 @@ infer (TypeVar v) = do

133133infer (TypeConstructor v) = do

134134 env <- liftCheck getEnv

135135 Just moduleName <- checkCurrentModule <$> get

136− case M.lookup (qualify moduleName v) (types env) of

137− Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"

138− Just (kind, _) -> return kind

136+ case M.lookup v (types env) of

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

138+ Just kind -> return kind

139139infer (TypeApp t1 t2) = do

140140 k0 <- fresh

141141 k1 <- infer t1

src/Language/PureScript/TypeChecker/Monad.hs+13−70

@@ -61,31 +61,6 @@ data NameKind

6161 --

6262 | DataConstructor deriving Show

6363

64−-- |

65−-- The type of a type declaration

66−--

67−data TypeDeclarationKind

68− -- |

69− -- A data constructor

70− --

71− = Data

72− -- |

73− -- A data type foreign import

74− --

75− | ExternData

76− -- |

77− -- A type synonym

78− --

79− | TypeSynonym

80− -- |

81− -- An alias for a type in another module, introduced using an import declaration

82− --

83− | DataAlias ModuleName ProperName

84− -- |

85− -- A local type name introduced using a forall quantifier

86− --

87− | LocalTypeVariable deriving Show

88−

8964-- |

9065-- The @Environment@ defines all values and types which are currently in scope:

9166--

@@ -97,15 +72,15 @@ data Environment = Environment {

9772 -- |

9873 -- Type names currently in scope

9974 --

100− , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

75+ , types :: M.Map (Qualified ProperName) Kind

10176 -- |

10277 -- Data constructors currently in scope, along with their associated data type constructors

10378 --

104− , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)

79+ , dataConstructors :: M.Map (Qualified ProperName) Type

10580 -- |

10681 -- Type synonyms currently in scope

10782 --

108− , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

83+ , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)

10984 -- |

11085 -- Available type class dictionaries

11186 --

@@ -115,12 +90,12 @@ data Environment = Environment {

11590-- |

11691-- The basic types existing in the external javascript environment

11792--

118−jsTypes ::M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

119−jsTypes = M.fromList [ ((ModuleName [ProperName "Prim"], ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))

120− , ((ModuleName [ProperName "Prim"], ProperName "Array"), (FunKind Star Star, ExternData))

121− , ((ModuleName [ProperName "Prim"], ProperName "String"), (Star, ExternData))

122− , ((ModuleName [ProperName "Prim"], ProperName "Number"), (Star, ExternData))

123− , ((ModuleName [ProperName "Prim"], ProperName "Boolean"), (Star, ExternData)) ]

93+jsTypes ::M.Map (Qualified ProperName) Kind

94+jsTypes = M.fromList [ (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Function"), FunKind Star (FunKind Star Star))

95+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array"), FunKind Star Star)

96+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "String"), Star)

97+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Number"), Star)

98+ , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean"), Star) ]

12499

125100-- |

126101-- The initial environment with no values and only the default javascript types defined

@@ -142,7 +117,7 @@ bindNames newNames action = do

142117-- |

143118-- Temporarily bind a collection of names to types

144119--

145−bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a

120+bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) Kind -> m a -> m a

146121bindTypes newNames action = do

147122 orig <- get

148123 modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

@@ -179,7 +154,7 @@ bindLocalVariables moduleName bindings =

179154--

180155bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

181156bindLocalTypeVariables moduleName bindings =

182− bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable)))

157+ bindTypes (M.fromList $ flip map bindings $ first $ Qualified (Just moduleName))

183158

184159-- |

185160-- Lookup the type of a value by name in the @Environment@

@@ -197,9 +172,9 @@ lookupVariable currentModule (Qualified moduleName var) = do

197172lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind

198173lookupTypeVariable currentModule (Qualified moduleName name) = do

199174 env <- getEnv

200− case M.lookup (fromMaybe currentModule moduleName, name) (types env) of

175+ case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of

201176 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

202− Just (k, _) -> return k

177+ Just k -> return k

203178

204179-- |

205180-- Canonicalize an identifier by resolving any aliases introduced by module imports

@@ -210,24 +185,6 @@ canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of

210185 Just (_, Alias mn' i') -> (mn', i')

211186 _ -> (mn, i)

212187

213−-- |

214−-- Canonicalize a type variable by resolving any aliases introduced by module imports

215−--

216−canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)

217−canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)

218−canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of

219− Just (_, DataAlias mn' pn') -> (mn', pn')

220− _ -> (mn, nm)

221−

222−-- |

223−-- Canonicalize a data constructor by resolving any aliases introduced by module imports

224−--

225−canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)

226−canonicalizeDataConstructor _ _ (Qualified (Just mn) pn) = (mn, pn)

227−canonicalizeDataConstructor mn env (Qualified Nothing pn) = case (mn, pn) `M.lookup` dataConstructors env of

228− Just (_, Alias mn' (Ident pn')) -> (mn', ProperName pn')

229− _ -> (mn, pn)

230−

231188-- |

232189-- State required for type checking:

233190--

@@ -322,17 +279,3 @@ liftUnify unify = do

322279 Right (a, ust) -> do

323280 modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

324281 return (a, unifyCurrentSubstitution ust)

325−

326−-- |

327−-- Replace any unqualified names in a type wit their qualified versionss

328−--

329−qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

330−qualifyAllUnqualifiedNames mn env = everywhere (mkT go)

331− where

332− go :: Type -> Type

333− go (TypeConstructor nm) = TypeConstructor $ qualify' nm

334− go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args

335− go (ConstrainedType constraints ty) = ConstrainedType (map (first qualify') constraints) ty

336− go other = other

337− qualify' qual = let (mn', pn') = canonicalizeType mn env qual

338− in Qualified (Just mn') pn'

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

@@ -20,8 +20,9 @@ module Language.PureScript.TypeChecker.Synonyms (

2020

2121import Language.PureScript.Types

2222import Language.PureScript.Names

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

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

2424

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

2526import Data.Maybe (fromMaybe)

2627import Data.Data

2728import Data.Generics

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

3233-- |

3334-- Build a type substitution for a type synonym

3435--

35−buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)

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

3637buildTypeSubstitution env moduleName name n = go n []

3738 where

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

39− go 0 args (TypeConstructor ctor) | name == canonicalizeType moduleName env ctor = return (Just $ SaturatedTypeSynonym ctor args)

40− go m _ (TypeConstructor ctor) | m > 0 && name == qualify moduleName ctor = throwError $ "Partially applied type synonym " ++ show name

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

41+ go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name

4142 go m args (TypeApp f arg) = go (m - 1) (arg:args) f

4243 go _ _ _ = return Nothing

4344

4445-- |

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

4647--

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

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

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

4950 where

50− replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t

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

5152

5253-- |

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

5455--

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

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

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

5758

5859

src/Language/PureScript/TypeChecker/Types.hs+17−24

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

109109 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

110110 env <- getEnv

111111 Just moduleName <- checkCurrentModule <$> get

112− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)

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

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

114114 t3 `unifyTypes` t5

115115 t4 `unifyTypes` t6

@@ -153,12 +153,6 @@ unifyRows r1 r2 =

153153 unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()

154154 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")."

155155

156−-- |

157−-- Ensure type constructors are equal after canonicalization

158−--

159−typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool

160−typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env

161−

162156-- |

163157-- Infer the types of multiple mutually-recursive values, and return elaborated values including

164158-- type class dictionaries and type annotations.

@@ -271,7 +265,7 @@ entails moduleName context goal@(className, tys) = do

271265 -- Choose type class dictionaries in scope in the current module

272266 , filterModule tcd

273267 -- Make sure the type class name matches the one we are trying to satisfy

274− , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)

268+ , className' == tcdClassName tcd

275269 -- Make sure the type unifies with the type in the type instance definition

276270 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)

277271 -- Solve any necessary subgoals

@@ -314,7 +308,7 @@ typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String

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

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

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

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

311+typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

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

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

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

@@ -419,7 +413,7 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

419413 Just moduleName <- checkCurrentModule <$> get

420414 dicts <- getTypeClassDictionaries

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

422− return (foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints)), ty')

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

423417instantiatePolyTypeWithUnknowns val ty = return (val, ty)

424418

425419-- |

@@ -437,7 +431,7 @@ replaceVarWithUnknown ident ty = do

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

438432replaceAllTypeSynonyms' env moduleName d =

439433 let

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

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

441435 in

442436 saturateAllTypeSynonyms env moduleName syns d

443437

@@ -461,7 +455,7 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

461455--

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

463457expandTypeSynonym' env moduleName name args =

464− case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of

458+ case M.lookup name (typeSynonyms env) of

465459 Just (synArgs, body) -> do

466460 let repl = replaceAllTypeVars (zip synArgs args) body

467461 replaceAllTypeSynonyms' env moduleName repl

@@ -540,15 +534,15 @@ infer' (Var var) = do

540534 ConstrainedType constraints ty' -> do

541535 env <- getEnv

542536 dicts <- getTypeClassDictionaries

543− return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'

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

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

545539infer' v@(Constructor c) = do

546540 env <- getEnv

547541 Just moduleName <- checkCurrentModule <$> get

548− case M.lookup (qualify moduleName c) (dataConstructors env) of

542+ case M.lookup c (dataConstructors env) of

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

550− Just (ty, _) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

551− return $ TypedValue True v ty'

544+ Just ty -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

545+ return $ TypedValue True v ty'

552546infer' (Case vals binders) = do

553547 ts <- mapM infer vals

554548 ret <- fresh

@@ -596,8 +590,8 @@ inferBinder val (VarBinder name) = return $ M.singleton name val

596590inferBinder val (ConstructorBinder ctor binders) = do

597591 env <- getEnv

598592 Just moduleName <- checkCurrentModule <$> get

599− case M.lookup (qualify moduleName ctor) (dataConstructors env) of

600− Just (ty, _) -> do

593+ case M.lookup ctor (dataConstructors env) of

594+ Just ty -> do

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

602596 go binders fn

603597 where

@@ -725,8 +719,7 @@ check' val t@(ConstrainedType constraints ty) = do

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

726720 val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->

727721 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

728− (qualifyAllUnqualifiedNames moduleName env constraints)) $

729− check val ty

722+ constraints) $ check val ty

730723 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

731724check' val (SaturatedTypeSynonym name args) = do

732725 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

@@ -806,9 +799,9 @@ check' (Accessor prop val) ty = do

806799check' (Constructor c) ty = do

807800 env <- getEnv

808801 Just moduleName <- checkCurrentModule <$> get

809− case M.lookup (qualify moduleName c) (dataConstructors env) of

802+ case M.lookup c (dataConstructors env) of

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

811− Just (ty1, _) -> do

804+ Just ty1 -> do

812805 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

813806 _ <- subsumes Nothing repl ty

814807 return $ TypedValue True (Constructor c) ty

@@ -886,7 +879,7 @@ checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do

886879 env <- getEnv

887880 dicts <- getTypeClassDictionaries

888881 Just moduleName <- checkCurrentModule <$> get

889− checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy arg

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

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

891884 ++ prettyPrintType fnTy

892885 ++ " to argument " ++ prettyPrintValue arg

@@ -932,7 +925,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

932925 dicts <- getTypeClassDictionaries

933926 Just moduleName <- checkCurrentModule <$> get

934927 _ <- subsumes' Nothing ty1 ty2

935− return . Just $ foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))

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

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

937930 let

938931 (ts1, r1') = rowToList r1