17ccc92 · rowtype-yoga/purescript-native

examples/failing/ImportExplicit.pursnew file+14

compare with golang

unifiedsplit

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

1+module M1 where

2+

3+ data X = X | Y

4+ data Z = Z

5+

6+module Main where

7+

8+ import M1 (X(..))

9+

10+ testX = X

11+ testY = Y

12+ testZ = Z

13+

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

examples/failing/ImportExplicit2.pursnew file+7

@@ -0,0 +1,7 @@

1+module M1 where

2+

3+ foo = "foo"

4+

5+module Main where

6+

7+ import M1 (X(..))

examples/failing/ImportExplicit3.pursnew file+7

@@ -0,0 +1,7 @@

1+module M1 where

2+

3+ data X = Y

4+

5+module Main where

6+

7+ import M1 (X(Z, Q))

examples/failing/ImportModule.pursnew file+7

@@ -0,0 +1,7 @@

1+module M2 where

2+

3+ data X = X

4+

5+module Main where

6+

7+ import M1

examples/passing/ImportExplicit.pursnew file+14

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

1+module M1 where

2+

3+ data X = X | Y

4+ data Z = Z

5+

6+module Main where

7+

8+ import M1 (X(..))

9+

10+ testX :: X

11+ testX = X

12+ testY = Y

13+

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

examples/passing/RedefinedFixity.purs+1−1

@@ -12,7 +12,7 @@ module M3 where

12

13import M1

14import M2

15−

15+

16module Main where

17

18main = Debug.Trace.trace "Done"

prelude/prelude.purs+19−17

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

42 \ return n.toString();\

43 \}" :: Number -> String

44

45− instance Prelude.Show Number where

45+ instance Show Number where

46 show = showNumber

47

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

@@ -661,17 +661,17 @@ module Data.Array where

661 take _ [] = []

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

663

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

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

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

666

667− instance Prelude.Functor [] where

667+ instance Functor [] where

668 (<$>) = map

669

670− instance Prelude.Monad [] where

670+ instance Monad [] where

671 return = singleton

672 (>>=) = concatMap

673

674− instance Prelude.Alternative [] where

674+ instance Alternative [] where

675 empty = []

676 (<|>) = concat

677

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

690

691 data Tuple a b = Tuple a b

692

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

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

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

695

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

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

944

945module Control.Monad.Eff where

946

947+ import Prelude

948+

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

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

948

950

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

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

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

966 \ return f();\

968 \ return f();\

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

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

968

970

969− instance Prelude.Monad (Eff e) where

971+ instance Monad (Eff e) where

970 return = retEff

972 return = retEff

971 (>>=) = bindEff

973 (>>=) = bindEff

972

974

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

1109 \ };\

1111 \ };\

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

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

1111

1113

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

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

1113 print o = trace (show o)

1115 print o = trace (show o)

1114

1116

1115module Control.Monad.ST where

1117module 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/Data/Generics/Extras.hs+21−10

@@ -47,17 +47,28 @@ everywhereM' f x = do

47-- > go locals lam@(Lam local _) = (local : locals, lam)

48-- > go locals other = (locals, other)

49--

50−everywhereWithContext' :: (Data d) => s -> (forall d1. (Data d1) => s -> d1 -> (s, d1)) -> d -> d

50+everywhereWithContextM' :: (Monad m, Data d) => s -> (forall d1. (Data d1) => s -> d1 -> m (s, d1)) -> d -> m d

51−everywhereWithContext' s0 f x =

51+everywhereWithContextM' s0 f x = do

52− let (s, y) = f s0 x in

52+ (s, y) <- f s0 x

53− gmapT (everywhereWithContext' s f) y

53+ gmapM (everywhereWithContextM' s f) y

54

55-- |

56-- Make a stateful transformation function

57--

58−mkS :: (Data a, Data b) => (s -> a -> (s, a)) -> s -> b -> (s, b)

58+mkS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> s -> b -> m (s, b)

59−mkS f s b = fromMaybe (s, b) $ do

59+mkS = extS (curry return)

60− a <- cast b

60+

61+-- |

62+-- Extend a stateful transformation function

63+--

64+extS :: (Monad m, Data a, Data b) => (s -> a -> m (s, a)) -> (s -> b -> m (s, b)) -> (s -> a -> m (s, a))

65+extS f g s a = do

61− let (s', a') = f s a

66+ (s', a') <- f s a

67+ case cast a' of

68+ Just b -> do

69+ (s'', b') <- g s' b

62− b' <- cast a'

70+ case cast b' of

71+ Just a'' -> return (s'', a'')

72+ Nothing -> return (s', a')

63− return (s', b')

73+ Nothing -> return (s', a')

74+

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+5−23

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

47

46

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)

@@ -194,14 +189,10 @@ varToJs m e qual@(Qualified _ ident) = go qual

194 where

189 where

195 go qual' = case M.lookup (qualify m qual') (names e) of

190 go qual' = case M.lookup (qualify m qual') (names e) of

