0ec9d41 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1373 from purescript/standalonederiving

0ec9d41Phil Freeman11 years ago

core-tests/tests/generic-deriving/Main.purs+6−4

compare with golang

unifiedsplit

@@ -4,10 +4,12 @@ import Prelude

5import Data.Generic

7−data A

7+data A a

8 = A Number String

9 | B Int

10− | C (Array A)

10+ | C (Array (A a))

11− | D { a :: A }

11+ | D { a :: a }

13−instance genericA :: Generic A

13+derive instance genericA :: (Generic a) => Generic (A a)

14+

15+main = Control.Monad.Eff.Console.log (gShow (D { a: C [ A 1.0 "test", B 42, D { a: true } ] }))

purescript.cabal+1−1

@@ -122,10 +122,10 @@ library

122 Language.PureScript.Sugar.ObjectWildcards

123 Language.PureScript.Sugar.Operators

124 Language.PureScript.Sugar.TypeClasses

125+ Language.PureScript.Sugar.TypeClasses.Deriving

125 Language.PureScript.Sugar.TypeDeclarations

126 Language.PureScript.Sugar.TypeDeclarations

126 Language.PureScript.Traversals

127 Language.PureScript.Traversals

127 Language.PureScript.TypeChecker

128 Language.PureScript.TypeChecker

128− Language.PureScript.TypeChecker.Deriving

129 Language.PureScript.TypeChecker.Entailment

130 Language.PureScript.TypeChecker.Kinds

131 Language.PureScript.TypeChecker.Monad

src/Language/PureScript/AST/Declarations.hs+21−4

@@ -19,6 +19,10 @@ module Language.PureScript.AST.Declarations where

19import qualified Data.Data as D

20import qualified Data.Map as M

22+import Control.Monad.Identity

23+

24+import Control.Applicative

25+

22import Language.PureScript.AST.Binders

26import Language.PureScript.AST.Binders

23import Language.PureScript.AST.Operators

27import Language.PureScript.AST.Operators

24import Language.PureScript.AST.SourcePos

28import Language.PureScript.AST.SourcePos

@@ -154,13 +158,29 @@ data Declaration

154 -- A type instance declaration (name, dependencies, class name, instance types, member

158 -- A type instance declaration (name, dependencies, class name, instance types, member

155 -- declarations)

159 -- declarations)

156 --

160 --

157− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]

161+ | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody

158 -- |

162 -- |

159 -- A declaration with source position information

163 -- A declaration with source position information

160 --

164 --

161 | PositionedDeclaration SourceSpan [Comment] Declaration

165 | PositionedDeclaration SourceSpan [Comment] Declaration

162 deriving (Show, D.Data, D.Typeable)

166 deriving (Show, D.Data, D.Typeable)

163

167

168+-- | The members of a type class instance declaration

169+data TypeInstanceBody

170+ -- | This is a derived instance

171+ = DerivedInstance

172+ -- | This is a regular (explicit) instance

173+ | ExplicitInstance [Declaration]

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

175+

176+mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody

177+mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)

178+

179+-- | A traversal for TypeInstanceBody

180+traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody

181+traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance

182+traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds

183+

164-- |

184-- |

165-- Test if a declaration is a value declaration

185-- Test if a declaration is a value declaration

166--

186--

@@ -376,9 +396,6 @@ data Expr

376 --

396 --

377 | SuperClassDictionary (Qualified ProperName) [Type]

397 | SuperClassDictionary (Qualified ProperName) [Type]

378 -- |

398 -- |

379− -- A placeholder for a member function of a typeclass instance. To be elaborated during typechecking. (function name, class name, name of the type gaining the instance).

380− | TypeClassInstanceMemberFunction Ident (Qualified ProperName) (Qualified ProperName)

381− -- |

382 -- A value with source position information

399 -- A value with source position information

383 --

400 --

384 | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)

401 | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/AST/Traversals.hs+7−6

@@ -16,6 +16,7 @@ module Language.PureScript.AST.Traversals where

17import Data.Monoid (Monoid(..), mconcat)

18import Data.Maybe (mapMaybe)

19+import Data.Traversable (traverse)

20import Control.Applicative

21import Control.Applicative

21import Control.Monad

22import Control.Monad

@@ -37,7 +38,7 @@ everywhereOnValues f g h = (f', g', h')

37 f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))

38 f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))

38 f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))

39 f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))

39 f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))

40 f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))

40− f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))

41+ f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds))

41 f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))

42 f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))

42 f' other = f other

43 f' other = f other

@@ -95,7 +96,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

95 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

96 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

96 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

97 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

97 f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds

98 f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds

98− f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds

99+ f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds

99 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')

100 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')

100 f' other = f other

101 f' other = f other

101

102

@@ -147,7 +148,7 @@ everywhereOnValuesM f g h = (f', g', h')

147 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f

148 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f

148 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

149 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

149 f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f

150 f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f

150− f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f

151+ f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM f') ds) >>= f

151 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f

152 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f

152 f' other = f other

153 f' other = f other

153

154

@@ -202,7 +203,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

202 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

203 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

203 f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)

204 f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)

204 f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)

205 f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)

205− f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)

206+ f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds)

206 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1

207 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1

207 f' d = f d

208 f' d = f d

208

209

@@ -266,7 +267,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

266 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

267 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

267 f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)

268 f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)

268 f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

269 f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

269− f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

270+ f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds)

270 f' s (PositionedDeclaration _ _ d1) = f'' s d1

271 f' s (PositionedDeclaration _ _ d1) = f'' s d1

271 f' _ _ = r0

272 f' _ _ = r0

272

273

@@ -335,7 +336,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

335 f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val

336 f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val

336 f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds

337 f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds

337 f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds

338 f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds

338− f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds

339+ f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM (f'' s)) ds

339 f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1

340 f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1

340 f' _ other = return other

341 f' _ other = return other

341

342

src/Language/PureScript/Errors.hs+8

@@ -102,6 +102,8 @@ data SimpleErrorMessage

102 | ConstrainedTypeUnified Type Type

103 | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]

104 | NoInstanceFound (Qualified ProperName) [Type]

105+ | CannotDerive (Qualified ProperName) [Type]

106+ | CannotFindDerivingType ProperName

105 | DuplicateLabel String (Maybe Expr)

107 | DuplicateLabel String (Maybe Expr)

106 | DuplicateValueDeclaration Ident

108 | DuplicateValueDeclaration Ident

107 | ArgListLengthsDiffer Ident

109 | ArgListLengthsDiffer Ident

@@ -214,6 +216,8 @@ errorCode em = case unwrapErrorMessage em of

214 (ConstrainedTypeUnified _ _) -> "ConstrainedTypeUnified"

216 (ConstrainedTypeUnified _ _) -> "ConstrainedTypeUnified"

215 (OverlappingInstances _ _ _) -> "OverlappingInstances"

217 (OverlappingInstances _ _ _) -> "OverlappingInstances"

216 (NoInstanceFound _ _) -> "NoInstanceFound"

218 (NoInstanceFound _ _) -> "NoInstanceFound"

219+ (CannotDerive _ _) -> "CannotDerive"

220+ (CannotFindDerivingType _) -> "CannotFindDerivingType"

217 (DuplicateLabel _ _) -> "DuplicateLabel"

221 (DuplicateLabel _ _) -> "DuplicateLabel"

218 (DuplicateValueDeclaration _) -> "DuplicateValueDeclaration"

222 (DuplicateValueDeclaration _) -> "DuplicateValueDeclaration"

219 (ArgListLengthsDiffer _) -> "ArgListLengthsDiffer"

223 (ArgListLengthsDiffer _) -> "ArgListLengthsDiffer"

@@ -509,6 +513,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

509 ]

513 ]

510 goSimple (NoInstanceFound nm ts) =

514 goSimple (NoInstanceFound nm ts) =

511 line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

515 line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

516+ goSimple (CannotDerive nm ts) =

517+ line $ "Cannot derive " ++ show nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)

518+ goSimple (CannotFindDerivingType nm) =

519+ line $ "Cannot derive instance, because the type declaration for " ++ show nm ++ " could not be found."

512 goSimple (DuplicateLabel l expr) =

520 goSimple (DuplicateLabel l expr) =

513 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

521 paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

514 <> foldMap (\expr' -> [ line "Relevant expression: "

522 <> foldMap (\expr' -> [ line "Relevant expression: "

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

@@ -229,7 +229,21 @@ parseTypeInstanceDeclaration = do

229 members <- P.option [] . P.try $ do

230 indented *> reserved "where"

231 mark (P.many (same *> positioned parseValueDeclaration))

232− return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members

232+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members)

233+

234+parseDerivingInstanceDeclaration :: TokenParser Declaration

235+parseDerivingInstanceDeclaration = do

236+ reserved "derive"

237+ reserved "instance"

238+ name <- parseIdent <* indented <* doubleColon

239+ deps <- P.optionMaybe $ do

240+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

241+ indented

242+ rfatArrow

243+ return deps

244+ className <- indented *> parseQualified properName

245+ ty <- P.many (indented *> noWildcards parseTypeAtom)

246+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty DerivedInstance

233

247

234positioned :: TokenParser Declaration -> TokenParser Declaration

248positioned :: TokenParser Declaration -> TokenParser Declaration

235positioned = withSourceSpan PositionedDeclaration

249positioned = withSourceSpan PositionedDeclaration

@@ -248,6 +262,7 @@ parseDeclaration = positioned (P.choice

248 , parseImportDeclaration

262 , parseImportDeclaration

249 , parseTypeClassDeclaration

263 , parseTypeClassDeclaration

250 , parseTypeInstanceDeclaration

264 , parseTypeInstanceDeclaration

265+ , parseDerivingInstanceDeclaration

251 ]) P.<?> "declaration"

266 ]) P.<?> "declaration"

252

267

253parseLocalDeclaration :: TokenParser Declaration

268parseLocalDeclaration :: TokenParser Declaration

src/Language/PureScript/Parser/Lexer.hs+1

@@ -494,6 +494,7 @@ reservedPsNames = [ "data"

494 , "infix"

495 , "class"

496 , "instance"

497+ , "derive"

497 , "module"

498 , "module"

498 , "case"

499 , "case"

499 , "of"

500 , "of"

src/Language/PureScript/Sugar.hs+2

@@ -33,6 +33,7 @@ import Language.PureScript.Sugar.Names as S

33import Language.PureScript.Sugar.ObjectWildcards as S

34import Language.PureScript.Sugar.Operators as S

35import Language.PureScript.Sugar.TypeClasses as S

36+import Language.PureScript.Sugar.TypeClasses.Deriving as S

36import Language.PureScript.Sugar.TypeDeclarations as S

37import Language.PureScript.Sugar.TypeDeclarations as S

38-- |

39-- |

@@ -67,5 +68,6 @@ desugar = map removeSignedLiterals

67 >=> desugarTypeDeclarationsModule

68 >=> desugarTypeDeclarationsModule

68 >=> desugarImports

69 >=> desugarImports

69 >=> rebracket

70 >=> rebracket

71+ >=> mapM deriveInstances

70 >=> desugarTypeClasses

72 >=> desugarTypeClasses

71 >=> createBindingGroupsModule

73 >=> createBindingGroupsModule

src/Language/PureScript/Sugar/CaseDeclarations.hs+2−1

@@ -23,6 +23,7 @@ module Language.PureScript.Sugar.CaseDeclarations (

24import Data.Maybe (catMaybes)

25import Data.List (nub, groupBy)

26+import Data.Traversable (traverse)

27import Control.Applicative

28import Control.Applicative

28import Control.Monad ((<=<), forM, replicateM, join, unless)

29import Control.Monad ((<=<), forM, replicateM, join, unless)

@@ -68,7 +69,7 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro

68 where

69 where

69 desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

70 desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

70 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

71 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

71− (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest

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

72 desugarRest (ValueDeclaration name nameKind bs result : rest) =

73 desugarRest (ValueDeclaration name nameKind bs result : rest) =

73 let (_, f, _) = everywhereOnValuesTopDownM return go return

74 let (_, f, _) = everywhereOnValuesTopDownM return go return

74 f' (Left gs) = Left <$> mapM (pairM return f) gs

75 f' (Left gs) = Left <$> mapM (pairM return f) gs

src/Language/PureScript/Sugar/TypeClasses.hs+3−25

@@ -166,7 +166,8 @@ desugarDecl mn exps = go

166 modify (M.insert (mn, name) d)

167 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

168 go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])

169+ go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = error "Derived instanced should have been desugared"

169− go d@(TypeInstanceDeclaration name deps className tys members) = do

170+ go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do

170 desugared <- desugarCases members

171 desugared <- desugarCases members

171 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

172 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

172 return (expRef name className tys, [d, dictDecl])

173 return (expRef name className tys, [d, dictDecl])

@@ -229,29 +230,8 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type

229unit :: Type

230unit :: Type

230unit = TypeApp tyObject REmpty

231unit = TypeApp tyObject REmpty

231

232

232−fillDerivingDecls :: (MonadError MultipleErrors m, Applicative m) => Qualified ProperName -> [Type] -> [Declaration] -> [Declaration] -> Desugar m [Declaration]

233−fillDerivingDecls className tys tyDecls decls = do

234− let missingDecls = mapMaybe declName tyDecls \\ mapMaybe declName decls

235− let mkMissingDecl cls fun =

236− case tys of

237− [TypeConstructor t] | unQualify className == ProperName cls && Ident fun `elem` missingDecls -> return [ValueDeclaration (Ident fun) Public [] (Right $ TypeClassInstanceMemberFunction (Ident fun) className t)]

238− _ -> return []

239− extraDecls <- concat <$> mapM (uncurry mkMissingDecl)

240− [(C.generic,C.toSpine)

241− ,(C.generic,C.fromSpine)

242− ,(C.generic,C.toSignature)]

243− return $ extraDecls ++ decls

244− where

245− declName :: Declaration -> Maybe Ident

246− declName (PositionedDeclaration _ _ d) = declName d

247− declName (ValueDeclaration ident _ _ _) = Just ident

248− declName (TypeDeclaration ident _) = Just ident

249− declName _ = Nothing

250−

251− unQualify (Qualified _ a) = a

252−

253typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

233typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

254−typeInstanceDictionaryDeclaration name mn deps className tys decls1 =

234+typeInstanceDictionaryDeclaration name mn deps className tys decls =

255 rethrow (onErrorMessages (ErrorInInstance className tys)) $ do

235 rethrow (onErrorMessages (ErrorInInstance className tys)) $ do

256 m <- get

236 m <- get

257

237

@@ -260,8 +240,6 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls1 =

260 maybe (throwError . errorMessage $ UnknownTypeClass className) return $

240 maybe (throwError . errorMessage $ UnknownTypeClass className) return $

261 M.lookup (qualify mn className) m

241 M.lookup (qualify mn className) m

262

242

263− decls <- fillDerivingDecls className tys tyDecls decls1

264−

265 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

243 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

266 member : _ -> throwError . errorMessage $ MissingClassMember member

244 member : _ -> throwError . errorMessage $ MissingClassMember member

267 [] -> do

245 [] -> do

src/Language/PureScript/Sugar/TypeClasses/Deriving.hsnew file+229

@@ -0,0 +1,229 @@

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

2+--

3+-- Module : Language.PureScript.Sugar.TypeClasses.Deriving

4+-- Copyright : (c) Gershom Bazerman 2015

5+-- License : MIT (http://opensource.org/licenses/MIT)

6+--

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

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module implements the generic deriving elaboration that takes place during desugaring.

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE FlexibleContexts #-}

17+{-# LANGUAGE MultiParamTypeClasses #-}

18+{-# LANGUAGE OverloadedStrings #-}

19+{-# LANGUAGE PatternGuards #-}

20+{-# LANGUAGE RankNTypes #-}

21+{-# LANGUAGE ScopedTypeVariables #-}

22+

23+module Language.PureScript.Sugar.TypeClasses.Deriving (

24+ deriveInstances

25+) where

26+

27+import Data.List

28+import Data.Maybe (fromMaybe)

29+import Data.Ord (comparing)

30+

31+import Control.Applicative

32+import Control.Monad (replicateM)

33+import Control.Monad.Supply.Class (MonadSupply, freshName)

34+import Control.Monad.Error.Class (MonadError(..))

35+

36+import Language.PureScript.AST

37+import Language.PureScript.Environment

38+import Language.PureScript.Errors

39+import Language.PureScript.Names

40+import Language.PureScript.Types

41+import qualified Language.PureScript.Constants as C

42+

43+-- | Elaborates deriving instance declarations by code generation.

44+deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module

45+deriveInstances (Module coms mn ds exts) = Module coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts

46+

47+-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

48+-- elaborates that into an instance declaration via code generation.

49+deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration

50+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)

51+ | className == Qualified (Just dataGeneric) (ProperName C.generic)

52+ , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty

53+ , mn == fromMaybe mn mn'

54+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon

55+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

56+ = throwError . errorMessage $ CannotDerive className tys

57+deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

58+deriveInstance _ _ e = return e

59+

60+unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName)

61+unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon

62+unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty

63+unwrapTypeConstructor _ = Nothing

64+

65+dataGeneric :: ModuleName

66+dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

67+

68+dataMaybe :: ModuleName

69+dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

70+

71+deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration]

72+deriveGeneric mn ds tyConNm = do

73+ tyCon <- findTypeDecl tyConNm ds

74+ toSpine <- mkSpineFunction mn tyCon

75+ fromSpine <- mkFromSpineFunction mn tyCon

76+ let toSignature = mkSignatureFunction mn tyCon

77+ return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)

78+ , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)

79+ , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

80+ ]

81+

82+findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration

83+findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl

84+ where

85+ isTypeDecl :: Declaration -> Bool

86+ isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True

87+ isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d

88+ isTypeDecl _ = False

89+

90+mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

91+mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args

92+ where

93+ prodConstructor :: Expr -> Expr

94+ prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))

95+

96+ recordConstructor :: Expr -> Expr

97+ recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))

98+

99+ mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative

100+ mkCtorClause (ctorName, tys) = do

101+ idents <- replicateM (length tys) (fmap Ident freshName)

102+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

103+ where

104+ caseResult idents =

105+ App (prodConstructor (StringLiteral . runProperName $ ctorName))

106+ . ArrayLiteral

107+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys

108+

109+ toSpineFun :: Expr -> Type -> Expr

110+ toSpineFun i r | Just rec <- objectType r =

111+ lamNull . recordConstructor . ArrayLiteral .

112+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])

113+ $ decomposeRec rec

114+ toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i

115+mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d

116+mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration"

117+

118+mkSignatureFunction :: ModuleName -> Declaration -> Expr

119+mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args

120+ where

121+ mkSigProd :: [Expr] -> Expr

122+ mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral

123+

124+ mkSigRec :: [Expr] -> Expr

125+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral

126+

127+ proxy :: Type -> Type

128+ proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))

129+

130+ mkProdClause :: (ProperName, [Type]) -> Expr

131+ mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))

132+ , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)

133+ ]

134+

135+ mkProductSignature :: Type -> Expr

136+ mkProductSignature r | Just rec <- objectType r =

137+ lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)

138+ , ("recValue", mkProductSignature typ)

139+ ]

140+ | (str, typ) <- decomposeRec rec

141+ ]

142+ mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)

143+ (TypedValue False (mkGenVar "anyProxy") (proxy typ))

144+mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d

145+mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration"

146+

147+mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

148+mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)

149+ where

150+ mkJust :: Expr -> Expr

151+ mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))

152+

153+ mkNothing :: Expr

154+ mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))

155+

156+ prodBinder :: [Binder] -> Binder

157+ prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))

158+

159+ recordBinder :: [Binder] -> Binder

160+ recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

161+

162+ mkAlternative :: (ProperName, [Type]) -> m CaseAlternative

163+ mkAlternative (ctorName, tys) = do

164+ idents <- replicateM (length tys) (fmap Ident freshName)

165+ return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]

166+ . Right

167+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

168+ (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)

169+

170+ addCatch :: [CaseAlternative] -> [CaseAlternative]

171+ addCatch = (++ [catchAll])

172+ where

173+ catchAll = CaseAlternative [NullBinder] (Right mkNothing)

174+

175+ fromSpineFun e r

176+ | Just rec <- objectType r

177+ = App (lamCase "r" [ mkRecCase (decomposeRec rec)

178+ , CaseAlternative [NullBinder] (Right mkNothing)

179+ ])

180+ (App e (mkPrelVar "unit"))

181+

182+ fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))

183+

184+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)

185+ ]

186+ ]

187+ . Right

188+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)

189+

190+ mkRecFun :: [(String, Type)] -> Expr

191+ mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)

192+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs

193+mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d

194+mkFromSpineFunction _ _ = error "mkFromSpineFunction: expected DataDeclaration"

195+

196+-- Helpers

197+

198+objectType :: Type -> Maybe Type

199+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec

200+objectType _ = Nothing

201+

202+lam :: String -> Expr -> Expr

203+lam s = Abs (Left (Ident s))

204+

205+lamNull :: Expr -> Expr

206+lamNull = lam "$q"

207+

208+lamCase :: String -> [CaseAlternative] -> Expr

209+lamCase s = lam s . Case [mkVar s]

210+

211+liftApplicative :: Expr -> [Expr] -> Expr

212+liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)

213+

214+mkVarMn :: Maybe ModuleName -> String -> Expr

215+mkVarMn mn s = Var (Qualified mn (Ident s))

