57f3a5c · rowtype-yoga/purescript-native

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

on golang help sign in

Standalone deriving, fix #1371

57f3a5cPhil Freeman11 years ago

core-tests/tests/generic-deriving/Main.purs+1−1

compare with golang

unifiedsplit

@@ -10,4 +10,4 @@ data A

10 | C (Array A)

11 | D { a :: A }

13−instance genericA :: Generic A

13+deriving instance genericA :: Generic A

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+1−4

@@ -154,7 +154,7 @@ data Declaration

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

155 -- declarations)

156 --

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

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

158 -- |

159 -- A declaration with source position information

160 --

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

376 --

377 | SuperClassDictionary (Qualified ProperName) [Type]

378 -- |

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

379 -- A value with source position information

383 --

380 --

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

381 | 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 (fmap (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 <$> traverse (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 <$> traverse (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 _ _ _ _ (Just 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 _ _ _ _ (Just 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 <$> traverse (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

@@ -213,6 +215,8 @@ errorCode em = case unwrapErrorMessage em of

213 (ConstrainedTypeUnified _ _) -> "ConstrainedTypeUnified"

215 (ConstrainedTypeUnified _ _) -> "ConstrainedTypeUnified"

214 (OverlappingInstances _ _ _) -> "OverlappingInstances"

216 (OverlappingInstances _ _ _) -> "OverlappingInstances"

215 (NoInstanceFound _ _) -> "NoInstanceFound"

217 (NoInstanceFound _ _) -> "NoInstanceFound"

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

219+ (CannotFindDerivingType _) -> "CannotFindDerivingType"

216 (DuplicateLabel _ _) -> "DuplicateLabel"

220 (DuplicateLabel _ _) -> "DuplicateLabel"

217 (DuplicateValueDeclaration _) -> "DuplicateValueDeclaration"

221 (DuplicateValueDeclaration _) -> "DuplicateValueDeclaration"

218 (ArgListLengthsDiffer _) -> "ArgListLengthsDiffer"

222 (ArgListLengthsDiffer _) -> "ArgListLengthsDiffer"

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

507 ]

511 ]

508 goSimple (NoInstanceFound nm ts) =

512 goSimple (NoInstanceFound nm ts) =

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

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

514+ goSimple (CannotDerive nm ts) =

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

516+ goSimple (CannotFindDerivingType nm) =

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

510 goSimple (DuplicateLabel l expr) =

518 goSimple (DuplicateLabel l expr) =

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

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

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

520 <> 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 (Just members)

233+

234+parseDerivingInstanceDeclaration :: TokenParser Declaration

235+parseDerivingInstanceDeclaration = do

236+ reserved "deriving"

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 Nothing

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+ , "deriving"

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 <$> traverse 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 _ _ _ _ Nothing) = 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 (Just 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+224

@@ -0,0 +1,224 @@

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 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@[TypeConstructor tyName] Nothing)

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

52+ , Qualified mn' tyCon <- tyName

53+ , mn == fromMaybe mn mn'

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

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

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+dataGeneric :: ModuleName

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

62+

63+dataMaybe :: ModuleName

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

65+

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

67+deriveGeneric mn ds tyConNm = do

68+ tyCon <- findTypeDecl tyConNm ds

69+ toSpine <- mkSpineFunction mn tyCon

70+ fromSpine <- mkFromSpineFunction mn tyCon

71+ let toSignature = mkSignatureFunction mn tyCon

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

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

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

75+ ]

76+

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

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

79+ where

80+ isTypeDecl :: Declaration -> Bool

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

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

83+ isTypeDecl _ = False

84+

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

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

87+ where

88+ prodConstructor :: Expr -> Expr

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

90+

91+ recordConstructor :: Expr -> Expr

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

93+

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

95+ mkCtorClause (ctorName, tys) = do

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

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

98+ where

99+ caseResult idents =

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

101+ . ArrayLiteral

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

103+

104+ toSpineFun :: Expr -> Type -> Expr

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

106+ lamNull . recordConstructor . ArrayLiteral .

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

108+ $ decomposeRec rec

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

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

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

112+

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

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

115+ where

116+ mkSigProd :: [Expr] -> Expr

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

118+

119+ mkSigRec :: [Expr] -> Expr

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

121+

122+ proxy :: Type -> Type

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

124+

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

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

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

128+ ]

129+

130+ mkProductSignature :: Type -> Expr

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

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

133+ , ("recValue", mkProductSignature typ)

134+ ]

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

136+ ]

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

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

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

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

141+

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

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

144+ where

145+ mkJust :: Expr -> Expr

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

147+

148+ mkNothing :: Expr

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

150+

151+ prodBinder :: [Binder] -> Binder

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

153+

154+ recordBinder :: [Binder] -> Binder

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

156+

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

158+ mkAlternative (ctorName, tys) = do

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

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

161+ . Right

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

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

164+

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

166+ addCatch = (++ [catchAll])

167+ where

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

169+

170+ fromSpineFun e r

171+ | Just rec <- objectType r

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

173+ , CaseAlternative [NullBinder] (Right mkNothing)

174+ ])

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

176+

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

178+

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

180+ ]

181+ ]

182+ . Right

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

184+

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

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

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

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

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

190+

191+-- Helpers

192+

193+objectType :: Type -> Maybe Type

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

195+objectType _ = Nothing

196+

197+lam :: String -> Expr -> Expr

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

199+

200+lamNull :: Expr -> Expr

201+lamNull = lam "$q"

202+

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

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

205+

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

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

208+

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

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

211+

212+mkVar :: String -> Expr

213+mkVar s = mkVarMn Nothing s

214+

215+mkPrelVar :: String -> Expr

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

217+

218+mkGenVar :: String -> Expr

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

220+

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

222+decomposeRec = sortBy (comparing fst) . go

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

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