495eeec · rowtype-yoga/purescript-native

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

on golang help sign in

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

495eeecPhil Freeman13 years ago

examples/failing/ImportExplicit.pursnew file+14

compare with golang

unifiedsplit

@@ -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

42 \ return n.toString();\

43 \}" :: Number -> String

45− instance Prelude.Show Number where

45+ instance Show Number where

46 show = showNumber

48 class Read a where

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

439 maybe _ f (Just a) = f a

440

441 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)

443

444− instance Prelude.Monad Maybe where

444+ instance Monad Maybe where

445 return = Just

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

447

448− instance Prelude.Applicative Maybe where

448+ instance Applicative Maybe where

449 pure = Just

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

451 (<*>) Nothing _ = Nothing

452

453− instance Prelude.Functor Maybe where

453+ instance Functor Maybe where

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

455 (<$>) _ _ = Nothing

456

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

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

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

459 show Nothing = "Nothing"

460

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

468 either f _ (Left a) = f a

469 either _ g (Right b) = g b

470

471− instance Prelude.Monad (Either e) where

471+ instance Monad (Either e) where

472 return = Right

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

474

475− instance Prelude.Applicative (Either e) where

475+ instance Applicative (Either e) where

476 pure = Right

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

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

479

480− instance Prelude.Functor (Either a) where

480+ instance Functor (Either a) where

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

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

483

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

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

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

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

487

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

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

663

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

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

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

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

666

667

667− instance Prelude.Functor [] where

668+ instance Functor [] where

668 (<$>) = map

669 (<$>) = map

669

670

670− instance Prelude.Monad [] where

671+ instance Monad [] where

671 return = singleton

672 return = singleton

672 (>>=) = concatMap

673 (>>=) = concatMap

673

674

674− instance Prelude.Alternative [] where

675+ instance Alternative [] where

675 empty = []

676 empty = []

676 (<|>) = concat

677 (<|>) = concat

677

678

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

690

691

691 data Tuple a b = Tuple a b

692 data Tuple a b = Tuple a b

692

693

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

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

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

695

696

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

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

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

944

945

945module Control.Monad.Eff where

946module Control.Monad.Eff where

946

947

948+ import Prelude

949+

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

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

948

951

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

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

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

966 \ return f();\

969 \ return f();\

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

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

968

971

969− instance Prelude.Monad (Eff e) where

972+ instance Monad (Eff e) where

970 return = retEff

973 return = retEff

971 (>>=) = bindEff

974 (>>=) = bindEff

972

975

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

1109 \ };\

1112 \ };\

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

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

1111

1114

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) {}

1113 print o = trace (show o)

1116 print o = trace (show o)

1114

1117

1115module Control.Monad.ST where

1118module Control.Monad.ST where

purescript.cabal+1

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

43 Language.PureScript.Sugar.Operators

44 Language.PureScript.Sugar.TypeClasses

45 Language.PureScript.Sugar.Let

46+ Language.PureScript.Sugar.Names

46 Language.PureScript.CodeGen

47 Language.PureScript.CodeGen

47 Language.PureScript.CodeGen.Common

48 Language.PureScript.CodeGen.Common

48 Language.PureScript.CodeGen.Externs

49 Language.PureScript.CodeGen.Externs

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

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

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

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

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

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

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

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

47declToPs _ _ (ExternDataDeclaration name kind) =

48 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

43import Language.PureScript.Types

44import Language.PureScript.CodeGen.Optimize

45import Language.PureScript.CodeGen.Common

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

48-- |

47-- |

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

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

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

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

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

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

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

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

122valueToJs 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

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

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

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

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

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

125valueToJs 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

262 then

257 then

263 return js

258 return js

264 else

259 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)))

266 (JSBlock js)

261 (JSBlock js)

267 Nothing]

262 Nothing]

268 where

263 where

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

313--

308--

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

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

315isOnlyConstructor m e ctor =

310isOnlyConstructor 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

317 in numConstructors ty == 1