216+

217+mkVar :: String -> Expr

218+mkVar s = mkVarMn Nothing s

219+

220+mkPrelVar :: String -> Expr

221+mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s

222+

223+mkGenVar :: String -> Expr

224+mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s

225+

226+decomposeRec :: Type -> [(String, Type)]

227+decomposeRec = sortBy (comparing fst) . go

228+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs

229+ go _ = []

src/Language/PureScript/TypeChecker/Deriving.hsdeleted−154

@@ -1,154 +0,0 @@

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.TypeChecker.Deriving

4−-- Copyright : (c) Gershom Bazerman 2015

5−-- License : MIT (http://opensource.org/licenses/MIT)

6−--

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

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- |

12−-- This module implements the generic deriving elaboration that takes place during typechecking.

13−--

14−-----------------------------------------------------------------------------

15−

16−{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings, PatternGuards #-}

17−

18−module Language.PureScript.TypeChecker.Deriving (

19− elaborateInstance

20−) where

21−

22−import Data.List

23−import Data.Maybe (fromMaybe)

24−import Data.Ord (comparing)

25−import qualified Data.Map as M

26−

27−import Control.Applicative

28−import Control.Monad.State

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

30−

31−import Language.PureScript.AST

32−import Language.PureScript.Environment

33−import Language.PureScript.Errors

34−import Language.PureScript.Names

35−import Language.PureScript.TypeChecker.Monad

36−import Language.PureScript.Types

37−import qualified Language.PureScript.Constants as C

38−

39−-- | Takes an expression, and if the head of the expression is a TypeClassInstanceMemberFunction, elaborates that into an instantiation of the actual member function via code generation.

40−elaborateInstance :: (Functor m, MonadState CheckState m, MonadError MultipleErrors m) => Expr -> m Expr

41−elaborateInstance (TypeClassInstanceMemberFunction funName className t) =

42− fromMaybe noInstanceError $ lookup (unQualify className, funName) derivingList

43− where noInstanceError = throwError $ MultipleErrors [ErrorInInstance className [TypeConstructor t] (SimpleErrorWrapper $ MissingClassMember funName)]

44− derivingList = [((ProperName C.generic, Ident C.toSpine), mkSpineFunction t)

45− ,((ProperName C.generic, Ident C.fromSpine), mkFromSpineFunction t)

46− ,((ProperName C.generic, Ident C.toSignature), mkSignatureFunction t)]

47−elaborateInstance e = return e

48−

49−mkSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr

50−mkSpineFunction t = do

51− ctors <- M.toList . dataConstructors <$> getEnv

52− let prodConstructor = App (Constructor $ findName "SProd" ctors)

53− recordConstructor = App (Constructor $ findName "SRecord" ctors)

54−

55− mkCtorClause (ctorName, (_,_,typ,idents)) = CaseAlternative [ConstructorBinder ctorName (map VarBinder idents)] (Right caseResult)

56− where caseResult = App (prodConstructor (StringLiteral . runProperName . unQualify $ ctorName)) . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) (argTypes typ)

57−

58− toSpineFun :: Expr -> Type -> Expr

59− toSpineFun i r | Just rec <- objectType r =

60− lamNull . recordConstructor . ArrayLiteral .

61− map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])

62− $ decomposeRec rec

63− toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i

64−

65− return . lamCase "$x" . map mkCtorClause . constructorsForType t $ ctors

66−

67−mkSignatureFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr

68−mkSignatureFunction t = do

69− ctors <- M.toList . dataConstructors <$> getEnv

70− envtyps <- M.toList . types <$> getEnv

71− let mkSigProd = App (Constructor $ findName "SigProd" ctors) . ArrayLiteral

72− mkSigRec = App (Constructor $ findName "SigRecord" ctors) . ArrayLiteral

73−

74− mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]

75−

76− mkProductSignature r | Just rec <- objectType r =

77− lamNull . mkSigRec .

78− map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])

79− $ decomposeRec rec

80− mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)

81− (TypedValue False (mkGenVar "anyProxy") (TypeApp (TypeConstructor $ findName "Proxy" envtyps) typ))

82−

83− return . lamNull . mkSigProd . map mkProdClause . constructorsForType t $ ctors

84−

85−mkFromSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr

86−mkFromSpineFunction t = do

87− ctors <- M.toList . dataConstructors <$> getEnv

88− let

89− mkJust = App (Constructor $ findName "Just" ctors)

