e0b2655 · rowtype-yoga/purescript-native

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

on golang help sign in

Add deriving for Data.Newtype

e0b2655Gary Burgess10 years ago

examples/failing/CannotDeriveNewtypeForData.pursnew file+8

compare with golang

unifiedsplit

@@ -0,0 +1,8 @@

1+-- @shouldFailWith CannotDeriveNewtypeForData

2+module CannotDeriveNewtypeForData where

4+import Data.Newtype

6+data Test = Test String

8+derive instance newtypeTest :: Newtype Test _

examples/failing/NonWildcardNewtypeInstance.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith NonWildcardNewtypeInstance

2+module NonWildcardNewtypeInstance where

4+import Data.Newtype

6+data Test = Test String

8+derive instance newtypeTest :: Newtype Test String

examples/failing/TypeWildcards3.purs+1−2

@@ -1,4 +1,4 @@

1−-- @shouldFailWith ErrorParsingModule

1+-- @shouldFailWith InvalidInstanceHead

2module TypeWildcards where

4import Prelude

@@ -7,4 +7,3 @@ data Foo a = Foo

8instance showFoo :: Show (Foo _) where

9 show Foo = "Foo"

10−

examples/passing/DeriveNewtype.pursnew file+17

@@ -0,0 +1,17 @@

1+module Main where

3+import Control.Monad.Eff.Console (log)

5+import Data.Newtype

7+newtype Test = Test String

9+derive instance newtypeTest :: Newtype Test _

10+

11+t :: Test

12+t = wrap "hello"

13+

14+a :: String

15+a = unwrap t

16+

17+main = log "Done"

src/Language/PureScript/AST/Declarations.hs+2

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

123 | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)

124 | DeprecatedRequirePath

125 | CannotGeneralizeRecursiveFunction Ident Type

126+ | CannotDeriveNewtypeForData (ProperName 'TypeName)

127+ | NonWildcardNewtypeInstance (ProperName 'TypeName)

126 deriving (Show)

128 deriving (Show)

127

129

128-- | Error message hints, providing more detailed information about failure.

130-- | Error message hints, providing more detailed information about failure.

src/Language/PureScript/Errors.hs+10

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

166 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

167 DeprecatedRequirePath{} -> "DeprecatedRequirePath"

168 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

169+ CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

170+ NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance"

169

171

170-- |

172-- |

171-- A stack trace for an error

173-- A stack trace for an error

@@ -831,6 +833,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

831 , line "Try adding a type signature."

833 , line "Try adding a type signature."

832 ]

834 ]

833

835

836+ renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) =

837+ paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."

838+ ]

839+

840+ renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) =

841+ paras [ line $ "A type wildcard (_) should be used for the inner type when deriving the " ++ markCode "Newtype" ++ " instance for " ++ markCode (runProperName tyName) ++ "."

842+ ]

843+

834 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

844 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

835 renderHint (ErrorUnifyingTypes t1 t2) detail =

845 renderHint (ErrorUnifyingTypes t1 t2) detail =

