-- |
-- Description: Utility functions for generating an export list ast and
--              associated Anns.  It's a bit fiddlier than it could be because ghc's
--              functions for producing exportable things generates @AvailInfo@ from which we
--              need to reconstitue @IEWrappedName@ and then @IE@

module Smuggler2.Exports
  ( mkExportAnnT
  )
where

import Avail ( AvailInfo(..) )
import GHC
    ( AnnKeywordId(AnnCloseP, AnnVal, AnnType, AnnPattern, AnnDotdot,
                   AnnOpenP),
      GhcPs,
      IE(IEThingAbs, IEVar, IEThingAll),
      IEWrappedName(IEName, IEType, IEPattern),
      LIEWrappedName,
      RdrName )
import GhcPlugins ( Located, mkVarUnqual )
import Language.Haskell.GHC.ExactPrint ( TransformT )
import Language.Haskell.GHC.ExactPrint.Types
    ( noExt, DeltaPos(DP), KeywordId(G) )
import Lexeme ( isLexSym )
import Name
    ( Name,
      OccName(occNameFS),
      getOccString,
      isDataOcc,
      isSymOcc,
      isTcOcc,
      HasOccName(occName) )
import Smuggler2.Anns ( mkLocWithAnns, mkLoc )

-- | Generates the annotations for a name, wrapping () around symbollic names
mkLIEName ::
  Monad m =>
  Name ->
  TransformT m (LIEWrappedName RdrName)
mkLIEName :: Name -> TransformT m (LIEWrappedName RdrName)
mkLIEName Name
name
  | OccName -> Bool
isTcOcc OccName
occ Bool -> Bool -> Bool
&& OccName -> Bool
isSymOcc OccName
occ = do
    Located RdrName
lname <-
      RdrName
-> DeltaPos
-> [(KeywordId, DeltaPos)]
-> TransformT m (Located RdrName)
forall e (m :: * -> *).
(Data e, Monad m) =>
e
-> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m (Located e)
mkLocWithAnns
        (FastString -> RdrName
mkVarUnqual FastString
nameFS)
        ((Int, Int) -> DeltaPos
DP (Int
0, Int
0)) -- for a gap afer @type@
        [(KeywordId, DeltaPos)]
ann
    IEWrappedName RdrName
-> DeltaPos
-> [(KeywordId, DeltaPos)]
-> TransformT m (LIEWrappedName RdrName)
forall e (m :: * -> *).
(Data e, Monad m) =>
e
-> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m (Located e)
mkLocWithAnns (Located RdrName -> IEWrappedName RdrName
forall name. Located name -> IEWrappedName name
IEType Located RdrName
lname) ((Int, Int) -> DeltaPos
DP (Int
1, Int
2)) [(AnnKeywordId -> KeywordId
G AnnKeywordId
AnnType, (Int, Int) -> DeltaPos
DP (Int
0, Int
0))]
  | OccName -> Bool
isDataOcc OccName
occ = do
    Located RdrName
lname <-
      RdrName
-> DeltaPos
-> [(KeywordId, DeltaPos)]
-> TransformT m (Located RdrName)
forall e (m :: * -> *).
(Data e, Monad m) =>
e
-> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m (Located e)
mkLocWithAnns
        (FastString -> RdrName
mkVarUnqual FastString
nameFS)
        ((Int, Int) -> DeltaPos
DP (Int
0, Int
1)) -- for a gap after @pattern@
        [(KeywordId, DeltaPos)]
ann
    IEWrappedName RdrName
-> DeltaPos
-> [(KeywordId, DeltaPos)]
-> TransformT m (LIEWrappedName RdrName)
forall e (m :: * -> *).
(Data e, Monad m) =>
e
-> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m (Located e)
mkLocWithAnns (Located RdrName -> IEWrappedName RdrName
forall name. Located name -> IEWrappedName name
IEPattern Located RdrName
lname) ((Int, Int) -> DeltaPos
DP (Int
1, Int
2)) [(AnnKeywordId -> KeywordId
G AnnKeywordId
AnnPattern, (Int, Int) -> DeltaPos
DP (Int
0, Int
0))]
  | Bool
otherwise = do
    Located RdrName
lname <-
      RdrName
-> DeltaPos
-> [(KeywordId, DeltaPos)]
-> TransformT m (Located RdrName)
forall e (m :: * -> *).
(Data e, Monad m) =>
e
-> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m (Located e)
mkLocWithAnns
        (FastString -> RdrName
mkVarUnqual FastString
nameFS)
        ((Int, Int) -> DeltaPos
DP (Int
0, Int
0))
        [(KeywordId, DeltaPos)]
ann
    IEWrappedName RdrName
-> DeltaPos
-> [(KeywordId, DeltaPos)]
-> TransformT m (LIEWrappedName RdrName)
forall e (m :: * -> *).
(Data e, Monad m) =>
e
-> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m (Located e)
mkLocWithAnns (Located RdrName -> IEWrappedName RdrName
forall name. Located name -> IEWrappedName name
IEName Located RdrName
lname) ((Int, Int) -> DeltaPos
DP (Int
1, Int
2)) []
  where
    occ :: OccName
occ = Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
name
    nameFS :: FastString
nameFS = OccName -> FastString
occNameFS OccName
occ
    ann :: [(KeywordId, DeltaPos)]
ann =
      if FastString -> Bool