196 Just (_, ty) | isExtern ty -> var ident

191 Just (_, ty) | isExtern ty -> var ident

197− Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent)

198 _ -> case qual' of

192 _ -> case qual' of

199 Qualified Nothing _ -> var ident

193 Qualified Nothing _ -> var ident

200 _ -> qualifiedToJS m id qual'

194 _ -> qualifiedToJS m id qual'

201 isExtern (Extern ForeignImport) = True

195 isExtern (Extern ForeignImport) = True

202− isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of

203− Just (_, ty') -> isExtern ty'

204− Nothing -> error "Undefined alias in varToJs"

205 isExtern _ = False

196 isExtern _ = False

206

197

207-- |

198-- |

@@ -216,10 +207,10 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

216-- Generate code in the simplified Javascript intermediate representation for pattern match binders

207-- Generate code in the simplified Javascript intermediate representation for pattern match binders

217-- and guards.

208-- and guards.

218--

209--

219−bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS

210+bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS

220bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do

211bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do

221 valNames <- replicateM (length vals) fresh

212 valNames <- replicateM (length vals) fresh

222− jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd

213+ jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd

223 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

214 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

224 vals

215 vals

225 where

216 where

@@ -231,15 +222,6 @@ bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders,

231 binderToJs m e v done'' b

222 binderToJs m e v done'' b

232 go _ _ _ _ = error "Invalid arguments to bindersToJs"

223 go _ _ _ _ = error "Invalid arguments to bindersToJs"

233

224

234−-- |

235−-- Collect all names introduced in binders in an expression

236−--

237−binderNames :: (Data d) => d -> [Ident]

238−binderNames = everything (++) (mkQ [] go)

239− where

240− go (VarBinder ident) = [ident]

241− go _ = []

242−

243-- |

225-- |

244-- Generate code in the simplified Javascript intermediate representation for a pattern match

226-- Generate code in the simplified Javascript intermediate representation for a pattern match

245-- binder.

227-- binder.

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

262 then

244 then

263 return js

245 return js

264 else

246 else

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

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

266 (JSBlock js)

248 (JSBlock js)

267 Nothing]

249 Nothing]

268 where

250 where

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

313--

295--

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

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

315isOnlyConstructor m e ctor =

297isOnlyConstructor m e ctor =

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

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

317 in numConstructors ty == 1

299 in numConstructors ty == 1

318 where

300 where

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

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

320 typeConstructor (TypeConstructor qual) = qualify m qual

302 typeConstructor (TypeConstructor qual) = qualify m qual

321 typeConstructor (ForAll _ ty _) = typeConstructor ty

303 typeConstructor (ForAll _ ty _) = typeConstructor ty

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

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

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

@@ -43,19 +43,20 @@ declarationsByModule :: Environment -> Module -> [(Key, [Key])]

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

44 where

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

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

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

47 go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors

48 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

49− go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names'

49+ go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies moduleName d)) names'

50 go (DataBindingGroupDeclaration ds') = concatMap go ds'

51 go _ = []

52

53−dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]

53+dependencies :: (Data d) => ModuleName -> d -> [Key]

54−dependencies env moduleName = nub . everything (++) (mkQ [] values)

54+dependencies 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)]

57+ values (Var ident) = let (mn, name) = qualify moduleName 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 _ = []

60

61

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

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

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

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

65 --

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

67

68+-- |

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

70+--

71+data ImportType

72+ -- |

73+ -- A type constructor import

74+ --

75+ = TypeImport ProperName (Maybe [ProperName])

76+ -- |

77+ -- A declaration import

78+ --

79+ | NameImport Ident

80+ -- |

81+ -- A type class import

82+ --

83+ | TypeClassImport ProperName

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

85+

68-- |

86-- |

69-- The data type of declarations

87-- The data type of declarations

70--

88--

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

108 -- |

126 -- |

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

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

110 --

128 --

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

129+ | ImportDeclaration ModuleName (Maybe [ImportType])

112 -- |

130 -- |

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

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

114 --

132 --

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

@@ -88,9 +88,15 @@ 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 parseExplicitImport

92 return $ ImportDeclaration moduleName' idents

93

94+parseExplicitImport :: P.Parsec String ParseState ImportType

95+parseExplicitImport = NameImport <$> parseIdent

96+ <|> do name <- properName

97+ dctors <- P.optionMaybe $ parens (Just <$> commaSep1 properName <|> lexeme (P.string "..") *> pure Nothing)

98+ return $ maybe (TypeClassImport name) (TypeImport name) dctors

99+

94parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

100parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

95parseTypeClassDeclaration = do

101parseTypeClassDeclaration = do

96 reserved "class"

102 reserved "class"

src/Language/PureScript/Parser/Values.hs+5−5

