{-# LANGUAGE CPP #-}
module Data.Constraint.Deriving
  ( plugin
    -- * DeriveAll pass
  , DeriveAll (..)
  , DeriveContext
    -- * ToInstance pass
  , ToInstance (..)
  , OverlapMode (..)
    -- * ClassDict pass
  , 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


-- | To use the plugin, add
--
-- @
-- {\-\# OPTIONS_GHC -fplugin Data.Constraint.Deriving \#-\}
-- @
--
-- to the header of your file.
--
-- For debugging, add a plugin option @dump-instances@
--
-- @
-- {\-\# OPTIONS_GHC -fplugin-opt Data.Constraint.Deriving:dump-instances \#-\}
-- @
--
-- to the header of your file; it will print all instances declared in the module
-- (hand-written and auto-generated).
--
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
           )


-- | Just print all instance signatures in this module
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