@@ -13,7 +13,7 @@ import Control.Monad (replicateM)
1313import Control.Monad.Error.Class (MonadError(..))
1414import Control.Monad.Supply.Class (MonadSupply)
1515
16−import Data.List (foldl', find, sortBy)
16+import Data.List (foldl', find, sortBy, unzip5)
1717import Data.Maybe (fromMaybe)
1818import Data.Ord (comparing)
1919
@@ -58,9 +58,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwr
5858 | className == Qualified (Just dataNewtype) (ProperName "Newtype")
5959 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
6060 , mn == fromMaybe mn mn'
61− = do
62− (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
63− return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
61+ = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
62+ return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
63+deriveInstance mn ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance)
64+ | className == Qualified (Just dataGenericRep) (ProperName C.generic)
65+ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy
66+ , mn == fromMaybe mn mn'
67+ = do (inst, inferredRepTy) <- deriveGenericRep mn ds tyCon args repTy
68+ return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst)
6469deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
6570 = throwError . errorMessage $ CannotDerive className tys
6671deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
@@ -122,6 +127,9 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do
122127dataGeneric :: ModuleName
123128dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
124129
130+dataGenericRep :: ModuleName
131+dataGenericRep = ModuleName [ ProperName "Data", ProperName "Generic", ProperName "Rep" ]
132+
125133dataMaybe :: ModuleName
126134dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
127135
@@ -304,6 +312,187 @@ deriveGeneric mn ds tyConNm dargs = do
304312 mkGenVar :: Ident -> Expr
305313 mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
306314
315+deriveGenericRep
316+ :: forall m
317+ . (MonadError MultipleErrors m, MonadSupply m)
318+ => ModuleName
319+ -> [Declaration]
320+ -> ProperName 'TypeName
321+ -> [Type]
322+ -> Type
323+ -> m ([Declaration], Type)
324+deriveGenericRep mn ds tyConNm tyConArgs repTy = do
325+ checkIsWildcard tyConNm repTy
326+ go =<< findTypeDecl tyConNm ds
327+ where
328+ go :: Declaration -> m ([Declaration], Type)
329+ go (DataDeclaration _ _ args dctors) = do
330+ x <- freshIdent "x"
331+ (reps, to, from) <- unzip3 <$> traverse makeInst dctors
332+ let rep = toRepTy reps
333+ inst | null reps =
334+ -- If there are no cases, spin
335+ [ ValueDeclaration (Ident "to") Public [] $ Right $
336+ lamCase x [ CaseAlternative [NullBinder]
337+ (Right (App toName (Var (Qualified Nothing x))))
338+ ]
339+ , ValueDeclaration (Ident "from") Public [] $ Right $
340+ lamCase x [ CaseAlternative [NullBinder]
341+ (Right (App fromName (Var (Qualified Nothing x))))
342+ ]
343+ ]
344+ | otherwise =
345+ [ ValueDeclaration (Ident "to") Public [] $ Right $
346+ lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to)
347+ , ValueDeclaration (Ident "from") Public [] $ Right $
348+ lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from)
349+ ]
350+
351+ subst = zipWith ((,) . fst) args tyConArgs
352+ return (inst, replaceAllTypeVars subst rep)
353+ go (PositionedDeclaration _ _ d) = go d
354+ go _ = internalError "deriveGenericRep go: expected DataDeclaration"
355+
356+ select :: (a -> a) -> (a -> a) -> Int -> [a -> a]
357+ select _ _ 0 = []
358+ select _ _ 1 = [id]
359+ select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r]
360+
361+ sumBinders :: Int -> [Binder -> Binder]
362+ sumBinders = select (ConstructorBinder inl . pure) (ConstructorBinder inr . pure)
363+
364+ sumExprs :: Int -> [Expr -> Expr]
365+ sumExprs = select (App (Constructor inl)) (App (Constructor inr))
366+
367+ compN :: Int -> (a -> a) -> a -> a
368+ compN 0 _ = id
369+ compN n f = f . compN (n - 1) f
370+
371+ makeInst
372+ :: (ProperName 'ConstructorName, [Type])
373+ -> m (Type, CaseAlternative, CaseAlternative)
374+ makeInst (ctorName, args) = do
375+ (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args
376+ return ( TypeApp (TypeApp (TypeConstructor constructor)
377+ (TypeLevelString (runProperName ctorName)))
378+ ctorTy
379+ , CaseAlternative [ ConstructorBinder constructor [matchProduct] ]
380+ (Right (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs))
381+ , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) matchCtor ]
382+ (Right (constructor' mkProduct))
383+ )
384+
385+ makeProduct
386+ :: [Type]
387+ -> m (Type, Binder, [Expr], [Binder], Expr)
388+ makeProduct [] =
389+ pure (noArgs, NullBinder, [], [], noArgs')
390+ makeProduct args = do
391+ (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args
392+ pure ( foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) tys
393+ , foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) bs1
394+ , es1
395+ , bs2
396+ , foldr1 (\e1 -> App (App (Constructor productName) e1)) es2
397+ )
398+
399+ makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr)
400+ makeArg arg | Just rec <- objectType arg = do
401+ let fields = decomposeRec rec
402+ fieldNames <- traverse freshIdent (map fst fields)
403+ pure ( TypeApp (TypeConstructor record)
404+ (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f))
405+ (map (\(name, ty) ->
406+ TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields))
407+ , ConstructorBinder record
408+ [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2])
409+ (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames)
410+ ]
411+ , Literal . ObjectLiteral $
412+ zipWith (\(name, _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames
413+ , LiteralBinder . ObjectLiteral $
414+ zipWith (\(name, _) ident -> (name, VarBinder ident)) fields fieldNames
415+ , record' $
416+ foldr1 (\e1 -> App (App (Constructor productName) e1))
417+ (map (field' . Var . Qualified Nothing) fieldNames)
418+ )
419+ makeArg arg = do
420+ argName <- freshIdent "arg"
421+ pure ( TypeApp (TypeConstructor argument) arg
422+ , ConstructorBinder argument [ VarBinder argName ]
423+ , Var (Qualified Nothing argName)
424+ , VarBinder argName
425+ , argument' (Var (Qualified Nothing argName))
426+ )
427+
428+ underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative
429+ underBinder f (CaseAlternative bs e) = CaseAlternative (map f bs) e
430+
431+ underExpr :: (Expr -> Expr) -> CaseAlternative -> CaseAlternative
432+ underExpr f (CaseAlternative b (Right e)) = CaseAlternative b (Right (f e))
433+ underExpr _ _ = internalError "underExpr: expected Right"
434+
435+ toRepTy :: [Type] -> Type
436+ toRepTy [] = noCtors
437+ toRepTy [only] = only
438+ toRepTy ctors = foldr1 (\f -> TypeApp (TypeApp sumCtor f)) ctors
439+
440+ toName :: Expr
441+ toName = Var (Qualified (Just dataGenericRep) (Ident "to"))
442+
443+ fromName :: Expr
444+ fromName = Var (Qualified (Just dataGenericRep) (Ident "from"))
445+
446+ noCtors :: Type
447+ noCtors = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors"))
448+
449+ noArgs :: Type
450+ noArgs = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments"))
451+
452+ noArgs' :: Expr
453+ noArgs' = Constructor (Qualified (Just dataGenericRep) (ProperName "NoArguments"))
454+
455+ sumCtor :: Type
456+ sumCtor = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum"))
457+
458+ inl :: Qualified (ProperName 'ConstructorName)
459+ inl = Qualified (Just dataGenericRep) (ProperName "Inl")
460+
461+ inr :: Qualified (ProperName 'ConstructorName)
462+ inr = Qualified (Just dataGenericRep) (ProperName "Inr")
463+
464+ productName :: Qualified (ProperName ty)
465+ productName = Qualified (Just dataGenericRep) (ProperName "Product")
466+
467+ constructor :: Qualified (ProperName ty)
468+ constructor = Qualified (Just dataGenericRep) (ProperName "Constructor")
469+
470+ constructor' :: Expr -> Expr
471+ constructor' = App (Constructor constructor)
472+
473+ argument :: Qualified (ProperName ty)
474+ argument = Qualified (Just dataGenericRep) (ProperName "Argument")
475+
476+ argument' :: Expr -> Expr
477+ argument' = App (Constructor argument)
478+
479+ record :: Qualified (ProperName ty)
480+ record = Qualified (Just dataGenericRep) (ProperName "Rec")
481+
482+ record' :: Expr -> Expr
483+ record' = App (Constructor record)
484+
485+ field :: Qualified (ProperName ty)
486+ field = Qualified (Just dataGenericRep) (ProperName "Field")
487+
488+ field' :: Expr -> Expr
489+ field' = App (Constructor field)
490+
491+checkIsWildcard :: MonadError MultipleErrors m => ProperName 'TypeName -> Type -> m ()
492+checkIsWildcard _ (TypeWildcard _) = return ()
493+checkIsWildcard tyConNm _ =
494+ throwError . errorMessage $ ExpectedWildcard tyConNm
495+
307496deriveEq ::
308497 forall m. (MonadError MultipleErrors m, MonadSupply m)
309498 => ModuleName
@@ -451,7 +640,7 @@ deriveNewtype
451640 -> Type
452641 -> m ([Declaration], Type)
453642deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
454− checkIsWildcard unwrappedTy
643+ checkIsWildcard tyConNm unwrappedTy
455644 go =<< findTypeDecl tyConNm ds
456645 where
457646 go :: Declaration -> m ([Declaration], Type)
@@ -477,12 +666,6 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
477666 go (PositionedDeclaration _ _ d) = go d
478667 go _ = internalError "deriveNewtype go: expected DataDeclaration"
479668
480− checkIsWildcard :: Type -> m ()
481− checkIsWildcard (TypeWildcard _) =
482− return ()
483− checkIsWildcard _ =
484− throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
485−
486669findTypeDecl
487670 :: (MonadError MultipleErrors m)
488671 => ProperName 'TypeName