@@ -74,11 +74,11 @@ parseCase :: P.Parsec String ParseState Value

74parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)

75 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

76

77−parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)

77+parseCaseAlternative :: P.Parsec String ParseState CaseAlternative

78−parseCaseAlternative = (,,) <$> (return <$> parseBinder)

78+parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)

79− <*> P.optionMaybe parseGuard

79+ <*> P.optionMaybe parseGuard

80− <*> (C.indented *> C.reservedOp "->" *> parseValue)

80+ <*> (C.indented *> C.reservedOp "->" *> parseValue)

81− P.<?> "case alternative"

81+ P.<?> "case alternative"

82

83parseIfThenElse :: P.Parsec String ParseState Value

84parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)

src/Language/PureScript/Pretty/Values.hs+3−2

@@ -45,8 +45,9 @@ literals = mkPattern match

45 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

46 match _ = Nothing

47

48−prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String

48+prettyPrintCaseAlternative :: CaseAlternative -> String

49+prettyPrintCaseAlternative (CaseAlternative binders grd val) =

49−prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++

50+ "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++

50 maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val

51 maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val

51

52

52ifThenElse :: Pattern () Value ((Value, Value), Value)

53ifThenElse :: Pattern () Value ((Value, Value), Value)

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

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

30

31

31-- |

32-- |

32-- The desugaring pipeline proceeds as follows:

33-- The desugaring pipeline proceeds as follows:

@@ -45,11 +46,14 @@ import Language.PureScript.Sugar.Let as S

45--

46--

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

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

47--

48--

49+-- * Qualify any unqualified names and types

50+--

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

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

49−desugar = desugarTypeClasses

50− >=> rebracket

52+desugar = rebracket

51 >=> desugarDo

53 >=> desugarDo

54+ >=> desugarCasesModule

52 >=> desugarLetBindings

55 >=> desugarLetBindings

53− >>> desugarCasesModule

56+ >>> desugarImports

54 >=> desugarTypeDeclarationsModule

57 >=> desugarTypeDeclarationsModule

58+ >=> desugarTypeClasses

55 >=> createBindingGroupsModule

59 >=> createBindingGroupsModule

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 _ = []

85

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 _ = []

92

93getIdent :: Declaration -> Ident

src/Language/PureScript/Sugar/CaseDeclarations.hs+11−5

@@ -22,8 +22,8 @@ module Language.PureScript.Sugar.CaseDeclarations (

22import Data.List (groupBy)

23import Data.Generics (mkT, everywhere)

24

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

25+import Control.Applicative

26−import Control.Monad (forM, join, unless)

26+import Control.Monad ((<=<), forM, join, unless)

27import Control.Monad.Error.Class

28

29import Language.PureScript.Names

@@ -44,14 +44,20 @@ desugarAbs = everywhere (mkT replace)

44 let

45 ident = head $ unusedNames (binder, val)

46 in

47− Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [([binder], Nothing, val)]

47+ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]

48 replace other = other

49

50-- |

51-- Replace all top-level binders with case expressions.

52--

53desugarCases :: [Declaration] -> Either String [Declaration]

54−desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

54+desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

55+ where

56+ desugarRest :: [Declaration] -> Either String [Declaration]

57+ desugarRest ((TypeInstanceDeclaration constraints className tys ds) : rest) =

58+ (:) <$> (TypeInstanceDeclaration constraints className tys <$> desugarCases ds) <*> desugarRest rest

59+ desugarRest (d : ds) = (:) d <$> desugarRest ds

60+ desugarRest [] = pure []

55

61

56inSameGroup :: Declaration -> Declaration -> Bool

62inSameGroup :: Declaration -> Declaration -> Bool

57inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2

63inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2

@@ -76,7 +82,7 @@ makeCaseDeclaration ident alternatives =

76 argPattern = length . fst . head $ alternatives

82 argPattern = length . fst . head $ alternatives

77 args = take argPattern $ unusedNames (ident, alternatives)

83 args = take argPattern $ unusedNames (ident, alternatives)

78 vars = map (Var . Qualified Nothing) args

84 vars = map (Var . Qualified Nothing) args

79− binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ]

85+ binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]

80 value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args

86 value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args

81 in

87 in

82 ValueDeclaration ident [] Nothing value

88 ValueDeclaration ident [] Nothing value

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

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

55 go (DoNotationBind binder val : rest) = do

56 rest' <- go rest

57 let ident = head $ unusedNames rest'

58− return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')]))

58+ return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))

59 go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"

60 go (DoNotationLet binder val : rest) = do

61 rest' <- go rest

62− return $ Case [val] [([binder], Nothing, rest')]

62+ return $ Case [val] [CaseAlternative [binder] Nothing rest']

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

@@ -28,5 +28,5 @@ import Language.PureScript.Declarations

28desugarLetBindings :: [Module] -> [Module]

29desugarLetBindings = everywhere (mkT go)

30 where

31− go (Let binder value result) = Case [value] [([binder], Nothing, result)]

31+ go (Let binder value result) = Case [value] [CaseAlternative [binder] Nothing result]

32 go other = other

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

@@ -0,0 +1,303 @@

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+ desugarImports

17+) where

18+

19+import Data.Maybe (fromMaybe)

20+import Data.Data

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

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

23+

24+import Control.Applicative (Applicative(..), (<$>), (<*>))

25+import Control.Monad (foldM)

26+import Control.Monad.Error

27+

28+import qualified Data.Map as M

29+import qualified Data.Set as S

30+

31+import Language.PureScript.Declarations

32+import Language.PureScript.Names

33+import Language.PureScript.Types

34+import Language.PureScript.Values

35+

36+-- |

37+-- The global export environment - every declaration exported from every module.

38+--

39+type ExportEnvironment = M.Map ModuleName Exports

40+

41+-- |

42+-- The exported declarations from a module.

43+--

44+data Exports = Exports

45+ -- |

46+ -- The types exported from each module

47+ --

48+ { exportedTypes :: S.Set (ProperName, [ProperName])

49+ -- |

50+ -- The classes exported from each module

51+ --

52+ , exportedTypeClasses :: S.Set ProperName

53+ -- |

54+ -- The values exported from each module

55+ , exportedValues :: S.Set Ident

56+ --

57+ } deriving (Show)

58+

59+-- |

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

61+--

62+data ImportEnvironment = ImportEnvironment

63+ -- |

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

65+ --

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

67+ -- |

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

69+ --

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

71+ -- |

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

73+ --

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

75+ -- |

76+ -- Local names for values within a module mapped to to their qualified names

77+ --

78+ , importedValues :: M.Map Ident (Qualified Ident)

79+ } deriving (Show)

80+

81+-- |

82+-- Updates the exports for a module from the global environment. If the module was not previously

83+-- present in the global environment, it is created.

84+--

85+updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment

86+updateExportedModule env mn update = do

87+ let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env

88+ exports' <- update exports

89+ return $ M.insert mn exports' env

90+

91+-- |

92+-- Adds an empty module to an ExportEnvironment.

93+--

94+addEmptyModule :: ExportEnvironment -> ModuleName -> ExportEnvironment

95+addEmptyModule env name = M.insert name (Exports S.empty S.empty S.empty) env

96+

97+-- |

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

99+--

100+addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment

101+addType env mn name dctors = updateExportedModule env mn $ \m -> do

102+ types <- addExport (exportedTypes m) (name, dctors)

103+ return $ m { exportedTypes = types }

104+

105+-- |

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

107+--

108+addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment

109+addTypeClass env mn name = updateExportedModule env mn $ \m -> do

110+ classes <- addExport (exportedTypeClasses m) name

111+ return $ m { exportedTypeClasses = classes }

112+

113+-- |

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

115+--

116+addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment

117+addValue env mn name = updateExportedModule env mn $ \m -> do

118+ values <- addExport (exportedValues m) name

119+ return $ m { exportedValues = values }

120+

121+-- |

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

123+--

124+addExport :: (Ord s, Show s) => S.Set s -> s -> Either String (S.Set s)

125+addExport exports name =

126+ if S.member name exports

127+ then throwError $ "Multiple definitions for '" ++ show name ++ "'"

128+ else return $ S.insert name exports

129+

130+-- |

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

132+--

133+desugarImports :: [Module] -> Either String [Module]

134+desugarImports modules = do

135+ exports <- findExports modules

136+ mapM (renameInModule' exports) modules

137+ where

138+ renameInModule' exports m = rethrowForModule m $ do

139+ imports <- resolveImports exports m

140+ renameInModule imports m

141+

142+-- |

143+-- Rethrow an error with the name of the current module in the case of a failure

144+--

145+rethrowForModule :: Module -> Either String a -> Either String a

146+rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)

147+

148+-- |

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

150+--

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

152+renameInModule imports (Module mn decls) =

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

154+ where

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

156+ TypeInstanceDeclaration <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds

157+ updateDecl d = return d

158+

159+ updateVars :: Declaration -> Either String Declaration

160+ updateVars (ValueDeclaration name [] Nothing val) =

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

162+ where

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

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

165+ bindFunctionArgs bound other = return (bound, other)

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

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

168+ updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name

169+ updateVars other = return other

170+

171+ updateValue (Constructor (Qualified Nothing nm)) =

172+ Constructor <$> updateDataConstructorName nm

173+ updateValue v = return v

174+

175+ updateBinder (ConstructorBinder (Qualified Nothing nm) b) =

176+ ConstructorBinder <$> updateDataConstructorName nm <*> pure b

177+ updateBinder v = return v

178+ updateType (TypeConstructor (Qualified Nothing nm)) =

179+ TypeConstructor <$> updateTypeName nm

180+ updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) =

