{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes          #-}

-- | Custom SYB traversals
module Wingman.Judgements.SYB where

import           Data.Foldable (foldl')
import           Data.Generics hiding (typeRep)
import qualified Data.Text as T
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.Util (unpackFS)
import           GHC.Exts (Any)
import           Type.Reflection
import           Unsafe.Coerce (unsafeCoerce)
import           Wingman.StaticPlugin (pattern WingmanMetaprogram)


------------------------------------------------------------------------------
-- | Like 'everything', but only looks inside 'Located' terms that contain the
-- given 'SrcSpan'.
everythingContaining
    :: forall r
     . Monoid r
    => SrcSpan
    -> GenericQ r
    -> GenericQ r
everythingContaining :: SrcSpan -> GenericQ r -> GenericQ r
everythingContaining SrcSpan
dst GenericQ r
f = a -> r
GenericQ r
go
  where
    go :: GenericQ r
    go :: a -> r
go a
x =
      case SrcSpan -> a -> Maybe Bool
SrcSpan -> GenericQ (Maybe Bool)
genericIsSubspan SrcSpan
dst a
x of
        Just Bool
False -> r
forall a. Monoid a => a
mempty
        Maybe Bool
_ -> (r -> r -> r) -> r -> [r] -> r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' r -> r -> r
forall a. Semigroup a => a -> a -> a
(<>) (a -> r
GenericQ r
f a
x) (GenericQ r -> a -> [r]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ GenericQ r
go a
x)


------------------------------------------------------------------------------
-- | Helper function for implementing 'everythingWithin'
--
-- NOTE(sandy): Subtly broken. In an ideal world, this function shuld return
-- @Just False@ for nodes of /any type/ which do not contain the span. But if
-- this functionality exists anywhere within the SYB machinery, I have yet to
-- find it.
genericIsSubspan
    :: SrcSpan
    -> GenericQ (Maybe Bool)
genericIsSubspan :: SrcSpan -> GenericQ (Maybe Bool)
genericIsSubspan SrcSpan
dst = GenLocated SrcSpan ()
-> Maybe Bool
-> (forall b. GenLocated SrcSpan b -> Maybe Bool)
-> a
-> Maybe Bool
forall a r (f :: * -> *).
(Data a, Data (f ())) =>
f () -> r -> (forall b. f b -> r) -> a -> r
mkQ1 (SrcSpan -> () -> GenLocated SrcSpan ()
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan ()) Maybe Bool
forall a. Maybe a
Nothing ((forall b. GenLocated SrcSpan b -> Maybe Bool) -> a -> Maybe Bool)
-> (forall b. GenLocated SrcSpan b -> Maybe Bool)
-> a
-> Maybe Bool
forall a b. (a -> b) -> a -> b
$ \case
  L SrcSpan
span b
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ SrcSpan
dst SrcSpan -> SrcSpan -> Bool
`isSubspanOf` SrcSpan
span


------------------------------------------------------------------------------
-- | Like 'mkQ', but allows for polymorphic instantiation of its specific case.
-- This instantation matches whenever the dynamic value has the same
-- constructor as the proxy @f ()@ value.
mkQ1 :: forall a r f
      . (Data a, Data (f ()))
     => f ()                  -- ^ Polymorphic constructor to match on
     -> r                     -- ^ Default value
     -> (forall b. f b -> r)  -- ^ Polymorphic match
     -> a
     -> r
mkQ1 :: f () -> r -> (forall b. f b -> r) -> a -> r
mkQ1 f ()
proxy r
r forall b. f b -> r
br a
a =
    case Constr
l_con Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== Constr
a_con Bool -> Bool -> Bool
&& (Typeable a, Typeable (f ())) => Bool
forall a b. (Typeable a, Typeable b) => Bool
sameTypeModuloLastApp @a @(f ()) of
      -- We have proven that the two values share the same constructor, and
      -- that they have the same type if you ignore the final application.
      -- Therefore, it is safe to coerce @a@ to @f b@, since @br@ is universal
      -- over @b@ and can't inspect it.
      Bool
True  -> f Any -> r
forall b. f b -> r
br (f Any -> r) -> f Any -> r
forall a b. (a -> b) -> a -> b
$ a -> f Any
forall a b. a -> b
unsafeCoerce @_ @(f Any) a
a
      Bool
False -> r
r
  where
    l_con :: Constr
l_con = f () -> Constr
forall a. Data a => a -> Constr
toConstr f ()
proxy
    a_con :: Constr
a_con = a -> Constr
forall a. Data a => a -> Constr
toConstr a
a


------------------------------------------------------------------------------
-- | Given @a ~ f1 a1@ and @b ~ f2 b2@, returns true if @f1 ~ f2@.
sameTypeModuloLastApp :: forall a b. (Typeable a, Typeable b) => Bool
sameTypeModuloLastApp :: Bool
sameTypeModuloLastApp =
  let tyrep1 :: TypeRep a
tyrep1 = Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @a
      tyrep2 :: TypeRep b
tyrep2 = Typeable b => TypeRep b
forall k (a :: k). Typeable a => TypeRep a
typeRep @b
   in case (TypeRep a
tyrep1 , TypeRep b
tyrep2) of
        (App TypeRep a
a TypeRep b
_, App TypeRep a
b TypeRep b
_) ->
          case TypeRep a -> TypeRep a -> Maybe (a :~~: a)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep a
a TypeRep a
b of
            Just a :~~: a
HRefl -> Bool
True
            Maybe (a :~~: a)
Nothing    -> Bool
False
        (TypeRep a, TypeRep b)
_ -> Bool
False


metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)]
metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, Text)]
metaprogramAtQ SrcSpan
ss = SrcSpan -> GenericQ [(SrcSpan, Text)] -> GenericQ [(SrcSpan, Text)]
forall r. Monoid r => SrcSpan -> GenericQ r -> GenericQ r
everythingContaining SrcSpan
ss (GenericQ [(SrcSpan, Text)] -> GenericQ [(SrcSpan, Text)])
-> GenericQ [(SrcSpan, Text)] -> GenericQ [(SrcSpan, Text)]
forall a b. (a -> b) -> a -> b
$ [(SrcSpan, Text)]
-> (GenLocated SrcSpan (HsExpr GhcTc) -> [(SrcSpan, Text)])
-> a
-> [(SrcSpan, Text)]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [(SrcSpan, Text)]
forall a. Monoid a => a
mempty ((GenLocated SrcSpan (HsExpr GhcTc) -> [(SrcSpan, Text)])
 -> a -> [(SrcSpan, Text)])