836 paras [ detail

846 paras [ detail

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

@@ -209,7 +209,7 @@ parseInstanceDeclaration = do

209 rfatArrow

210 return deps

211 className <- indented *> parseQualified properName

212− ty <- P.many (indented *> noWildcards parseTypeAtom)

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

213 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty

214

215parseTypeInstanceDeclaration :: TokenParser Declaration

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+62−4

@@ -22,6 +22,7 @@ import Language.PureScript.Environment

22import Language.PureScript.Errors

23import Language.PureScript.Names

24import Language.PureScript.Types

25+import Language.PureScript.TypeChecker (checkNewtype)

25import qualified Language.PureScript.Constants as C

26import qualified Language.PureScript.Constants as C

27-- | Elaborates deriving instance declarations by code generation.

28-- | Elaborates deriving instance declarations by code generation.

@@ -44,14 +45,21 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived

44 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

45 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

45 , mn == fromMaybe mn mn'

46 , mn == fromMaybe mn mn'

46 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args

47 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args

47− | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Eq" ])) (ProperName "Eq")

48+ | className == Qualified (Just dataEq) (ProperName "Eq")

48 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

49 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

49 , mn == fromMaybe mn mn'

50 , mn == fromMaybe mn mn'

50 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon

51 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon

51− | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Ord" ])) (ProperName "Ord")

52+ | className == Qualified (Just dataOrd) (ProperName "Ord")

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

53 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

53 , mn == fromMaybe mn mn'

54 , mn == fromMaybe mn mn'

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

55 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon

56+deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)

57+ | className == Qualified (Just dataNewtype) (ProperName "Newtype")

58+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor wrappedTy

59+ , mn == fromMaybe mn mn'

60+ = do

61+ (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon unwrappedTy

62+ return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)

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

63deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

56 = throwError . errorMessage $ CannotDerive className tys

64 = throwError . errorMessage $ CannotDerive className tys

57deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)

65deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)

@@ -100,6 +108,15 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

100typesProxy :: ModuleName

108typesProxy :: ModuleName

101typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

109typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]

102

110

111+dataEq :: ModuleName

112+dataEq = ModuleName [ ProperName "Data", ProperName "Eq" ]

113+

114+dataOrd :: ModuleName

115+dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ]

116+

117+dataNewtype :: ModuleName

118+dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ]

119+

103deriveGeneric

120deriveGeneric

104 :: forall m. (MonadError MultipleErrors m, MonadSupply m)

121 :: forall m. (MonadError MultipleErrors m, MonadSupply m)

105 => ModuleName

122 => ModuleName

@@ -290,7 +307,7 @@ deriveEq mn ds tyConNm = do

290 preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj)))

307 preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj)))

291

308

292 preludeEq :: Expr -> Expr -> Expr

309 preludeEq :: Expr -> Expr -> Expr

293− preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Eq"])) (Ident C.eq)))

310+ preludeEq = App . App (Var (Qualified (Just dataEq) (Ident C.eq)))

294

311

295 addCatch :: [CaseAlternative] -> [CaseAlternative]

312 addCatch :: [CaseAlternative] -> [CaseAlternative]

296 addCatch xs

313 addCatch xs

@@ -360,7 +377,7 @@ deriveOrd mn ds tyConNm = do

360 orderingBinder name = ConstructorBinder (orderingName name) []

377 orderingBinder name = ConstructorBinder (orderingName name) []

361

378

362 ordCompare :: Expr -> Expr -> Expr

379 ordCompare :: Expr -> Expr -> Expr

363− ordCompare = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Ord"])) (Ident C.compare)))

380+ ordCompare = App . App (Var (Qualified (Just dataOrd) (Ident C.compare)))

364

381

365 mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]

382 mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]

366 mkCtorClauses ((ctorName, tys), isLast) = do

383 mkCtorClauses ((ctorName, tys), isLast) = do

@@ -404,6 +421,47 @@ deriveOrd mn ds tyConNm = do

404 $ decomposeRec rec

421 $ decomposeRec rec

405 toOrdering l r _ = ordCompare l r

422 toOrdering l r _ = ordCompare l r

406

423

424+deriveNewtype

425+ :: forall m

426+ . (MonadError MultipleErrors m, MonadSupply m)

427+ => ModuleName

428+ -> [Declaration]

429+ -> ProperName 'TypeName

430+ -> Type

431+ -> m ([Declaration], Type)

432+deriveNewtype mn ds tyConNm unwrappedTy = do

433+ checkIsWildcard unwrappedTy

434+ go =<< findTypeDecl tyConNm ds

435+ where

436+

437+ go :: Declaration -> m ([Declaration], Type)

438+ go (DataDeclaration Data name _ _) =

439+ throwError . errorMessage $ CannotDeriveNewtypeForData name

440+ go (DataDeclaration Newtype name _ dctors) = do

441+ checkNewtype name dctors