181+ SaturatedTypeSynonym <$> updateTypeName nm <*> mapM updateType tys

182+ updateType (ConstrainedType cs t) =

183+ ConstrainedType <$> updateConstraints cs <*> pure t

184+ updateType t = return t

185+ updateConstraints = mapM updateConstraint

186+ updateConstraint (Qualified Nothing nm, ts) = (,) <$> updateClassName nm <*> pure ts

187+ updateConstraint other = return other

188+ updateTypeName = update "type" importedTypes

189+ updateClassName = update "type class" importedTypeClasses

190+ updateValueName = update "value" importedValues

191+ updateDataConstructorName = update "data constructor" importedDataConstructors

192+ update t get nm = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show nm ++ "'") return $ M.lookup nm (get imports)

193+

194+-- |

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

196+--

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

198+findExports = foldM addModule M.empty

199+ where

200+ addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds

201+ addDecl mn env (TypeClassDeclaration tcn _ ds) = do

202+ env' <- addTypeClass env mn tcn

203+ foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds

204+ addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)

205+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []

206+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

207+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name

208+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

209+ addDecl _ env _ = return env

210+

211+-- |

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

213+--

214+type ExplicitImports = [ImportType]

215+

216+-- |

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

218+-- explicitly imported declarations.

219+--

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

221+findImports = foldl findImports' M.empty

222+ where

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

224+ findImports' result _ = result

225+

226+-- |

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

228+--

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

230+resolveImports env (Module currentModule decls) =

231+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

232+ where

233+ -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported

234+ scope :: M.Map ModuleName (Maybe ExplicitImports)

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

236+ resolveImport' imp (mn, i) = do

237+ m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env

238+ resolveImport currentModule mn m imp i

239+

240+-- |

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

242+--

243+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment

244+resolveImport currentModule importModule exp imp i = case i of

245+ Nothing -> importAll imp

246+ (Just expl) -> foldM importExplicit imp expl

247+ where

248+

249+ -- Import everything from a module

250+ importAll :: ImportEnvironment -> Either String ImportEnvironment

251+ importAll imp = do

252+ imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeImport name (Just dctors))) imp (S.toList $ exportedTypes exp)

253+ imp'' <- foldM (\m name -> importExplicit m (NameImport name)) imp' (S.toList $ exportedValues exp)

254+ foldM (\m name -> importExplicit m (TypeClassImport name)) imp'' (S.toList $ exportedTypeClasses exp)

255+

256+ -- Import something explicitly

257+ importExplicit :: ImportEnvironment -> ImportType -> Either String ImportEnvironment

258+ importExplicit imp (NameImport name) = do

259+ checkImportExists "value" values name

260+ values' <- updateImports (importedValues imp) name

