{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Test.Tasty.AutoCollect.GHC (
  module Test.Tasty.AutoCollect.GHC.Shim,

  -- * Output helpers
  showPpr,

  -- * Parsers
  parseLitStrPat,

  -- * Builders
  genFuncSig,
  genFuncDecl,
  lhsvar,
  mkHsVar,
  mkHsAppTypes,
  mkHsTyVar,
  mkExprTypeSig,
  mkHsLitString,

  -- * Located utilities
  genLoc,
  firstLocatedWhere,
  getSpanLine,

  -- * Name utilities
  mkRdrName,
  mkLRdrName,
  mkRdrNameType,
  mkLRdrNameType,
  fromRdrName,
) where

import Data.Foldable (foldl')
import Data.List (sortOn)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import qualified GHC.Types.Name.Occurrence as NameSpace (tcName, varName)

import Test.Tasty.AutoCollect.GHC.Shim

{----- Output helpers -----}

showPpr :: Outputable a => a -> String
showPpr :: forall a. Outputable a => a -> [Char]
showPpr = SDoc -> [Char]
showSDocUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr

{----- Parsers ----}

parseLitStrPat :: LPat GhcPs -> Maybe String
parseLitStrPat :: LPat GhcPs -> Maybe [Char]
parseLitStrPat = \case
  L SrcSpanAnnA
_ (LitPat XLitPat GhcPs
_ (HsString XHsString GhcPs
_ FastString
s)) -> forall a. a -> Maybe a
Just (FastString -> [Char]
unpackFS FastString
s)
  LPat GhcPs
_ -> forall a. Maybe a
Nothing

{----- Builders -----}

genFuncSig :: LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig :: LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig LocatedN RdrName
funcName LHsType GhcPs
funcType =
  forall p. XSigD p -> Sig p -> HsDecl p
SigD NoExtField
noExtField
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig forall a. EpAnn a
noAnn [LocatedN RdrName
funcName]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> LHsSigWcType GhcPs
hsTypeToHsSigWcType
    forall a b. (a -> b) -> a -> b
$ LHsType GhcPs
funcType

-- | Make simple function declaration of the form `<funcName> <funcArgs> = <funcBody> where <funcWhere>`
genFuncDecl :: LocatedN RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> Maybe (HsLocalBinds GhcPs) -> HsDecl GhcPs
genFuncDecl :: LocatedN RdrName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl LocatedN RdrName
funcName [LPat GhcPs]
funcArgs LHsExpr GhcPs
funcBody Maybe (HsLocalBinds GhcPs)
mFuncWhere =
  forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
NoExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. Origin
-> LocatedN RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
mkFunBind Origin
Generated LocatedN RdrName
funcName forall a b. (a -> b) -> a -> b
$
    [ forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
funcName) [LPat GhcPs]
funcArgs LHsExpr GhcPs
funcBody HsLocalBinds GhcPs
funcWhere
    ]
  where
    funcWhere :: HsLocalBinds GhcPs
funcWhere = forall a. a -> Maybe a -> a
fromMaybe forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds Maybe (HsLocalBinds GhcPs)
mFuncWhere

lhsvar :: LocatedN RdrName -> LHsExpr GhcPs
lhsvar :: LocatedN RdrName -> LHsExpr GhcPs
lhsvar = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
NoExtField

mkHsVar :: Name -> LHsExpr GhcPs
mkHsVar :: Name -> LHsExpr GhcPs
mkHsVar = LocatedN RdrName -> LHsExpr GhcPs
lhsvar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall thing. NamedThing thing => thing -> RdrName
getRdrName

mkHsAppTypes :: LHsExpr GhcPs -> [LHsType GhcPs] -> LHsExpr GhcPs
mkHsAppTypes :: LHsExpr GhcPs -> [LHsType GhcPs] -> LHsExpr GhcPs
mkHsAppTypes = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkHsAppType

mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkHsAppType LHsExpr GhcPs
e LHsType GhcPs
t = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcPs
xAppTypeE LHsExpr GhcPs
e (forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC NoExtField
noExtField LHsType GhcPs
t)

mkHsTyVar :: Name -> LHsType GhcPs
mkHsTyVar :: Name -> LHsType GhcPs
mkHsTyVar = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall thing. NamedThing thing => thing -> RdrName
getRdrName

-- | mkExprTypeSig e t = [| $e :: $t |]
mkExprTypeSig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkExprTypeSig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkExprTypeSig LHsExpr GhcPs
e LHsType GhcPs
t =
  forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig forall a. EpAnn a
noAnn LHsExpr GhcPs
e forall a b. (a -> b) -> a -> b
$
    forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC NoExtField
NoExtField (LHsType GhcPs -> LHsSigType GhcPs
hsTypeToHsSigType LHsType GhcPs
t)

mkHsLitString :: String -> LHsExpr GhcPs
mkHsLitString :: [Char] -> LHsExpr GhcPs
mkHsLitString = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XLitE p -> HsLit p -> HsExpr p
HsLit forall a. EpAnn a
noAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass). [Char] -> HsLit (GhcPass p)
mkHsString

{----- Located utilities -----}

genLoc :: e -> GenLocated (SrcAnn ann) e
genLoc :: forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc = forall l e. l -> e -> GenLocated l e
L forall ann. SrcAnn ann
generatedSrcAnn

firstLocatedWhere :: Ord l => (GenLocated l e -> Maybe a) -> [GenLocated l e] -> Maybe a
firstLocatedWhere :: forall l e a.
Ord l =>
(GenLocated l e -> Maybe a) -> [GenLocated l e] -> Maybe a
firstLocatedWhere GenLocated l e -> Maybe a
f = forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GenLocated l e -> Maybe a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall l e. GenLocated l e -> l
getLoc

getSpanLine :: SrcSpan -> String
getSpanLine :: SrcSpan -> [Char]
getSpanLine SrcSpan
loc =
  case SrcSpan -> SrcLoc
srcSpanStart SrcSpan
loc of
    RealSrcLoc RealSrcLoc
srcLoc Maybe BufPos
_ -> [Char]
"line " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (RealSrcLoc -> Int
srcLocLine RealSrcLoc
srcLoc)
    UnhelpfulLoc FastString
s -> FastString -> [Char]
unpackFS FastString
s

{----- Name utilities -----}

mkRdrName :: String -> RdrName
mkRdrName :: [Char] -> RdrName
mkRdrName = OccName -> RdrName
mkRdrUnqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> [Char] -> OccName
mkOccName NameSpace
NameSpace.varName

mkLRdrName :: String -> LocatedN RdrName
mkLRdrName :: [Char] -> LocatedN RdrName
mkLRdrName = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> RdrName
mkRdrName

mkRdrNameType :: String -> RdrName
mkRdrNameType :: [Char] -> RdrName
mkRdrNameType = OccName -> RdrName
mkRdrUnqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> [Char] -> OccName
mkOccName NameSpace
NameSpace.tcName

mkLRdrNameType :: String -> LocatedN RdrName
mkLRdrNameType :: [Char] -> LocatedN RdrName
mkLRdrNameType = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> RdrName
mkRdrNameType

fromRdrName :: LocatedN RdrName -> String
fromRdrName :: LocatedN RdrName -> [Char]
fromRdrName = OccName -> [Char]
occNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc