{-# LANGUAGE DeriveDataTypeable #-}
module GhcPluginNonEmpty
( plugin
, GhcPlugnNonEmptyClass (..)
, cons
) where
import GHC.Driver.Plugins (CommandLineOption, Plugin (..), defaultPlugin, purePlugin)
import GHC.Hs.Expr (HsWrap (..), XXExprGhcTc (WrapExpr))
import GHC.Hs.Extension (GhcRn, GhcTc)
import GHC.Iface.Env (lookupOrig)
import GHC.Parser.Annotation (EpAnn (..), SrcSpanAnn' (..))
import GHC.Plugins (Name, mkVarOcc)
import GHC.Tc.Types (TcGblEnv (tcg_binds), TcM)
import GHC.Tc.Types.Evidence (HsWrapper, pprHsWrapper)
import GHC.Tc.Utils.Monad (getTopEnv)
import GHC.Types.SrcLoc (GenLocated (L), SrcSpan (..), UnhelpfulSpanReason (..))
import GHC.Types.TyThing (MonadThings (lookupId))
import GHC.Types.Var (Id)
import GHC.Unit.Finder (FindResult (..), findImportedModule)
import GHC.Unit.Module.ModSummary (ModSummary)
import GHC.Utils.Outputable (defaultSDocContext, renderWithContext, sdocPrintTypecheckerElaboration,
text)
import Language.Haskell.Syntax.Decls (HsGroup)
import Language.Haskell.Syntax.Expr (HsExpr (..), LHsExpr)
import Language.Haskell.Syntax.Extension (NoExtField (..))
import Control.Monad.IO.Class (MonadIO (..))
import Data.Generics.Aliases (mkM, mkT)
import Data.Generics.Schemes (everywhere, everywhereM)
import Data.List (isInfixOf)
import Data.List.NonEmpty (NonEmpty (..))
import qualified GHC
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin
{ pluginRecompile :: [[Char]] -> IO PluginRecompile
pluginRecompile = [[Char]] -> IO PluginRecompile
purePlugin
, renamedResultAction :: [[Char]]
-> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
renamedResultAction = [[Char]]
-> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
wrapLists
, typeCheckResultAction :: [[Char]] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typeCheckResultAction = [[Char]] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
replaceNonEmpty
}
wrapLists
:: [CommandLineOption]
-> TcGblEnv
-> HsGroup GhcRn
-> TcM (TcGblEnv, HsGroup GhcRn)
wrapLists :: [[Char]]
-> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
wrapLists [[Char]]
_options TcGblEnv
tcGblEnv HsGroup GhcRn
hsGroup = do
HscEnv
hscEnv <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
Found ModLocation
_ Module
ghcPluginNonEmptyModule <- IO FindResult -> IOEnv (Env TcGblEnv TcLclEnv) FindResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> IOEnv (Env TcGblEnv TcLclEnv) FindResult)
-> IO FindResult -> IOEnv (Env TcGblEnv TcLclEnv) FindResult
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule
HscEnv
hscEnv
([Char] -> ModuleName
GHC.mkModuleName [Char]
"GhcPluginNonEmpty")
Maybe FastString
forall a. Maybe a
Nothing
Name
ghcPluginNonEmptyFromListName <- Module -> OccName -> TcRnIf TcGblEnv TcLclEnv Name
forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig
Module
ghcPluginNonEmptyModule
([Char] -> OccName
mkVarOcc [Char]
"_xxx_ghc_plugin_nonEmpty_fromList")
Name
nonEmptyCtor <- Module -> OccName -> TcRnIf TcGblEnv TcLclEnv Name
forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig
Module
ghcPluginNonEmptyModule
([Char] -> OccName
mkVarOcc [Char]
"cons")
let newHsGroup :: HsGroup GhcRn
newHsGroup = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere
((LHsExpr GhcRn -> LHsExpr GhcRn) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((LHsExpr GhcRn -> LHsExpr GhcRn) -> a -> a)
-> (LHsExpr GhcRn -> LHsExpr GhcRn) -> a -> a
forall a b. (a -> b) -> a -> b
$ Name -> Name -> LHsExpr GhcRn -> LHsExpr GhcRn
rewriteListLiterals Name
ghcPluginNonEmptyFromListName Name
nonEmptyCtor)
HsGroup GhcRn
hsGroup
(TcGblEnv, HsGroup GhcRn) -> TcM (TcGblEnv, HsGroup GhcRn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcGblEnv
tcGblEnv, HsGroup GhcRn
newHsGroup)
rewriteListLiterals
:: Name
-> Name
-> LHsExpr GhcRn
-> LHsExpr GhcRn
rewriteListLiterals :: Name -> Name -> LHsExpr GhcRn -> LHsExpr GhcRn
rewriteListLiterals Name
ghcPluginNonEmptyFromListName Name
nonEmptyCtor = \case
l :: LHsExpr GhcRn
l@(L SrcSpanAnnA
_ ExplicitList{}) ->
LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
app (LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
app (Name -> LHsExpr GhcRn
var Name
ghcPluginNonEmptyFromListName) (Name -> LHsExpr GhcRn
var Name
nonEmptyCtor)) LHsExpr GhcRn
l
LHsExpr GhcRn
expr ->
LHsExpr GhcRn
expr
mkSpan :: a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a
mkSpan :: forall a ann. a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a
mkSpan = SrcSpanAnn' (EpAnn ann)
-> a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnn' (EpAnn ann)
-> a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a)
-> SrcSpanAnn' (EpAnn ann)
-> a
-> GenLocated (SrcSpanAnn' (EpAnn ann)) a
forall a b. (a -> b) -> a -> b
$ EpAnn ann -> SrcSpan -> SrcSpanAnn' (EpAnn ann)
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn EpAnn ann
forall ann. EpAnn ann
EpAnnNotUsed (SrcSpan -> SrcSpanAnn' (EpAnn ann))
-> SrcSpan -> SrcSpanAnn' (EpAnn ann)
forall a b. (a -> b) -> a -> b
$ UnhelpfulSpanReason -> SrcSpan
UnhelpfulSpan UnhelpfulSpanReason
UnhelpfulGenerated
app :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
app :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
app LHsExpr GhcRn
l LHsExpr GhcRn
r = HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a ann. a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a
mkSpan (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XApp GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcRn
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcRn
l LHsExpr GhcRn
r
var :: Name -> LHsExpr GhcRn
var :: Name -> LHsExpr GhcRn
var Name
name = HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a ann. a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a
mkSpan (HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> HsExpr GhcRn -> GenLocated SrcSpanAnnA (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcRn
NoExtField
NoExtField (LIdP GhcRn -> HsExpr GhcRn) -> LIdP GhcRn -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> GenLocated (SrcSpanAnn' (EpAnn NameAnn)) Name
forall a ann. a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a
mkSpan Name
name
replaceNonEmpty
:: [CommandLineOption]
-> ModSummary
-> TcGblEnv
-> TcM TcGblEnv
replaceNonEmpty :: [[Char]] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
replaceNonEmpty [[Char]]
_options ModSummary
_modSummary TcGblEnv
tcGblEnv = do
HscEnv
hscEnv <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
Found ModLocation
_ Module
ghcPluginNonEmptyModule <- IO FindResult -> IOEnv (Env TcGblEnv TcLclEnv) FindResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FindResult -> IOEnv (Env TcGblEnv TcLclEnv) FindResult)
-> IO FindResult -> IOEnv (Env TcGblEnv TcLclEnv) FindResult
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule
HscEnv
hscEnv
([Char] -> ModuleName
GHC.mkModuleName [Char]
"GhcPluginNonEmpty")
Maybe FastString
forall a. Maybe a
Nothing
Name
ghcPluginNonEmptyFromListName <- Module -> OccName -> TcRnIf TcGblEnv TcLclEnv Name
forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig
Module
ghcPluginNonEmptyModule
([Char] -> OccName
mkVarOcc [Char]
"_xxx_ghc_plugin_nonEmpty_fromList")
Id
ghcPluginNonEmptyFromListId <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Id
forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId Name
ghcPluginNonEmptyFromListName
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
newTcgBinds <- GenericM (IOEnv (Env TcGblEnv TcLclEnv))
-> GenericM (IOEnv (Env TcGblEnv TcLclEnv))
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM
((LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc))
-> a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM ((LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc))
-> a -> IOEnv (Env TcGblEnv TcLclEnv) a)
-> (LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc))
-> a
-> IOEnv (Env TcGblEnv TcLclEnv) a
forall a b. (a -> b) -> a -> b
$ Id
-> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc)
rewriteToNonEmpty Id
ghcPluginNonEmptyFromListId)
(TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
tcGblEnv)
TcGblEnv -> TcM TcGblEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure TcGblEnv
tcGblEnv{ tcg_binds :: LHsBinds GhcTc
tcg_binds = LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
newTcgBinds }
rewriteToNonEmpty
:: Id
-> LHsExpr GhcTc
-> TcM (LHsExpr GhcTc)
rewriteToNonEmpty :: Id
-> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc)
rewriteToNonEmpty Id
ghcPluginNonEmptyFromListId = \case
L
SrcSpanAnnA
_
(HsApp
XApp GhcTc
_
(L
SrcSpanAnnA
_
(HsApp
XApp GhcTc
_
(L
SrcSpanAnnA
_
(XExpr
(WrapExpr
(HsWrap
HsWrapper
varType
(HsVar XVar GhcTc
_ (L SrcSpanAnn' (EpAnn NameAnn)
_ Id
varName))
)
)
)
)
LHsExpr GhcTc
nonEmptyCtor
)
)
r :: LHsExpr GhcTc
r@(L
SrcSpanAnnA
_
(ExplicitList XExplicitList GhcTc
listType [LHsExpr GhcTc]
items)
)
)
| Id
varName Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
ghcPluginNonEmptyFromListId ->
if HsWrapper -> Bool
isNonEmptyWrapper HsWrapper
varType
then case [LHsExpr GhcTc]
items of
[] -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
r
LHsExpr GhcTc
x : [LHsExpr GhcTc]
xs -> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc))
-> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a ann. a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a
mkSpan (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
forall ann. EpAnn ann
EpAnnNotUsed
(HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a ann. a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a
mkSpan (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
forall ann. EpAnn ann
EpAnnNotUsed LHsExpr GhcTc
nonEmptyCtor LHsExpr GhcTc
x)
(HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a ann. a -> GenLocated (SrcSpanAnn' (EpAnn ann)) a
mkSpan (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcTc
listType [LHsExpr GhcTc]
xs)
else GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
r
LHsExpr GhcTc
expr -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> IOEnv
(Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr
isNonEmptyWrapper :: HsWrapper -> Bool
isNonEmptyWrapper :: HsWrapper -> Bool
isNonEmptyWrapper HsWrapper
hsWrapper = [Char]
"@NonEmpty" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
strWrapper
where
strWrapper :: String
strWrapper :: [Char]
strWrapper = SDocContext -> SDoc -> [Char]
renderWithContext
SDocContext
defaultSDocContext { sdocPrintTypecheckerElaboration :: Bool
sdocPrintTypecheckerElaboration = Bool
True }
(SDoc -> [Char]) -> SDoc -> [Char]
forall a b. (a -> b) -> a -> b
$ HsWrapper -> (Bool -> SDoc) -> SDoc
pprHsWrapper HsWrapper
hsWrapper (\Bool
_ -> [Char] -> SDoc
text [Char]
"wtf?")
class GhcPlugnNonEmptyClass listOf where
_xxx_ghc_plugin_nonEmpty_fromList
:: (a -> [a] -> NonEmpty a)
-> [a]
-> listOf a
instance GhcPlugnNonEmptyClass [] where
_xxx_ghc_plugin_nonEmpty_fromList :: (a -> [a] -> NonEmpty a) -> [a] -> [a]
_xxx_ghc_plugin_nonEmpty_fromList :: forall a. (a -> [a] -> NonEmpty a) -> [a] -> [a]
_xxx_ghc_plugin_nonEmpty_fromList a -> [a] -> NonEmpty a
_ [a]
l = [a]
l
{-# INLINE _xxx_ghc_plugin_nonEmpty_fromList #-}
instance GhcPlugnNonEmptyClass NonEmpty where
_xxx_ghc_plugin_nonEmpty_fromList :: (a -> [a] -> NonEmpty a) -> [a] -> NonEmpty a
_xxx_ghc_plugin_nonEmpty_fromList :: forall a. (a -> [a] -> NonEmpty a) -> [a] -> NonEmpty a
_xxx_ghc_plugin_nonEmpty_fromList = [Char] -> (a -> [a] -> NonEmpty a) -> [a] -> NonEmpty a
forall a. HasCallStack => [Char] -> a
error ([Char] -> (a -> [a] -> NonEmpty a) -> [a] -> NonEmpty a)
-> [Char] -> (a -> [a] -> NonEmpty a) -> [a] -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
[ [Char]
"Panic! At The 'ghc-plugin-non-empty'"
, [Char]
" Remained usage of: _xxx_ghc_plugin_nonEmpty_fromList :: [a] -> NonEmpty a"
, [Char]
""
, [Char]
"If you see this error, please open an issue in the plugin with your code example:"
, [Char]
""
, [Char]
" * https://github.com/chshersh/ghc-plugin-non-empty/issues/new"
]
{-# NOINLINE _xxx_ghc_plugin_nonEmpty_fromList #-}
cons :: a -> [a] -> NonEmpty a
cons :: forall a. a -> [a] -> NonEmpty a
cons = a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|)