isLexSym FastString
nameFS -- infix type or data constructor / identifier, so add ()
        then [(AnnKeywordId -> KeywordId
G AnnKeywordId
AnnOpenP, (Int, Int) -> DeltaPos
DP (Int
0, Int
0)), (AnnKeywordId -> KeywordId
G AnnKeywordId
AnnVal, (Int, Int) -> DeltaPos
DP (Int
0, Int
0)), (AnnKeywordId -> KeywordId
G AnnKeywordId
AnnCloseP, (Int, Int) -> DeltaPos
DP (Int
0, Int
0))]
        else [(AnnKeywordId -> KeywordId
G AnnKeywordId
AnnVal, (Int, Int) -> DeltaPos
DP (Int
0, Int
0))]

-- | Uses an exportable thing to generate the corresponding
-- piece of (annotated) AST.
mkExportAnnT :: (Monad m) => AvailInfo -> TransformT m (Located (IE GhcPs))
-- Ordinary identifier
mkExportAnnT :: AvailInfo -> TransformT m (Located (IE GhcPs))
mkExportAnnT (Avail Name
name) = do
  LIEWrappedName RdrName
liename <- Name -> TransformT m (LIEWrappedName RdrName)
forall (m :: * -> *).
Monad m =>
Name -> TransformT m (LIEWrappedName RdrName)
mkLIEName Name
name
  IE GhcPs -> TransformT m (Located (IE GhcPs))
forall e (m :: * -> *).
(Data e, Monad m) =>
e -> TransformT m (Located e)
mkLoc (XIEVar GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar NoExtField
XIEVar GhcPs
noExt LIEWrappedName (IdP GhcPs)
LIEWrappedName RdrName
liename)

-- A type or class.  Since we expect @name@ to be in scope, it should be the head
-- of @names@
mkExportAnnT (AvailTC Name
name [Name]
names [FieldLabel]
fieldlabels) = do
  LIEWrappedName RdrName
liename <- Name -> TransformT m (LIEWrappedName RdrName)
forall (m :: * -> *).
Monad m =>
Name -> TransformT m (LIEWrappedName RdrName)
mkLIEName Name
name

  -- Could export pieces explicitly, but this becomes ugly;
  -- operators need to be wrapped in (), etc, so just export things
  -- with pieces by wildcard
  let lienameWithWildcard :: TransformT m (Located (IE GhcPs))
lienameWithWildcard =
        IE GhcPs
-> DeltaPos
-> [(KeywordId, DeltaPos)]
-> TransformT m (Located (IE GhcPs))
forall e (m :: * -> *).
(Data e, Monad m) =>
e
-> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m (Located e)
mkLocWithAnns
          (XIEThingAll GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass.
XIEThingAll pass -> LIEWrappedName (IdP pass) -> IE pass
IEThingAll NoExtField
XIEThingAll GhcPs
noExt LIEWrappedName (IdP GhcPs)
LIEWrappedName RdrName
liename)
          ((Int, Int) -> DeltaPos
DP (Int
0, Int
0))
          [(AnnKeywordId -> KeywordId
G AnnKeywordId
AnnOpenP, (Int, Int) -> DeltaPos
DP (Int
0, Int
0)), (AnnKeywordId -> KeywordId
G AnnKeywordId
AnnDotdot, (Int, Int) -> DeltaPos
DP (Int
0, Int
0)), (AnnKeywordId -> KeywordId
G AnnKeywordId
AnnCloseP, (Int, Int) -> DeltaPos
DP (Int
0, Int
0))]

  case ([Name]
names, [FieldLabel]
fieldlabels) of
    -- This case implies that the type or class is not to be in scope
    -- which should not happen as we should only be processing exportable things
    -- Alternativey, could just: mkLoc (IEThingAbs noExt liename)
    ([], [FieldLabel]
_) ->
      [Char] -> TransformT m (Located (IE GhcPs))
forall a. HasCallStack => [Char] -> a
error ([Char] -> TransformT m (Located (IE GhcPs)))
-> [Char] -> TransformT m (Located (IE GhcPs))
forall a b. (a -> b) -> a -> b
$
        [Char]
"smuggler: trying to export type class that is not to be in scope "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. NamedThing a => a -> [Char]
getOccString Name
name
    -- A type class with no pieces
    ([Name
_typeclass], []) -> IE GhcPs -> TransformT m (Located (IE GhcPs))
forall e (m :: * -> *).
(Data e, Monad m) =>
e -> TransformT m (Located e)
mkLoc (XIEThingAbs GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass.
XIEThingAbs pass -> LIEWrappedName (IdP pass) -> IE pass
IEThingAbs NoExtField
XIEThingAbs GhcPs
noExt LIEWrappedName (IdP GhcPs)
LIEWrappedName RdrName
liename)
    -- A type class with no pieces, but with field selectors.  A record type?
    ([Name
_typeclass], [FieldLabel]
_fl) -> TransformT m (Located (IE GhcPs))
lienameWithWildcard
    -- A type class with pieces
    (Name
typeorclass : [Name]
_pieces, [FieldLabel]
_fl) ->
      if Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeorclass -- check AvailTC invariant
        then TransformT m (Located (IE GhcPs))
lienameWithWildcard
        else
          [Char] -> TransformT m (Located (IE GhcPs))
forall a. HasCallStack => [Char] -> a
error ([Char] -> TransformT m (Located (IE GhcPs)))
-> [Char] -> TransformT m (Located (IE GhcPs))
forall a b. (a -> b) -> a -> b
$
            [Char]
"smuggler: broken AvailTC invariant: "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. NamedThing a => a -> [Char]
getOccString Name
name
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/="
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. NamedThing a => a -> [Char]
getOccString Name
typeorclass