442+ let (ctorName, [ty]) = head dctors

443+ wrappedIdent <- freshIdent "n"

444+ unwrappedIdent <- freshIdent "a"

445+ let inst =

446+ [ ValueDeclaration (Ident "wrap") Public [] $ Right $

447+ Constructor (Qualified (Just mn) ctorName)

448+ , ValueDeclaration (Ident "unwrap") Public [] $ Right $

449+ lamCase wrappedIdent

450+ [ CaseAlternative

451+ [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]]

452+ (Right (Var (Qualified Nothing unwrappedIdent)))

453+ ]

454+ ]

455+ return (inst, ty)

456+ go (PositionedDeclaration _ _ d) = go d

457+ go _ = internalError "deriveNewtype go: expected DataDeclaration"

458+

459+ checkIsWildcard :: Type -> m ()

460+ checkIsWildcard (TypeWildcard _) =

461+ return ()

462+ checkIsWildcard _ =

463+ throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm

464+

407findTypeDecl

465findTypeDecl

408 :: (MonadError MultipleErrors m)

466 :: (MonadError MultipleErrors m)

409 => ProperName 'TypeName

467 => ProperName 'TypeName

src/Language/PureScript/TypeChecker.hs+10−4

@@ -6,6 +6,7 @@

6module Language.PureScript.TypeChecker

7 ( module T

8 , typeCheckModule

9+ , checkNewtype

9 ) where

10 ) where

11import Prelude.Compat

12import Prelude.Compat

@@ -318,10 +319,6 @@ typeCheckAll moduleName _ = traverse go

318 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"

319 checkType _ = internalError "Invalid type in instance in checkOrphanInstance"

319 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"

320 checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"

320

321

321− checkNewtype :: ProperName 'TypeName -> [(ProperName 'ConstructorName, [Type])] -> m ()

322− checkNewtype _ [(_, [_])] = return ()

323− checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name

324−

325 -- |

322 -- |

326 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

323 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

327 -- extracted from the kind of the type constructor itself.

324 -- extracted from the kind of the type constructor itself.

@@ -332,6 +329,15 @@ typeCheckAll moduleName _ = traverse go

332 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

329 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

333 withKinds _ _ = internalError "Invalid arguments to peelKinds"

330 withKinds _ _ = internalError "Invalid arguments to peelKinds"

334

331

332+checkNewtype

333+ :: forall m

334+ . MonadError MultipleErrors m

335+ => ProperName 'TypeName

336+ -> [(ProperName 'ConstructorName, [Type])]

337+ -> m ()

338+checkNewtype _ [(_, [_])] = return ()

339+checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name

340+

335-- |

341-- |

336-- Type check an entire module and ensure all types and classes defined within the module that are

342-- Type check an entire module and ensure all types and classes defined within the module that are

337-- required by exported members are also exported.

343-- required by exported members are also exported.

tests/TestUtils.hs+2

@@ -75,6 +75,8 @@ supportModules =

75 , "Data.Function"

76 , "Data.Functor"

77 , "Data.HeytingAlgebra"

78+ , "Data.NaturalTransformation"

79+ , "Data.Newtype"

78 , "Data.Ord.Unsafe"

80 , "Data.Ord.Unsafe"

79 , "Data.Ord"

81 , "Data.Ord"

80 , "Data.Ordering"

82 , "Data.Ordering"

tests/support/bower.json+3−2

@@ -5,8 +5,9 @@

5 "purescript-console": "1.0.0-rc.1",

6 "purescript-eff": "1.0.0-rc.1",

7 "purescript-functions": "1.0.0-rc.1",

8− "purescript-prelude": "1.0.0-rc.3",

8+ "purescript-prelude": "1.1.0",

9 "purescript-st": "1.0.0-rc.1",

10− "purescript-partial": "1.1.2"

10+ "purescript-partial": "1.1.2",

11+ "purescript-newtype": "0.1.0"

11 }

12 }

12}

13}