{-# LANGUAGE CPP #-}
module Data.Constraint.Deriving
( plugin
, DeriveAll (..)
, DeriveContext
, ToInstance (..)
, OverlapMode (..)
, ClassDict (..)
) where
import Data.List (sortOn)
import Data.Constraint.Deriving.ClassDict
import Data.Constraint.Deriving.DeriveAll
import Data.Constraint.Deriving.Import
import Data.Constraint.Deriving.ToInstance
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin
{ installCoreToDos :: CorePlugin
installCoreToDos = CorePlugin
install
#if __GLASGOW_HASKELL__ >= 860
, pluginRecompile = purePlugin
#endif
}
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: CorePlugin
install [CommandLineOption]
cmdopts [CoreToDo]
todo = do
IORef CorePluginEnv
eref <- CoreM (IORef CorePluginEnv)
initCorePluginEnv
[CoreToDo] -> CoreM [CoreToDo]
forall (m :: * -> *) a. Monad m => a -> m a
return ( IORef CorePluginEnv -> CoreToDo
deriveAllPass IORef CorePluginEnv
eref
CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: IORef CorePluginEnv -> CoreToDo
classDictPass IORef CorePluginEnv
eref
CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: IORef CorePluginEnv -> CoreToDo
toInstancePass IORef CorePluginEnv
eref
CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: if CommandLineOption
"dump-instances" CommandLineOption -> [CommandLineOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CommandLineOption]
cmdopts
then CoreToDo
dumpInstancesCoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
:[CoreToDo]
todo
else [CoreToDo]
todo
)
dumpInstances :: CoreToDo
dumpInstances :: CoreToDo
dumpInstances = CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass CommandLineOption
"Data.Constraint.Deriving.DumpInstances"
(CorePluginPass -> CoreToDo) -> CorePluginPass -> CoreToDo
forall a b. (a -> b) -> a -> b
$ \ModGuts
guts -> ModGuts
guts ModGuts -> CoreM () -> CoreM ModGuts
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [ClsInst] -> CoreM ()
go (ModGuts -> [ClsInst]
mg_insts ModGuts
guts)
where
locdoc :: ClsInst -> ((CommandLineOption, [Maybe CommandLineOption]), SDoc)
locdoc ClsInst
i = ( ( Class -> CommandLineOption
forall a. NamedThing a => a -> CommandLineOption
getOccString (Class -> CommandLineOption) -> Class -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ ClsInst -> Class
is_cls ClsInst
i
, (Type -> Maybe CommandLineOption)
-> [Type] -> [Maybe CommandLineOption]
forall a b. (a -> b) -> [a] -> [b]
map ((TyCon -> CommandLineOption)
-> Maybe TyCon -> Maybe CommandLineOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCon -> CommandLineOption
forall a. NamedThing a => a -> CommandLineOption
getOccString (Maybe TyCon -> Maybe CommandLineOption)
-> (Type -> Maybe TyCon) -> Type -> Maybe CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe TyCon
tyConAppTyCon_maybe)
([Type] -> [Maybe CommandLineOption])
-> [Type] -> [Maybe CommandLineOption]
forall a b. (a -> b) -> a -> b
$ ClsInst -> [Type]
is_tys ClsInst
i
), ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
i)
go :: [ClsInst] -> CoreM ()
go [ClsInst]
is = do
let is' :: [((CommandLineOption, [Maybe CommandLineOption]), SDoc)]
is' = (((CommandLineOption, [Maybe CommandLineOption]), SDoc)
-> (CommandLineOption, [Maybe CommandLineOption]))
-> [((CommandLineOption, [Maybe CommandLineOption]), SDoc)]
-> [((CommandLineOption, [Maybe CommandLineOption]), SDoc)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((CommandLineOption, [Maybe CommandLineOption]), SDoc)
-> (CommandLineOption, [Maybe CommandLineOption])
forall a b. (a, b) -> a
fst ([((CommandLineOption, [Maybe CommandLineOption]), SDoc)]
-> [((CommandLineOption, [Maybe CommandLineOption]), SDoc)])
-> [((CommandLineOption, [Maybe CommandLineOption]), SDoc)]
-> [((CommandLineOption, [Maybe CommandLineOption]), SDoc)]
forall a b. (a -> b) -> a -> b
$ (ClsInst -> ((CommandLineOption, [Maybe CommandLineOption]), SDoc))
-> [ClsInst]
-> [((CommandLineOption, [Maybe CommandLineOption]), SDoc)]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> ((CommandLineOption, [Maybe CommandLineOption]), SDoc)
locdoc [ClsInst]
is
SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$
SDoc
blankLine
SDoc -> SDoc -> SDoc
$+$
SDoc -> Int -> SDoc -> SDoc
hang
(CommandLineOption -> SDoc
text CommandLineOption
"============ Class instances declared in this module ============")
Int
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (((CommandLineOption, [Maybe CommandLineOption]), SDoc) -> SDoc)
-> [((CommandLineOption, [Maybe CommandLineOption]), SDoc)]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((CommandLineOption, [Maybe CommandLineOption]), SDoc) -> SDoc
forall a b. (a, b) -> b
snd [((CommandLineOption, [Maybe CommandLineOption]), SDoc)]
is')
SDoc -> SDoc -> SDoc
$+$
SDoc
blankLine