90− mkNothing = Constructor $ findName "Nothing" ctors

91−

92− mkAlternative (ctor@(Qualified _ (ProperName ctorName)), (_,_,typ,idents)) =

93− CaseAlternative [ConstructorBinder (findName "SProd" ctors) [StringBinder ctorName, ArrayBinder (map VarBinder idents)]]

94− . Right $ liftApplicative (mkJust $ Constructor ctor) (zipWith fromSpineFun (map (Var . (Qualified Nothing))idents) (argTypes typ))

95−

96− fromSpineFun e r | Just rec <- objectType r = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))

97−

98− fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))

99−

100− mkRecCase rs = CaseAlternative [ConstructorBinder (findName "SRecord" ctors) [ArrayBinder (map (VarBinder . Ident . fst) rs)]] . Right $ liftApplicative (mkRecFun rs) (map (\(x,y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)

101−

102− mkRecFun :: [(String,Type)] -> Expr

103− mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)

104− where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs

105−

106− return . lamCase "$x" $ map mkAlternative (constructorsForType t ctors) ++ [CaseAlternative [NullBinder] (Right mkNothing)]

107−

108−-- Helpers

109−

110−objectType :: Type -> Maybe Type

111−objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec

112−objectType _ = Nothing

113−

114−lam :: String -> Expr -> Expr

115−lam s = Abs (Left (Ident s))

116−

117−lamNull :: Expr -> Expr

118−lamNull = lam "$q"

119−

120−lamCase :: String -> [CaseAlternative] -> Expr

121−lamCase s = lam s . Case [mkVar s]

122−

123−liftApplicative :: Expr -> [Expr] -> Expr

124−liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)

125−

126−mkVarMn :: Maybe ModuleName -> String -> Expr

127−mkVarMn mn s = Var (Qualified mn (Ident s))

128−

129−mkVar :: String -> Expr

130−mkVar s = mkVarMn Nothing s

131−

132−mkPrelVar :: String -> Expr

133−mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s

134−

135−mkGenVar :: String -> Expr

136−mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s

137−

138−decomposeRec :: Type -> [(String, Type)]

139−decomposeRec = sortBy (comparing fst) . go

140− where go (RCons str typ typs) = (str, typ) : decomposeRec typs

141− go _ = []

142−

143−argTypes :: Type -> [Type]

144−argTypes (TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Function"))) a) b) = a : argTypes b

145−argTypes _ = []

146−

147−findName :: String -> [(Qualified ProperName, a)] -> Qualified ProperName

148−findName s lst = fromMaybe (Qualified Nothing (ProperName s)) . find ((== ProperName s) . unQualify) . map fst $ lst

149−

150−unQualify :: Qualified a -> a

151−unQualify (Qualified _ x) = x

152−

153−constructorsForType :: Qualified ProperName -> [(Qualified ProperName, (a, ProperName, b, c))] -> [(Qualified ProperName, (a, ProperName, b, c))]

154−constructorsForType t = filter (\(Qualified mn _ ,(_,typeName,_,_)) -> t == Qualified mn typeName)

src/Language/PureScript/TypeChecker/Types.hs−4

@@ -52,7 +52,6 @@ import Language.PureScript.Errors

52import Language.PureScript.Kinds

53import Language.PureScript.Names

54import Language.PureScript.Traversals

55−import Language.PureScript.TypeChecker.Deriving

56import Language.PureScript.TypeChecker.Entailment

55import Language.PureScript.TypeChecker.Entailment

57import Language.PureScript.TypeChecker.Kinds

56import Language.PureScript.TypeChecker.Kinds

58import Language.PureScript.TypeChecker.Monad

57import Language.PureScript.TypeChecker.Monad

@@ -560,9 +559,6 @@ check' (Constructor c) ty = do

560 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

559 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

561 _ <- subsumes Nothing repl ty

560 _ <- subsumes Nothing repl ty

562 return $ TypedValue True (Constructor c) ty

561 return $ TypedValue True (Constructor c) ty

563−

564−check' e@TypeClassInstanceMemberFunction{} ty = flip check' ty =<< elaborateInstance e

565−

566check' (Let ds val) ty = do

562check' (Let ds val) ty = do

567 (ds', val') <- inferLetBinding [] ds val (`check` ty)

563 (ds', val') <- inferLetBinding [] ds val (`check` ty)

568 return $ TypedValue True (Let ds' val') ty

564 return $ TypedValue True (Let ds' val') ty