312 in numConstructors ty == 1

318 where

313 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

320 typeConstructor (TypeConstructor qual) = qualify m qual

315 typeConstructor (TypeConstructor qual) = qualify m qual

321 typeConstructor (ForAll _ ty _) = typeConstructor ty

316 typeConstructor (ForAll _ ty _) = typeConstructor ty

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

317 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)

55 where

56 values :: Value -> [Key]

57 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"

59 values _ = []

60 values _ = []

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

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

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

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

65 --

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

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+

68-- |

82-- |

69-- The data type of declarations

83-- The data type of declarations

70--

84--

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

108 -- |

122 -- |

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

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

110 --

124 --

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

125+ | ImportDeclaration ModuleName (Maybe [ImportType])

112 -- |

126 -- |

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

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

114 --

128 --

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

169isTypeClassDeclaration TypeClassDeclaration{} = True

183isTypeClassDeclaration TypeClassDeclaration{} = True

170isTypeClassDeclaration TypeInstanceDeclaration{} = True

184isTypeClassDeclaration TypeInstanceDeclaration{} = True

171isTypeClassDeclaration _ = False

185isTypeClassDeclaration _ = 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

88 reserved "import"

89 indented

90 moduleName' <- moduleName

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

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

92 return $ ImportDeclaration moduleName' idents

94parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

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

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

27import Language.PureScript.Sugar.BindingGroups as S

28import Language.PureScript.Sugar.TypeClasses as S

29import Language.PureScript.Sugar.Let as S

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

31-- |

32-- |

32-- The desugaring pipeline proceeds as follows:

33-- The desugaring pipeline proceeds as follows:

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

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

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

47--

48--

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

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

50+desugar = rename

49−desugar = desugarTypeClasses

51+ >=> desugarTypeClasses

50 >=> rebracket

52 >=> rebracket

51 >=> desugarDo

53 >=> desugarDo

52 >=> desugarLetBindings

54 >=> desugarLetBindings

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

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

52 let values = filter isValueDecl ds

53 dataDecls = filter isDataDecl ds

54 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

56 dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

57 let allIdents = map getIdent values

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

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

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

84 names _ = []

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

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

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

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

88 where

89 names :: Type -> [ProperName]

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

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

91 names _ = []

93getIdent :: 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]

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

93 let tys = map memberToNameAndType members

94 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

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

97 desugared <- lift $ desugarCases members

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

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

108typeClassDictionaryDeclaration name args members =

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

110

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

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

112−typeClassMemberToDictionaryAccessor name args (TypeDeclaration ident ty) =

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

113 ExternDeclaration TypeClassAccessorImport ident

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

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

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

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

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

117

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

119typeInstanceDictionaryDeclaration mn deps name tys decls = do

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

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

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

157

158+

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

159qualifiedToString :: 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+

161

162

162-- |

163-- |

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

164-- 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

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

42addDataType moduleName name args dctors ctorKind = do

43 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) }

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

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

47 addDataConstructor moduleName name args dctor tys

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

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

50addDataConstructor moduleName name args dctor tys = do

51 env <- getEnv

52− dataConstructorIsNotDefined moduleName dctor

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

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

54 let dctorTy = foldr function retTy tys

53 let dctorTy = foldr function retTy tys

55 let polyType = mkForAll args dctorTy

54 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) }

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

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

59addTypeSynonym moduleName name args ty kind = do

58addTypeSynonym moduleName name args ty kind = do

60 env <- getEnv

59 env <- getEnv

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

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

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

61+ , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, 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)

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

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

77valueIsNotDefined moduleName name = do

64valueIsNotDefined moduleName name = do

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

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

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

84addValue moduleName name ty = do

71addValue moduleName name ty = do

85 env <- getEnv

72 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) })

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

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

89addTypeClassDictionaries entries =

76addTypeClassDictionaries entries =

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

93checkTypeClassInstance _ (TypeVar _) = return ()

80checkTypeClassInstance _ (TypeVar _) = return ()

