e0b2655 · rowtype-yoga/purescript-native

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

Add deriving for Data.Newtype

commite0b26554ce579c07d72b008683ca0a0c36c0165b authorGary Burgess <gary.burgess@gmail.com> dateFri 23 Sep 2016, 19:26 (10 years ago) parenta84f7f3

11 files changed+124−13

compare with golang

unifiedsplit

examples/failing/CannotDeriveNewtypeForData.purs+8 examples/failing/NonWildcardNewtypeInstance.purs+8 examples/failing/TypeWildcards3.purs+1−2 examples/passing/DeriveNewtype.purs+17 src/Language/PureScript/AST/Declarations.hs+2 src/Language/PureScript/Errors.hs+10 src/Language/PureScript/Parser/Declarations.hs+1−1 src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+62−4 src/Language/PureScript/TypeChecker.hs+10−4 tests/TestUtils.hs+2 tests/support/bower.json+3−2

examples/failing/CannotDeriveNewtypeForData.pursnew file+8

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

22module TypeWildcards where

44import Prelude

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

88instance showFoo :: Show (Foo _) where

99 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

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

124124 | DeprecatedRequirePath

125125 | CannotGeneralizeRecursiveFunction Ident Type

126+ | CannotDeriveNewtypeForData (ProperName 'TypeName)

127+ | NonWildcardNewtypeInstance (ProperName 'TypeName)

126128 deriving (Show)

127129

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

166166 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

167167 DeprecatedRequirePath{} -> "DeprecatedRequirePath"

168168 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

169+ CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

170+ NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance"

169171

170172-- |

171173-- A stack trace for an error

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

831833 , line "Try adding a type signature."

832834 ]

833835

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+

834844 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

835845 renderHint (ErrorUnifyingTypes t1 t2) detail =

836846 paras [ detail

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

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

209209 rfatArrow

210210 return deps

211211 className <- indented *> parseQualified properName

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

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

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

214214

215215parseTypeInstanceDeclaration :: TokenParser Declaration

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

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

2222import Language.PureScript.Errors

2323import Language.PureScript.Names

2424import Language.PureScript.Types

25+import Language.PureScript.TypeChecker (checkNewtype)

2526import qualified Language.PureScript.Constants as C

2627

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

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

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

4546 , mn == fromMaybe mn mn'

4647 = 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")

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

4950 , mn == fromMaybe mn mn'

5051 = 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")

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

5354 , mn == fromMaybe mn mn'

5455 = 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)

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

5664 = throwError . errorMessage $ CannotDerive className tys

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

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

100108typesProxy :: ModuleName

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

102110

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+

103120deriveGeneric

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

105122 => ModuleName

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

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

291308

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

294311

295312 addCatch :: [CaseAlternative] -> [CaseAlternative]

296313 addCatch xs

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

360377 orderingBinder name = ConstructorBinder (orderingName name) []

361378

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

364381

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

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

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

404421 $ decomposeRec rec

405422 toOrdering l r _ = ordCompare l r

406423

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+

407465findTypeDecl

408466 :: (MonadError MultipleErrors m)

409467 => ProperName 'TypeName

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

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

66module Language.PureScript.TypeChecker

77 ( module T

88 , typeCheckModule

9+ , checkNewtype

910 ) where

1011

1112import Prelude.Compat

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

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

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

320321

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

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

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

324−

325322 -- |

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

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

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

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

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

334331

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+

335341-- |

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

337343-- required by exported members are also exported.

tests/TestUtils.hs+2

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

7575 , "Data.Function"

7676 , "Data.Functor"

7777 , "Data.HeytingAlgebra"

78+ , "Data.NaturalTransformation"

79+ , "Data.Newtype"

7880 , "Data.Ord.Unsafe"

7981 , "Data.Ord"

8082 , "Data.Ordering"

tests/support/bower.json+3−2

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

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

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

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

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

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

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

1112 }

1213}