purescript · paf31 · Sep 16, 2016 · Sep 11, 2016 · Sep 12, 2016 · Sep 15, 2016
diff --git a/examples/failing/NewtypeInstance.purs b/examples/failing/NewtypeInstance.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+data X = X
+
+derive newtype instance showX :: Show X
diff --git a/examples/failing/NewtypeInstance2.purs b/examples/failing/NewtypeInstance2.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+data X a = X a a
+
+derive newtype instance showX :: Show a => Show (X a)
diff --git a/examples/failing/NewtypeInstance3.purs b/examples/failing/NewtypeInstance3.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+class Nullary
+
+derive newtype instance nullary :: Nullary
diff --git a/examples/failing/NewtypeInstance4.purs b/examples/failing/NewtypeInstance4.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith InvalidNewtypeInstance
+module Main where
+
+import Prelude
+
+data X = X | Y
+
+derive newtype instance showX :: Show X
diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs
@@ -0,0 +1,30 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff
+import Control.Monad.Eff.Console
+
+newtype X = X String
+
+derive newtype instance showX :: Show X
+
+derive newtype instance eqX :: Eq X
+
+derive newtype instance ordX :: Ord X
+
+newtype Y a = Y (Array a)
+
+derive newtype instance showY :: Show (Y String)
+
+class Singleton a b where
+  singleton :: a -> b
+
+instance singletonArray :: Singleton a (Array a) where
+  singleton x = [x]
+
+derive newtype instance singletonY :: Singleton a (Y a)
+
+main = do
+  logShow (X "test")
+  logShow (singleton "test" :: Y String)
+  log "Done"
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -77,6 +77,7 @@ data SimpleErrorMessage
   | NoInstanceFound Constraint
   | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
   | CannotDerive (Qualified (ProperName 'ClassName)) [Type]
+  | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
   | CannotFindDerivingType (ProperName 'TypeName)
   | DuplicateLabel String (Maybe Expr)
   | DuplicateValueDeclaration Ident
@@ -374,19 +375,24 @@ pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFix
 
 -- | The members of a type class instance declaration
 data TypeInstanceBody
-  -- | This is a derived instance
   = DerivedInstance
-  -- | This is a regular (explicit) instance
+  -- ^ This is a derived instance
+  | NewtypeInstance
+  -- ^ This is an instance derived from a newtype
+  | NewtypeInstanceWithDictionary Expr
+  -- ^ This is an instance derived from a newtype, desugared to include a
+  -- dictionary for the type under the newtype.
   | ExplicitInstance [Declaration]
+  -- ^ This is a regular (explicit) instance
   deriving (Show)
 
 mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
 mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
 
 -- | A traversal for TypeInstanceBody
 traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
-traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance
 traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds
+traverseTypeInstanceBody _ other = pure other
 
 -- |
 -- Test if a declaration is a value declaration
@@ -570,7 +576,7 @@ data Expr
   -- |
   -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
   --
-  | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]
+  | DeferredDictionary (Qualified (ProperName 'ClassName)) [Type]
   -- |
   -- A placeholder for an anonymous function argument
   --

diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
@@ -583,6 +583,6 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
   forDecls _ = mempty
 
   forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c))
-  forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
+  forValues (DeferredDictionary _ tys) = mconcat (map f tys)
   forValues (TypedValue _ _ ty) = f ty
   forValues _ = mempty
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -120,6 +120,7 @@ errorCode em = case unwrapErrorMessage em of
   NoInstanceFound{} -> "NoInstanceFound"
   PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"
   CannotDerive{} -> "CannotDerive"
+  InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"
   CannotFindDerivingType{} -> "CannotFindDerivingType"
   DuplicateLabel{} -> "DuplicateLabel"
   DuplicateValueDeclaration{} -> "DuplicateValueDeclaration"
@@ -262,6 +263,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
   gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
   gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
   gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
+  gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts
   gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
   gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
   gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
@@ -642,6 +644,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
                 , Box.vcat Box.left (map typeAtomAsBox ts)
                 ]
             ]
+    renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) =
+      paras [ line "Cannot derive newtype instance for"
+            , markCodeBox $ indent $ Box.hsep 1 Box.left
+                [ line (showQualified runProperName nm)
+                , Box.vcat Box.left (map typeAtomAsBox ts)
+                ]
+            , line "Make sure this is a newtype."
+            ]
     renderSimpleErrorMessage (CannotFindDerivingType nm) =
       line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."
     renderSimpleErrorMessage (DuplicateLabel l expr) =

diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
@@ -17,6 +17,7 @@ module Language.PureScript.Parser.Declarations
 
 import Prelude hiding (lex)
 
+import Data.Functor (($>))
 import Data.Maybe (fromMaybe)
 
 import Control.Applicative
@@ -192,6 +193,7 @@ parseConstraint :: TokenParser Constraint
 parseConstraint = Constraint <$> parseQualified properName
                              <*> P.many (noWildcards parseTypeAtom)
                              <*> pure Nothing