94checkTypeClassInstance m (TypeConstructor ctor) = do

81checkTypeClassInstance m (TypeConstructor ctor) = do

95 env <- getEnv

82 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"

97 return ()

84 return ()

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

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

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

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

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

115typeCheckAll _ _ [] = return []

102typeCheckAll _ _ [] = return []

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

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

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

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

118− typeIsNotDefined moduleName name

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

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

120 addDataType moduleName name args dctors ctorKind

106 addDataType moduleName name args dctors ctorKind

121 ds <- typeCheckAll mainModuleName moduleName rest

107 ds <- typeCheckAll mainModuleName moduleName rest

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

125 let syns = mapMaybe toTypeSynonym tys

111 let syns = mapMaybe toTypeSynonym tys

126 let dataDecls = mapMaybe toDataDecl tys

112 let dataDecls = mapMaybe toDataDecl tys

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

113 (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

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

129− typeIsNotDefined moduleName name

130 addDataType moduleName name args dctors ctorKind

115 addDataType moduleName name args dctors ctorKind

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

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

132− typeIsNotDefined moduleName name

133 addTypeSynonym moduleName name args ty kind

117 addTypeSynonym moduleName name args ty kind

134 ds <- typeCheckAll mainModuleName moduleName rest

118 ds <- typeCheckAll mainModuleName moduleName rest

135 return $ d : ds

119 return $ d : ds

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

140 toDataDecl _ = Nothing

124 toDataDecl _ = Nothing

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

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

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

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

143− typeIsNotDefined moduleName name

144 kind <- kindsOf moduleName name args [ty]

127 kind <- kindsOf moduleName name args [ty]

145 addTypeSynonym moduleName name args ty kind

128 addTypeSynonym moduleName name args ty kind

146 ds <- typeCheckAll mainModuleName moduleName rest

129 ds <- typeCheckAll mainModuleName moduleName rest

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

168 return $ d : ds

151 return $ d : ds

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

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

170 env <- getEnv

153 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) }

173 ds <- typeCheckAll mainModuleName moduleName rest

155 ds <- typeCheckAll mainModuleName moduleName rest

174 return $ d : ds

156 return $ d : ds

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

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

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

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

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

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

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

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

163 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) })

183 ds <- typeCheckAll mainModuleName moduleName rest

165 ds <- typeCheckAll mainModuleName moduleName rest

184 return $ d : ds

166 return $ d : ds

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

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

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

194 case idents of

176 case idents of

195 Nothing -> do

177 Nothing -> do

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

178 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

198 Just idents' -> do

180 Just idents' -> do

199− shadowIdents (lefts idents') env

181+ shadowIdents (nameImports idents') env

200− shadowTypes (rights idents') env

182+ shadowTypes (typeImports idents') env

201 shadowTypeClassInstances env

183 shadowTypeClassInstances env

202 ds <- typeCheckAll mainModuleName currentModule rest

184 ds <- typeCheckAll mainModuleName currentModule rest

203 return $ d : ds

185 return $ d : ds

204 where

186 where

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

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

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

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

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

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

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

208 shadowIdents idents' env =

191 shadowIdents idents' env =

209 forM_ idents' $ \ident ->

192 forM_ idents' $ \ident ->

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

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

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

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

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

216 shadowTypes pns env =

199 shadowTypes pns env =

217 forM_ pns $ \pn ->

200 forM_ pns $ \pn ->

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

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

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

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

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

221− Just (k, _) -> do

203+ 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) })

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

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

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

225 forM_ keys $ \dctor ->

206 forM_ keys $ \dctor ->

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

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

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

228− Just (ctorTy, _) -> do

208+ Just ctorTy ->

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) })

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

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

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

232 shadowTypeClassInstances env = do

211 shadowTypeClassInstances env = do

