@@ -1,4 +1,5 @@
11{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE PatternGuards #-}
23
34-- |
45-- This module implements the generic deriving elaboration that takes place during desugaring.
@@ -93,12 +94,31 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do
9394 tyCon <- findTypeDecl tyConNm ds
9495 go tyCon
9596 where
96− go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do
97− let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
98− return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped]))
97+ go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])])
98+ -- The newtype might not be applied to all type arguments.
99+ -- This is okay as long as the newtype wraps something which ends with
100+ -- sufficiently many type applications to variables.
101+ -- For example, we can derive Functor for
102+ --
103+ -- newtype MyArray a = MyArray (Array a)
104+ --
105+ -- since Array a is a type application which uses the last
106+ -- type argument
107+ | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped =
108+ do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
109+ return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped']))
99110 go (PositionedDeclaration _ _ d) = go d
100111 go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
101112
113+ takeReverse :: Int -> [a] -> [a]
114+ takeReverse n = take n . reverse
115+
116+ stripRight :: [(String, Maybe kind)] -> Type -> Maybe Type
117+ stripRight [] ty = Just ty
118+ stripRight ((arg, _) : args) (TypeApp t (TypeVar arg'))
119+ | arg == arg' = stripRight args t
120+ stripRight _ _ = Nothing
121+
102122dataGeneric :: ModuleName
103123dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
104124