-> (GenLocated SrcSpan (HsExpr GhcTc) -> [(SrcSpan, Text)])
-> a
-> [(SrcSpan, Text)]
forall a b. (a -> b) -> a -> b
$ \case
  L SrcSpan
new_span (WingmanMetaprogram FastString
program) -> (SrcSpan, Text) -> [(SrcSpan, Text)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan
new_span, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
program)
  (GenLocated SrcSpan (HsExpr GhcTc)
_ :: LHsExpr GhcTc) -> [(SrcSpan, Text)]
forall a. Monoid a => a
mempty


metaprogramQ :: GenericQ [(SrcSpan, T.Text)]
metaprogramQ :: a -> [(SrcSpan, Text)]
metaprogramQ = ([(SrcSpan, Text)] -> [(SrcSpan, Text)] -> [(SrcSpan, Text)])
-> GenericQ [(SrcSpan, Text)] -> GenericQ [(SrcSpan, Text)]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [(SrcSpan, Text)] -> [(SrcSpan, Text)] -> [(SrcSpan, Text)]
forall a. Semigroup a => a -> a -> a
(<>) (GenericQ [(SrcSpan, Text)] -> GenericQ [(SrcSpan, Text)])
-> GenericQ [(SrcSpan, Text)] -> GenericQ [(SrcSpan, Text)]
forall a b. (a -> b) -> a -> b
$ [(SrcSpan, Text)]
-> (GenLocated SrcSpan (HsExpr GhcTc) -> [(SrcSpan, Text)])
-> a
-> [(SrcSpan, Text)]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [(SrcSpan, Text)]
forall a. Monoid a => a
mempty ((GenLocated SrcSpan (HsExpr GhcTc) -> [(SrcSpan, Text)])
 -> a -> [(SrcSpan, Text)])
-> (GenLocated SrcSpan (HsExpr GhcTc) -> [(SrcSpan, Text)])
-> a
-> [(SrcSpan, Text)]
forall a b. (a -> b) -> a -> b
$ \case
  L SrcSpan
new_span (WingmanMetaprogram FastString
program) -> (SrcSpan, Text) -> [(SrcSpan, Text)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan
new_span, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
program)
  (GenLocated SrcSpan (HsExpr GhcTc)
_ :: LHsExpr GhcTc) -> [(SrcSpan, Text)]
forall a. Monoid a => a
mempty