+
 parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
 parseInstanceDeclaration = do
   reserved "instance"
@@ -216,8 +218,9 @@ parseTypeInstanceDeclaration = do
 parseDerivingInstanceDeclaration :: TokenParser Declaration
 parseDerivingInstanceDeclaration = do
   reserved "derive"
+  ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance)
   instanceDecl <- parseInstanceDeclaration
-  return $ instanceDecl DerivedInstance
+  return $ instanceDecl ty
 
 positioned :: TokenParser Declaration -> TokenParser Declaration
 positioned = withSourceSpan PositionedDeclaration

diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
@@ -61,7 +61,7 @@ prettyPrintValue d (Let ds val) =
 prettyPrintValue d (Do els) =
   text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
 prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
-prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
+prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
 prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =
     text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"
 prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
@@ -332,9 +332,9 @@ updateTypes goType = (goDecl, goExpr, goBinder)
   goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do
     tys' <- traverse (goType' pos) tys
     return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints)
-  goExpr pos (SuperClassDictionary cls tys) = do
+  goExpr pos (DeferredDictionary cls tys) = do
     tys' <- traverse (goType' pos) tys
-    return (pos, SuperClassDictionary cls tys')
+    return (pos, DeferredDictionary cls tys')
   goExpr pos (TypedValue check v ty) = do
     ty' <- goType' pos ty
     return (pos, TypedValue check v ty')

diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -129,7 +129,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des
 --
 --   subString :: {} -> Sub String
 --   subString _ = { sub: "",
---                 , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>
+--                 , "__superclass_Foo_0": \_ -> <DeferredDictionary Foo String>
 --                 }
 --
 -- and finally as the generated javascript:
@@ -181,6 +181,10 @@ desugarDecl mn exps = go
     desugared <- desugarCases members
     dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
     return (expRef name className tys, [d, dictDecl])
+  go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do
+    let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys
+        constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
+    return (expRef name className tys, [d, ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))])
   go (PositionedDeclaration pos com d) = do
     (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
     return (dr, map (PositionedDeclaration pos com) ds)
@@ -287,7 +291,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
       -- The type is a record type, but depending on type instance dependencies, may be constrained.
       -- The dictionary itself is a record literal.
       let superclasses = superClassDictionaryNames implies `zip`
-            [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)
+            [ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs)
             | (Constraint superclass suTyArgs _) <- implies
             , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
             ]

diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -54,6 +54,12 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
   = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
 deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
   = throwError . errorMessage $ CannotDerive className tys
+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
+  | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys)
+  , mn == fromMaybe mn mn'
+  = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args
+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)
+  = throwError . errorMessage $ InvalidNewtypeInstance className tys
 deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
 deriveInstance _  _  e = return e
 
@@ -66,6 +72,25 @@ unwrapTypeConstructor = fmap (second reverse) . go
     return (tyCon, arg : args)
   go _ = Nothing
 
+deriveNewtypeInstance
+  :: forall m
+   . MonadError MultipleErrors m
+  => Qualified (ProperName 'ClassName)
+  -> [Declaration]
+  -> [Type]
+  -> ProperName 'TypeName
+  -> [Type]
+  -> m Expr
+deriveNewtypeInstance className ds tys tyConNm dargs = do
+    tyCon <- findTypeDecl tyConNm ds
+    go tyCon
+  where
+    go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do
+      let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
+      return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped]))
+    go (PositionedDeclaration _ _ d) = go d
+    go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
+
 dataGeneric :: ModuleName
 dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
 

diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -61,7 +61,7 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)
 
 -- |
 -- This function has one purpose - to skolemize type variables appearing in a
--- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
+-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the
 -- only example of scoped type variables.
 --
 skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr
@@ -71,8 +71,8 @@ skolemizeTypesInValue ident sko scope ss =
   in runIdentity . f
   where
   onExpr :: [String] -> Expr -> Identity ([String], Expr)
-  onExpr sco (SuperClassDictionary c ts)
-    | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts))
+  onExpr sco (DeferredDictionary c ts)
+    | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))
   onExpr sco (TypedValue check val ty)
     | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))
   onExpr sco other = return (sco, other)

diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -311,7 +311,7 @@ infer' (IfThenElse cond th el) = do
 infer' (Let ds val) = do
   (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
   return $ TypedValue True (Let ds' val') valTy
-infer' (SuperClassDictionary className tys) = do
+infer' (DeferredDictionary className tys) = do
   dicts <- getTypeClassDictionaries
   hints <- gets checkHints
   return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
@@ -583,7 +583,7 @@ check' v@(Var var) ty = do
   case v' of
     Nothing -> internalError "check: unable to check the subsumes relation."
     Just v'' -> return $ TypedValue True v'' ty'
-check' (SuperClassDictionary className tys) _ = do
+check' (DeferredDictionary className tys) _ = do
   {-
   -- Here, we replace a placeholder for a superclass dictionary with a regular
   -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the