261+ return $ imp { importedValues = values' }

262+ importExplicit imp (TypeImport name dctors) = do

263+ checkImportExists "type" types name

264+ types' <- updateImports (importedTypes imp) name

265+ let allDctors = allExportedDataConstructors name

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

267+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'

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

269+ importExplicit imp (TypeClassImport name) = do

270+ checkImportExists "type class" classes name

271+ typeClasses' <- updateImports (importedTypeClasses imp) name

272+ return $ imp { importedTypeClasses = typeClasses' }

273+

274+ -- Find all exported data constructors for a given type

275+ allExportedDataConstructors :: ProperName -> [ProperName]

276+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` S.toList (exportedTypes exp)

277+

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

279+ updateImports :: (Ord id, Show id) => M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))

280+ updateImports m name = case M.lookup name m of

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

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

283+ if mn == currentModule || importModule == currentModule

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

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

286+

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

288+ values = exportedValues exp

289+ types = fst `S.map` exportedTypes exp

290+ classes = exportedTypeClasses exp

291+

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

293+ -- from

294+ checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName

295+ checkDctorExists names = checkImportExists "data constructor" (S.fromList names)

296+

297+ -- Check that an explicitly imported item exists in the module it is being imported from

298+ checkImportExists :: (Show a, Ord a, Eq a) => String -> S.Set a -> a -> Either String a

299+ checkImportExists t exports item =

300+ if item `S.member` exports

301+ then return item

302+ else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"

303+

src/Language/PureScript/Sugar/TypeClasses.hs+7−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

@@ -156,8 +156,8 @@ typeInstanceDictionaryEntryDeclaration mn deps name tys (ValueDeclaration ident

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

157

158qualifiedToString :: 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

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

160+

161

162-- |

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

src/Language/PureScript/TypeChecker.hs+20−84

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

57

56

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)

75

62

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

87

74

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

@@ -189,70 +171,24 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d

189 return $ d : ds

171 return $ d : ds

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

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

191 env <- getEnv

173 env <- getEnv

192− rethrow errorMessage $ do

174+ let instances = filter (\tcd ->

193− guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env

175+ let Qualified (Just mn) _ = tcdName tcd in

194− case idents of

176+ moduleName == mn && tcdType tcd == TCDRegular

195− Nothing -> do

177+ ) (typeClassDictionaries env)

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

178+ forM_ instances $ \tcd -> do

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

179+ let (Qualified _ ident) = tcdName tcd

198− Just idents' -> do

180+ addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]

199− shadowIdents (lefts idents') env

200− shadowTypes (rights idents') env

201− shadowTypeClassInstances env

202 ds <- typeCheckAll mainModuleName currentModule rest

181 ds <- typeCheckAll mainModuleName currentModule rest

203 return $ d : ds

182 return $ d : ds

204− where

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

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

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

208− shadowIdents idents' env =

209− forM_ idents' $ \ident ->

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

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

212− Just (pt, _) -> do

213− guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

214− modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })

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

216− shadowTypes pns env =

217− forM_ pns $ \pn ->

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

219− 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

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

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

232− shadowTypeClassInstances env = do

233− let instances = filter (\tcd ->

234− let Qualified (Just mn) _ = tcdName tcd in

235− moduleName == mn && tcdType tcd == TCDRegular

236− ) (typeClassDictionaries env)

237− forM_ instances $ \tcd -> do

238− let (Qualified _ ident) = tcdName tcd

239− addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]

240− constructs (TypeConstructor (Qualified (Just mn) pn')) pn

241− = mn == moduleName && pn' == pn

242− constructs (ForAll _ ty _) pn = ty `constructs` pn

243− constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn

244− constructs (TypeApp ty _) pn = ty `constructs` pn

245− constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn

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

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

247 env <- getEnv

184 env <- getEnv

248 ds <- typeCheckAll mainModuleName moduleName rest

185 ds <- typeCheckAll mainModuleName moduleName rest

249− return $ qualifyAllUnqualifiedNames moduleName env d : ds

186+ return $ d : ds

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

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

251 env <- getEnv

188 env <- getEnv

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

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

253 mapM_ (checkTypeClassInstance moduleName) tys

190 mapM_ (checkTypeClassInstance moduleName) tys

254 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

191 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

255− addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env

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

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

257 ds <- typeCheckAll mainModuleName moduleName rest

193 ds <- typeCheckAll mainModuleName moduleName rest

258− return $ qualifyAllUnqualifiedNames moduleName env d : ds

194+ 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−83

@@ -49,10 +49,6 @@ data NameKind

49 --

50 | Extern ForeignImportType

51 -- |

52− -- An alias for a value in another module, introduced using an import declaration

53− --

54− | Alias ModuleName Ident

55− -- |

56 -- A local name introduced using a lambda abstraction, variable introduction or binder

52 -- A local name introduced using a lambda abstraction, variable introduction or binder

57 --

53 --

58 | LocalVariable

54 | LocalVariable

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

61 --

57 --

62 | DataConstructor deriving Show

58 | DataConstructor deriving Show

63

59

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

60-- |

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

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

91--

62--

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

97 -- |

68 -- |

98 -- Type names currently in scope

69 -- Type names currently in scope

99 --

70 --

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

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

101 -- |

72 -- |

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

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

103 --

74 --

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

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

105 -- |

76 -- |

106 -- Type synonyms currently in scope

77 -- Type synonyms currently in scope

107 --

78 --

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

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

109 -- |

80 -- |

110 -- Available type class dictionaries

81 -- Available type class dictionaries

111 --

82 --

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

115-- |

86-- |

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

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

117--

88--

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

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

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

90+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))

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

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

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

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

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

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

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

124

95

125-- |

96-- |

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

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

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

142-- |

113-- |

143-- Temporarily bind a collection of names to types

114-- Temporarily bind a collection of names to types

144--

115--

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

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

146bindTypes newNames action = do

117bindTypes newNames action = do

147 orig <- get

118 orig <- get

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

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

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

179--

150--

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

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

181bindLocalTypeVariables moduleName bindings =

152bindLocalTypeVariables moduleName bindings =

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

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

183

154

184-- |

155-- |

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

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

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

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

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

198lookupTypeVariable currentModule (Qualified moduleName name) = do

169lookupTypeVariable currentModule (Qualified moduleName name) = do

199 env <- getEnv

170 env <- getEnv

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

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

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

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

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

173+ Just k -> return k

203−

204−-- |

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

206−--

207−canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)

208−canonicalize _ _ (Qualified (Just mn) i) = (mn, i)

209−canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of

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

211− _ -> (mn, i)

212−

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

174

231-- |

175-- |

232-- State required for type checking:

176-- State required for type checking:

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

322 Right (a, ust) -> do

266 Right (a, ust) -> do

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

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

324 return (a, unifyCurrentSubstitution ust)

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

20

21import Language.PureScript.Types

22import Language.PureScript.Names

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

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

24

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

43

44

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

51

52

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

57

58

59

src/Language/PureScript/TypeChecker/Types.hs+21−30

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

@@ -294,8 +288,6 @@ entails moduleName context goal@(className, tys) = do

294 filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True

288 filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True

295 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True

289 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True

296 filterModule _ = False

290 filterModule _ = False

297− -- Resolve a type class dictionary in scope to an actual value by following any (TCDAlias) pointers

298− -- which originated from module imports

299 canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

291 canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident

300 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

292 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

301 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

293 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

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

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

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

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

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

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

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

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

309+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

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

311typeHeadsAreEqual 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

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

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

419 Just moduleName <- checkCurrentModule <$> get

411 Just moduleName <- checkCurrentModule <$> get

420 dicts <- getTypeClassDictionaries

412 dicts <- getTypeClassDictionaries

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

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

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

423instantiatePolyTypeWithUnknowns val ty = return (val, ty)

415instantiatePolyTypeWithUnknowns val ty = return (val, ty)

424

416

425-- |

417-- |

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

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

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

438replaceAllTypeSynonyms' env moduleName d =

430replaceAllTypeSynonyms' env moduleName d =

439 let

431 let

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

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

441 in

433 in

442 saturateAllTypeSynonyms env moduleName syns d

434 saturateAllTypeSynonyms env moduleName syns d

443

435

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

461--

453--

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

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

463expandTypeSynonym' env moduleName name args =

455expandTypeSynonym' env moduleName name args =

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

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

465 Just (synArgs, body) -> do

457 Just (synArgs, body) -> do

466 let repl = replaceAllTypeVars (zip synArgs args) body

458 let repl = replaceAllTypeVars (zip synArgs args) body

467 replaceAllTypeSynonyms' env moduleName repl

459 replaceAllTypeSynonyms' env moduleName repl

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

540 ConstrainedType constraints ty' -> do

532 ConstrainedType constraints ty' -> do

541 env <- getEnv

533 env <- getEnv

542 dicts <- getTypeClassDictionaries

534 dicts <- getTypeClassDictionaries

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

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

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

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

545infer' v@(Constructor c) = do

537infer' v@(Constructor c) = do

546 env <- getEnv

538 env <- getEnv

547 Just moduleName <- checkCurrentModule <$> get

539 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

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

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

551− return $ TypedValue True v ty'

543+ return $ TypedValue True v ty'

552infer' (Case vals binders) = do

544infer' (Case vals binders) = do

553 ts <- mapM infer vals

545 ts <- mapM infer vals

554 ret <- fresh

546 ret <- fresh

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

596inferBinder val (ConstructorBinder ctor binders) = do

588inferBinder val (ConstructorBinder ctor binders) = do

597 env <- getEnv

589 env <- getEnv

598 Just moduleName <- checkCurrentModule <$> get

590 Just moduleName <- checkCurrentModule <$> get

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

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

600− Just (ty, _) -> do

592+ Just ty -> do

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

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

602 go binders fn

594 go binders fn

603 where

595 where

@@ -640,18 +632,18 @@ inferBinder val (NamedBinder name binder) = do

640-- |

632-- |

641-- Check the types of the return values in a set of binders in a case statement

633-- Check the types of the return values in a set of binders in a case statement

642--

634--

643−checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> UnifyT Type Check [([Binder], Maybe Guard, Value)]

635+checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]

644checkBinders _ _ [] = return []

636checkBinders _ _ [] = return []

645−checkBinders nvals ret ((binders, grd, val):bs) = do

637+checkBinders nvals ret (CaseAlternative binders grd val : bs) = do

646 Just moduleName <- checkCurrentModule <$> get

638 Just moduleName <- checkCurrentModule <$> get

647 m1 <- M.unions <$> zipWithM inferBinder nvals binders

639 m1 <- M.unions <$> zipWithM inferBinder nvals binders

648 r <- bindLocalVariables moduleName (M.toList m1) $ do

640 r <- bindLocalVariables moduleName (M.toList m1) $ do

649 val' <- TypedValue True <$> check val ret <*> pure ret

641 val' <- TypedValue True <$> check val ret <*> pure ret

650 case grd of

642 case grd of

651− Nothing -> return (binders, Nothing, val')

643+ Nothing -> return $ CaseAlternative binders Nothing val'

652 Just g -> do

644 Just g -> do

653 g' <- check g tyBoolean

645 g' <- check g tyBoolean

654− return (binders, Just g', val')

646+ return $ CaseAlternative binders (Just g') val'

655 rs <- checkBinders nvals ret bs

647 rs <- checkBinders nvals ret bs

656 return $ r : rs

648 return $ r : rs

657

649

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

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

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

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

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

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

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

728− (qualifyAllUnqualifiedNames moduleName env constraints)) $

729− check val ty

720+ constraints) $ check val ty

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

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

731check' val (SaturatedTypeSynonym name args) = do

722check' val (SaturatedTypeSynonym name args) = do

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

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

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

806check' (Constructor c) ty = do

797check' (Constructor c) ty = do

807 env <- getEnv

798 env <- getEnv

808 Just moduleName <- checkCurrentModule <$> get

799 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

811− Just (ty1, _) -> do

802+ Just ty1 -> do

812 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

803 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

813 _ <- subsumes Nothing repl ty

804 _ <- subsumes Nothing repl ty

814 return $ TypedValue True (Constructor c) ty

805 return $ TypedValue True (Constructor c) ty

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

886 env <- getEnv

877 env <- getEnv

887 dicts <- getTypeClassDictionaries

878 dicts <- getTypeClassDictionaries

888 Just moduleName <- checkCurrentModule <$> get

879 Just moduleName <- checkCurrentModule <$> get

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

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

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

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

891 ++ prettyPrintType fnTy

882 ++ prettyPrintType fnTy

892 ++ " to argument " ++ prettyPrintValue arg

883 ++ " to argument " ++ prettyPrintValue arg

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

932 dicts <- getTypeClassDictionaries

923 dicts <- getTypeClassDictionaries

933 Just moduleName <- checkCurrentModule <$> get

924 Just moduleName <- checkCurrentModule <$> get

934 _ <- subsumes' Nothing ty1 ty2

925 _ <- subsumes' Nothing ty1 ty2

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

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

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

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

937 let

928 let

938 (ts1, r1') = rowToList r1

929 (ts1, r1') = rowToList r1

src/Language/PureScript/Values.hs+41−11

@@ -21,6 +21,7 @@ import Language.PureScript.Types

21import Language.PureScript.Names

22

23import Data.Data

24+import Data.Generics (mkQ, everything)

24

25

25-- |

26-- |

26-- A guard is just a boolean-valued expression that appears alongside a set of binders

27-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -93,7 +94,7 @@ data Value

93 -- A case expression. During the case expansion phase of desugaring, top-level binders will get

94 -- A case expression. During the case expansion phase of desugaring, top-level binders will get

94 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

95 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

95 --

96 --

96− | Case [Value] [([Binder], Maybe Guard, Value)]

97+ | Case [Value] [CaseAlternative]

97 -- |

98 -- |

98 -- A value with a type annotation

99 -- A value with a type annotation

99 --

100 --

@@ -115,17 +116,22 @@ data Value

115 | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

116 | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

116

117

117-- |

118-- |

118−-- The type of a type class dictionary

119+-- An alternative in a case statement

119--

120--

120−data TypeClassDictionaryType

121+data CaseAlternative = CaseAlternative

121− -- |

122− -- A regular type class dictionary

123− --

124− = TCDRegular

125− -- |

122+ { -- |

126− -- A type class dictionary which is an alias for an imported dictionary from another module

123+ -- A collection of binders with which to match the inputs

124+ --

125+ caseAlternativeBinders :: [Binder]

126+ -- |

127+ -- An optional guard

127− --

128+ --

129+ , caseAlternativeGuard :: Maybe Guard

130+ -- |

131+ -- The result expression

132+ --

133+ , caseAlternativeResult :: Value

128− | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)

134+ } deriving (Show, Data, Typeable)

129

135

130-- |

136-- |

131-- Data representing a type class dictionary which is in scope

137-- Data representing a type class dictionary which is in scope

@@ -154,6 +160,19 @@ data TypeClassDictionaryInScope

154 , tcdType :: TypeClassDictionaryType

160 , tcdType :: TypeClassDictionaryType

155 } deriving (Show, Data, Typeable)

161 } deriving (Show, Data, Typeable)

156

162

163+-- |

164+-- The type of a type class dictionary

165+--

166+data TypeClassDictionaryType

167+ -- |

168+ -- A regular type class dictionary

169+ --

170+ = TCDRegular

171+ -- |

172+ -- A type class dictionary which is an alias for an imported dictionary from another module

173+ --

174+ | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)

175+

157-- |

176-- |

158-- A statement in a do-notation block

177-- A statement in a do-notation block

159--

178--

@@ -215,3 +234,14 @@ data Binder

215 -- A binder which binds its input to an identifier

234 -- A binder which binds its input to an identifier

216 --

235 --

217 | NamedBinder Ident Binder deriving (Show, Data, Typeable)

236 | NamedBinder Ident Binder deriving (Show, Data, Typeable)

237+

238+

239+-- |

240+-- Collect all names introduced in binders in an expression

241+--

242+binderNames :: (Data d) => d -> [Ident]

243+binderNames = everything (++) (mkQ [] go)

244+ where

245+ go (VarBinder ident) = [ident]

246+ go (NamedBinder ident _) = [ident]

247+ go _ = []