233 let instances = filter (\tcd ->

212 let instances = filter (\tcd ->

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

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

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

247 env <- getEnv

226 env <- getEnv

248 ds <- typeCheckAll mainModuleName moduleName rest

227 ds <- typeCheckAll mainModuleName moduleName rest

249− return $ qualifyAllUnqualifiedNames moduleName env d : ds

228+ return $ d : ds

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

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

251 env <- getEnv

230 env <- getEnv

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

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

253 mapM_ (checkTypeClassInstance moduleName) tys

232 mapM_ (checkTypeClassInstance moduleName) tys

254 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

233 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]

257 ds <- typeCheckAll mainModuleName moduleName rest

235 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

133infer (TypeConstructor v) = do

134 env <- liftCheck getEnv

135 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

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

138+ Just kind -> return kind

139infer (TypeApp t1 t2) = do

140 k0 <- fresh

141 k1 <- infer t1

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

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

61 --

62 | DataConstructor deriving Show

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−

89-- |

64-- |

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

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

91--

66--

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

97 -- |

72 -- |

98 -- Type names currently in scope

73 -- Type names currently in scope

99 --

74 --

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

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

101 -- |

76 -- |

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

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

103 --

78 --

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

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

105 -- |

80 -- |

106 -- Type synonyms currently in scope

81 -- Type synonyms currently in scope

107 --

82 --

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

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

109 -- |

84 -- |

110 -- Available type class dictionaries

85 -- Available type class dictionaries

111 --

86 --

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

115-- |

90-- |

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

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

117--

92--

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

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

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

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

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

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

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

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

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

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

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

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

124

125-- |

100-- |

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

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

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

142-- |

117-- |

143-- Temporarily bind a collection of names to types

118-- Temporarily bind a collection of names to types

144--

119--

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

146bindTypes newNames action = do

121bindTypes newNames action = do

147 orig <- get

122 orig <- get

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

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

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

179--

154--

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

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

181bindLocalTypeVariables moduleName bindings =

156bindLocalTypeVariables 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))

183

158

184-- |

159-- |

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

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

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

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

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

198lookupTypeVariable currentModule (Qualified moduleName name) = do

173lookupTypeVariable currentModule (Qualified moduleName name) = do

199 env <- getEnv

174 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

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

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

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

177+ Just k -> return k

203

178

204-- |

179-- |

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

180-- 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

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

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

211 _ -> (mn, i)

186 _ -> (mn, i)

212

187

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−

231-- |

188-- |

232-- State required for type checking:

189-- State required for type checking:

233--

190--

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

322 Right (a, ust) -> do

279 Right (a, ust) -> do

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

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

324 return (a, unifyCurrentSubstitution ust)

281 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 (

21import Language.PureScript.Types

22import Language.PureScript.Names

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

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

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

25import Data.Maybe (fromMaybe)

26import Data.Maybe (fromMaybe)

26import Data.Data

27import Data.Data

27import Data.Generics

28import Data.Generics

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

32-- |

33-- |

33-- Build a type substitution for a type synonym

34-- Build a type substitution for a type synonym

34--

35--

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

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

36buildTypeSubstitution env moduleName name n = go n []

37buildTypeSubstitution env moduleName name n = go n []

37 where

38 where

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

39 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 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)

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

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

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

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

42 go _ _ _ = return Nothing

43 go _ _ _ = return Nothing

44-- |

45-- |

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

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

46--

47--

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

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

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

49 where

50 where

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

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

52-- |

53-- |

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

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

54--

55--

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

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

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

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

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

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

110 env <- getEnv

111 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)

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

114 t3 `unifyTypes` t5

115 t4 `unifyTypes` t6

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

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

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

155

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−

162-- |

156-- |

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

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

164-- type class dictionaries and type annotations.

158-- type class dictionaries and type annotations.

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

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

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

272 , filterModule tcd

266 , filterModule tcd

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

267 -- 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

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

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

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

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

277 -- Solve any necessary subgoals

271 -- Solve any necessary subgoals

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

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

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

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

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

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

310typeHeadsAreEqual _ _ 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 []

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

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

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

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

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

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

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

419 Just moduleName <- checkCurrentModule <$> get

413 Just moduleName <- checkCurrentModule <$> get

420 dicts <- getTypeClassDictionaries

414 dicts <- getTypeClassDictionaries

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

415 (_, 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')

423instantiatePolyTypeWithUnknowns val ty = return (val, ty)

417instantiatePolyTypeWithUnknowns val ty = return (val, ty)

424

418

425-- |

419-- |

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

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

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

438replaceAllTypeSynonyms' env moduleName d =

432replaceAllTypeSynonyms' env moduleName d =

439 let

433 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

441 in

435 in

442 saturateAllTypeSynonyms env moduleName syns d

436 saturateAllTypeSynonyms env moduleName syns d

443

437

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

461--

455--

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

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

463expandTypeSynonym' env moduleName name args =

457expandTypeSynonym' env moduleName name args =

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

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

465 Just (synArgs, body) -> do

459 Just (synArgs, body) -> do

466 let repl = replaceAllTypeVars (zip synArgs args) body

460 let repl = replaceAllTypeVars (zip synArgs args) body

467 replaceAllTypeSynonyms' env moduleName repl

461 replaceAllTypeSynonyms' env moduleName repl

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

540 ConstrainedType constraints ty' -> do

534 ConstrainedType constraints ty' -> do

541 env <- getEnv

535 env <- getEnv

542 dicts <- getTypeClassDictionaries

536 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'

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

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

545infer' v@(Constructor c) = do

539infer' v@(Constructor c) = do

546 env <- getEnv

540 env <- getEnv

547 Just moduleName <- checkCurrentModule <$> get

541 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

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

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

551− return $ TypedValue True v ty'

545+ return $ TypedValue True v ty'

552infer' (Case vals binders) = do

546infer' (Case vals binders) = do

553 ts <- mapM infer vals

547 ts <- mapM infer vals

554 ret <- fresh

548 ret <- fresh

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

596inferBinder val (ConstructorBinder ctor binders) = do

590inferBinder val (ConstructorBinder ctor binders) = do

597 env <- getEnv

591 env <- getEnv

598 Just moduleName <- checkCurrentModule <$> get

592 Just moduleName <- checkCurrentModule <$> get

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

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

600− Just (ty, _) -> do

594+ Just ty -> do

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

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

602 go binders fn

596 go binders fn

603 where

597 where

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

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

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

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

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

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

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

728− (qualifyAllUnqualifiedNames moduleName env constraints)) $

729− check val ty

722+ constraints) $ check val ty

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

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

731check' val (SaturatedTypeSynonym name args) = do

724check' val (SaturatedTypeSynonym name args) = do

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

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

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

806check' (Constructor c) ty = do

799check' (Constructor c) ty = do

807 env <- getEnv

800 env <- getEnv

808 Just moduleName <- checkCurrentModule <$> get

801 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

811− Just (ty1, _) -> do

804+ Just ty1 -> do

812 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

805 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

813 _ <- subsumes Nothing repl ty

806 _ <- subsumes Nothing repl ty

814 return $ TypedValue True (Constructor c) ty

807 return $ TypedValue True (Constructor c) ty

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

886 env <- getEnv

879 env <- getEnv

887 dicts <- getTypeClassDictionaries

880 dicts <- getTypeClassDictionaries

888 Just moduleName <- checkCurrentModule <$> get

881 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

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

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

891 ++ prettyPrintType fnTy

884 ++ prettyPrintType fnTy

892 ++ " to argument " ++ prettyPrintValue arg

885 ++ " to argument " ++ prettyPrintValue arg

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

932 dicts <- getTypeClassDictionaries

925 dicts <- getTypeClassDictionaries

933 Just moduleName <- checkCurrentModule <$> get

926 Just moduleName <- checkCurrentModule <$> get

934 _ <- subsumes' Nothing ty1 ty2

927 _ <- 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)

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

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

937 let

930 let

938 (ts1, r1') = rowToList r1

931 (ts1, r1') = rowToList r1