{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE ViewPatterns #-}

module Skeletest.Internal.Plugin (
  plugin,
) where

import Data.Functor.Const (Const (..))
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text qualified as Text

#if !MIN_VERSION_base(4, 20, 0)
import Data.Foldable (foldl')
#endif

import Skeletest.Internal.Constants (mainFileSpecsListIdentifier)
import Skeletest.Internal.Error (skeletestPluginError)
import Skeletest.Internal.GHC
import Skeletest.Internal.Predicate qualified as P
import Skeletest.Internal.Utils.HList (HList (..))
import Skeletest.Main qualified as Main
import Skeletest.Plugin qualified as Plugin

-- | The plugin to convert a module in the tests directory.
-- Injected by the preprocessor.
plugin :: Plugin
plugin :: Plugin
plugin =
  PluginDef -> Plugin
mkPlugin
    PluginDef
      { isPure :: Bool
isPure = Bool
True
      , modifyParsed :: Text -> ParsedModule -> ParsedModule
modifyParsed = \Text
modName ParsedModule
modl ->
          if Text
modName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Main"
            then ParsedModule -> ParsedModule
transformMainModule ParsedModule
modl
            else ParsedModule
modl
      , onRename :: Ctx -> Text -> HsExpr GhcRn -> HsExpr GhcRn
onRename = \Ctx
ctx Text
modName HsExpr GhcRn
expr ->
          if Text
"Spec" Text -> Text -> Bool
`Text.isSuffixOf` Text
modName
            then Ctx -> HsExpr GhcRn -> HsExpr GhcRn
transformTestModule Ctx
ctx HsExpr GhcRn
expr
            else HsExpr GhcRn
expr
      }

-- | Add 'main' function.
transformMainModule :: ParsedModule -> ParsedModule
transformMainModule :: ParsedModule -> ParsedModule
transformMainModule ParsedModule
modl = ParsedModule
modl{moduleFuncs = (hsVarName "main", Just mainFun) : moduleFuncs modl}
  where
    findVar :: Text -> Maybe (HsExpr GhcPs)
findVar Text
name =
      (HsName GhcPs -> HsExpr GhcPs)
-> Maybe (HsName GhcPs) -> Maybe (HsExpr GhcPs)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsName GhcPs -> HsExpr GhcPs
forall p. HsName p -> HsExpr p
hsExprVar (Maybe (HsName GhcPs) -> Maybe (HsExpr GhcPs))
-> ([HsName GhcPs] -> Maybe (HsName GhcPs))
-> [HsName GhcPs]
-> Maybe (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HsName GhcPs] -> Maybe (HsName GhcPs)
forall a. [a] -> Maybe a
listToMaybe ([HsName GhcPs] -> Maybe (HsExpr GhcPs))
-> [HsName GhcPs] -> Maybe (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
        [ HsName GhcPs
funName
        | (HsName GhcPs
funName, Maybe FunDef
_) <- ParsedModule -> [(HsName GhcPs, Maybe FunDef)]
moduleFuncs ParsedModule
modl
        , HsName GhcPs -> Text
forall p. HsName p -> Text
getHsName HsName GhcPs
funName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name
        ]

    cliFlagsExpr :: HsExpr GhcPs
cliFlagsExpr = HsExpr GhcPs -> Maybe (HsExpr GhcPs) -> HsExpr GhcPs
forall a. a -> Maybe a -> a
fromMaybe ([HsExpr GhcPs] -> HsExpr GhcPs
forall p. [HsExpr p] -> HsExpr p
hsExprList []) (Maybe (HsExpr GhcPs) -> HsExpr GhcPs)
-> Maybe (HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (HsExpr GhcPs)
findVar Text
"cliFlags"
    snapshotRenderersExpr :: HsExpr GhcPs
snapshotRenderersExpr = HsExpr GhcPs -> Maybe (HsExpr GhcPs) -> HsExpr GhcPs
forall a. a -> Maybe a -> a
fromMaybe ([HsExpr GhcPs] -> HsExpr GhcPs
forall p. [HsExpr p] -> HsExpr p
hsExprList []) (Maybe (HsExpr GhcPs) -> HsExpr GhcPs)
-> Maybe (HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (HsExpr GhcPs)
findVar Text
"snapshotRenderers"
    hooksExpr :: HsExpr GhcPs
hooksExpr = HsExpr GhcPs -> Maybe (HsExpr GhcPs) -> HsExpr GhcPs
forall a. a -> Maybe a -> a
fromMaybe (HsName GhcPs -> HsExpr GhcPs
forall p. HsName p -> HsExpr p
hsExprVar (HsName GhcPs -> HsExpr GhcPs) -> HsName GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Name -> HsName GhcPs
forall p. Name -> HsName p
hsName 'Plugin.defaultHooks) (Maybe (HsExpr GhcPs) -> HsExpr GhcPs)
-> Maybe (HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (HsExpr GhcPs)
findVar Text
"hooks"
    pluginsExpr :: HsExpr GhcPs
pluginsExpr = HsExpr GhcPs -> Maybe (HsExpr GhcPs) -> HsExpr GhcPs
forall a. a -> Maybe a -> a
fromMaybe ([HsExpr GhcPs] -> HsExpr GhcPs
forall p. [HsExpr p] -> HsExpr p
hsExprList []) (Maybe (HsExpr GhcPs) -> HsExpr GhcPs)
-> Maybe (HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (HsExpr GhcPs)
findVar Text
"plugins"

    mainFun :: FunDef
mainFun =
      FunDef
        { funType :: HsType GhcPs
funType = HsType GhcPs -> [HsType GhcPs] -> HsType GhcPs
forall p. HsType p -> [HsType p] -> HsType p
HsTypeApps (HsName GhcPs -> HsType GhcPs
forall p. HsName p -> HsType p
HsTypeCon (HsName GhcPs -> HsType GhcPs) -> HsName GhcPs -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$ Name -> HsName GhcPs
forall p. Name -> HsName p
hsName ''IO) [[HsType GhcPs] -> HsType GhcPs
forall p. [HsType p] -> HsType p
HsTypeTuple []]
        , funPats :: [HsPat GhcPs]
funPats = []
        , funBody :: HsExpr GhcPs
funBody =
            HsExpr GhcPs -> [HsExpr GhcPs] -> HsExpr GhcPs
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps
              (HsName GhcPs -> HsExpr GhcPs
forall p. HsName p -> HsExpr p
hsExprVar (HsName GhcPs -> HsExpr GhcPs) -> HsName GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Name -> HsName GhcPs
forall p. Name -> HsName p
hsName 'Main.runSkeletest)
              [ HsExpr GhcPs -> [HsExpr GhcPs] -> HsExpr GhcPs
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName GhcPs -> HsExpr GhcPs
forall p. HsName p -> HsExpr p
hsExprVar (Name -> HsName GhcPs
forall p. Name -> HsName p
hsName '(:))) ([HsExpr GhcPs] -> HsExpr GhcPs) -> [HsExpr GhcPs] -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
                  [ HsName GhcPs -> [(HsName GhcPs, HsExpr GhcPs)] -> HsExpr GhcPs
forall p. HsName p -> [(HsName p, HsExpr p)] -> HsExpr p
hsExprRecordCon
                      (Name -> HsName GhcPs
forall p. Name -> HsName p
hsName 'Plugin.Plugin)
                      [ (Name -> HsName GhcPs
forall p. Name -> HsName p
hsName 'Plugin.cliFlags, HsExpr GhcPs
cliFlagsExpr)
                      , (Name -> HsName GhcPs
forall p. Name -> HsName p
hsName 'Plugin.snapshotRenderers, HsExpr GhcPs
snapshotRenderersExpr)
                      , (Name -> HsName GhcPs
forall p. Name -> HsName p
hsName 'Plugin.hooks, HsExpr GhcPs
hooksExpr)
                      ]
                  , HsExpr GhcPs
pluginsExpr
                  ]
              , HsName GhcPs -> HsExpr GhcPs
forall p. HsName p -> HsExpr p
hsExprVar (HsName GhcPs -> HsExpr GhcPs) -> HsName GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Text -> HsName GhcPs
forall p. Text -> HsName p
hsVarName Text
mainFileSpecsListIdentifier
              ]
        }

transformTestModule :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn
transformTestModule :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn
transformTestModule Ctx
ctx =
  ((HsExpr GhcRn -> HsExpr GhcRn)
 -> (HsExpr GhcRn -> HsExpr GhcRn) -> HsExpr GhcRn -> HsExpr GhcRn)
-> (HsExpr GhcRn -> HsExpr GhcRn)
-> [HsExpr GhcRn -> HsExpr GhcRn]
-> HsExpr GhcRn
-> HsExpr GhcRn
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (HsExpr GhcRn -> HsExpr GhcRn)
-> (HsExpr GhcRn -> HsExpr GhcRn) -> HsExpr GhcRn -> HsExpr GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) HsExpr GhcRn -> HsExpr GhcRn
forall a. a -> a
id ([HsExpr GhcRn -> HsExpr GhcRn] -> HsExpr GhcRn -> HsExpr GhcRn)
-> [HsExpr GhcRn -> HsExpr GhcRn] -> HsExpr GhcRn -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$
    [ Ctx -> HsExpr GhcRn -> HsExpr GhcRn
replaceConMatch Ctx
ctx
    , Ctx -> HsExpr GhcRn -> HsExpr GhcRn
replaceIsoChecker Ctx
ctx
    ]

-- | Replace all uses of P.con with P.conMatches. See P.con.
--
-- P.con $ User (P.eq "user1") (P.contains "@")
-- ====>
-- P.conMatches
--   "User"
--   Nothing
--   ( \case
--       User x0 x1 -> Just (HCons (pure x0) $ HCons (pure x1) $ HNil)
--       _ -> Nothing
--   )
--   (HCons (H.eq "user1") $ HCons (P.contains "@") $ HNil)
--
-- P.con User{name = P.eq "user1", email = P.contains "@"}
-- ====>
-- P.conMatches
--   "User"
--   (Just (HCons (Const "user") $ HCons (Const "email") $ HNil))
--   ( \case
--       User{name, email} -> Just (HCons (pure name) $ HCons (pure email) $ HNil)
--       _ -> Nothing
--   )
--   (HCons (P.eq "user1") $ HCons (P.contains "@") $ HNil)
replaceConMatch :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn
replaceConMatch :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn
replaceConMatch Ctx
ctx HsExpr GhcRn
e =
  case HsExpr GhcRn -> HsExprData GhcRn
forall p. HsExpr p -> HsExprData p
getExpr HsExpr GhcRn
e of
    -- Matches:
    --   P.con User{name = ...}
    --   P.con (User "...")
    HsExprApps (HsExpr GhcRn -> HsExprData GhcRn
forall p. HsExpr p -> HsExprData p
getExpr -> HsExprVar HsName GhcRn
name) [HsExpr GhcRn
arg]
      | HsName GhcRn -> Bool
isCon HsName GhcRn
name ->
          HsExpr GhcRn -> HsExpr GhcRn
forall {p}. HsExpr p -> HsExpr p
convertCon HsExpr GhcRn
arg
    -- Matches:
    --   P.con $ User "..."
    HsExprOp (HsExpr GhcRn -> HsExprData GhcRn
forall p. HsExpr p -> HsExprData p
getExpr -> HsExprVar HsName GhcRn
name) (HsExpr GhcRn -> HsExprData GhcRn
forall p. HsExpr p -> HsExprData p
getExpr -> HsExprVar HsName GhcRn
dollar) HsExpr GhcRn
arg
      | Ctx -> HsName GhcRn -> HsName GhcRn -> Bool
matchesName Ctx
ctx (Name -> HsName GhcRn
forall p. Name -> HsName p
hsName '($)) HsName GhcRn
dollar
      , HsName GhcRn -> Bool
isCon HsName GhcRn
name ->
          HsExpr GhcRn -> HsExpr GhcRn
forall {p}. HsExpr p -> HsExpr p
convertCon HsExpr GhcRn
arg
    -- Check if P.con is by itself
    HsExprVar HsName GhcRn
name
      | HsName GhcRn -> Bool
isCon HsName GhcRn
name ->
          String -> HsExpr GhcRn
forall a. String -> a
skeletestPluginError String
"P.con must be applied to a constructor"
    -- Check if P.con is being applied more than once
    HsExprApps (HsExpr GhcRn -> HsExprData GhcRn
forall p. HsExpr p -> HsExprData p
getExpr -> HsExprVar HsName GhcRn
name) (HsExpr GhcRn
_ : HsExpr GhcRn
_ : [HsExpr GhcRn]
_)
      | HsName GhcRn -> Bool
isCon HsName GhcRn
name ->
          String -> HsExpr GhcRn
forall a. String -> a
skeletestPluginError String
"P.con must be applied to exactly one argument"
    HsExprData GhcRn
_ -> HsExpr GhcRn
e
  where
    isCon :: HsName GhcRn -> Bool
isCon = Ctx -> HsName GhcRn -> HsName GhcRn -> Bool
matchesName Ctx
ctx (Name -> HsName GhcRn
forall p. Name -> HsName p
hsName 'P.con)

    convertCon :: HsExpr p -> HsExpr p
convertCon HsExpr p
con =
      case HsExpr p -> HsExprData p
forall p. HsExpr p -> HsExprData p
getExpr HsExpr p
con of
        HsExprCon HsName p
conName -> HsName p -> [HsExpr p] -> HsExpr p
forall {p}. HsName p -> [HsExpr p] -> HsExpr p
convertPrefixCon HsName p
conName []
        HsExprApps (HsExpr p -> HsExprData p
forall p. HsExpr p -> HsExprData p
getExpr -> HsExprCon HsName p
conName) [HsExpr p]
preds -> HsName p -> [HsExpr p] -> HsExpr p
forall {p}. HsName p -> [HsExpr p] -> HsExpr p
convertPrefixCon HsName p
conName [HsExpr p]
preds
        HsExprRecordCon HsName p
conName [(HsName p, HsExpr p)]
fields -> HsName p -> [(HsName p, HsExpr p)] -> HsExpr p
forall p. HsName p -> [(HsName p, HsExpr p)] -> HsExpr p
convertRecordCon HsName p
conName [(HsName p, HsExpr p)]
fields
        HsExprData p
_ -> String -> HsExpr p
forall a. String -> a
skeletestPluginError String
"P.con must be applied to a constructor"
    convertPrefixCon :: HsName p -> [HsExpr p] -> HsExpr p
convertPrefixCon HsName p
conName [HsExpr p]
preds =
      let
        exprNames :: [HsName p]
exprNames = [HsExpr p] -> [HsName p]
forall {b} {p}. [b] -> [HsName p]
mkVarNames [HsExpr p]
preds
       in
        HsExpr p -> [HsExpr p] -> HsExpr p
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprVar (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'P.conMatches) ([HsExpr p] -> HsExpr p) -> [HsExpr p] -> HsExpr p
forall a b. (a -> b) -> a -> b
$
          [ Text -> HsExpr p
forall p. Text -> HsExpr p
hsExprLitString (Text -> HsExpr p) -> Text -> HsExpr p
forall a b. (a -> b) -> a -> b
$ HsName p -> Text
forall p. HsName p -> Text
getHsName HsName p
conName
          , HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprCon (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'Nothing
          , HsPat p -> [HsName p] -> HsExpr p
forall {p}. HsPat p -> [HsName p] -> HsExpr p
mkDeconstruct (HsName p -> [HsPat p] -> HsPat p
forall p. HsName p -> [HsPat p] -> HsPat p
HsPatCon HsName p
conName ([HsPat p] -> HsPat p) -> [HsPat p] -> HsPat p
forall a b. (a -> b) -> a -> b
$ (HsName p -> HsPat p) -> [HsName p] -> [HsPat p]
forall a b. (a -> b) -> [a] -> [b]
map HsName p -> HsPat p
forall p. HsName p -> HsPat p
HsPatVar [HsName p]
forall {p}. [HsName p]
exprNames) [HsName p]
forall {p}. [HsName p]
exprNames
          , [HsExpr p] -> HsExpr p
forall p. [HsExpr p] -> HsExpr p
mkPredList [HsExpr p]
preds
          ]
    convertRecordCon :: HsName p -> [(HsName p, HsExpr p)] -> HsExpr p
convertRecordCon HsName p
conName [(HsName p, HsExpr p)]
fields =
      let
        ([HsName p]
fieldNames, [HsExpr p]
preds) = [(HsName p, HsExpr p)] -> ([HsName p], [HsExpr p])
forall a b. [(a, b)] -> ([a], [b])
unzip [(HsName p, HsExpr p)]
fields
        fieldPats :: [(HsName p, HsPat p)]
fieldPats = [(HsName p
field, HsName p -> HsPat p
forall p. HsName p -> HsPat p
HsPatVar HsName p
field) | HsName p
field <- [HsName p]
fieldNames]
       in
        HsExpr p -> [HsExpr p] -> HsExpr p
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprVar (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'P.conMatches) ([HsExpr p] -> HsExpr p) -> [HsExpr p] -> HsExpr p
forall a b. (a -> b) -> a -> b
$
          [ Text -> HsExpr p
forall p. Text -> HsExpr p
hsExprLitString (Text -> HsExpr p) -> Text -> HsExpr p
forall a b. (a -> b) -> a -> b
$ HsName p -> Text
forall p. HsName p -> Text
getHsName HsName p
conName
          , HsExpr p -> [HsExpr p] -> HsExpr p
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprCon (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'Just) [[HsName p] -> HsExpr p
forall {p} {p}. [HsName p] -> HsExpr p
mkNamesList [HsName p]
fieldNames]
          , HsPat p -> [HsName p] -> HsExpr p
forall {p}. HsPat p -> [HsName p] -> HsExpr p
mkDeconstruct (HsName p -> [(HsName p, HsPat p)] -> HsPat p
forall p. HsName p -> [(HsName p, HsPat p)] -> HsPat p
HsPatRecord HsName p
conName [(HsName p, HsPat p)]
fieldPats) [HsName p]
fieldNames
          , [HsExpr p] -> HsExpr p
forall p. [HsExpr p] -> HsExpr p
mkPredList [HsExpr p]
preds
          ]

    -- Generate variable names like x0, x1, ... for each element in the given list.
    mkVarNames :: [b] -> [HsName p]
mkVarNames =
      let mkVar :: a -> Text
mkVar a
i = Text
"x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) a
i
       in (Int -> b -> HsName p) -> [Int] -> [b] -> [HsName p]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i b
_ -> Text -> HsName p
forall p. Text -> HsName p
hsVarName (Int -> Text
forall {a}. Show a => a -> Text
mkVar Int
i)) [Int
0 :: Int ..]

    -- Create the deconstruction function:
    --
    -- \actual ->
    --   case actual of
    --     User{name} -> Just (HCons (pure name) HNil)
    --     _ -> Nothing
    --
    -- However, if 'User' is the only constructor, GHC complains about the wildcard
    -- being redundant. So we'll obfuscate it a bit with
    --
    -- \actual ->
    --   case pure actual of
    --     Just User{name} -> Just (HCons (pure name) HNil)
    --     _ -> Nothing
    mkDeconstruct :: HsPat p -> [HsName p] -> HsExpr p
mkDeconstruct HsPat p
pat [HsName p]
argNames =
      [HsPat p] -> HsExpr p -> HsExpr p
forall p. [HsPat p] -> HsExpr p -> HsExpr p
hsExprLam [HsName p -> HsPat p
forall p. HsName p -> HsPat p
HsPatVar (HsName p -> HsPat p) -> HsName p -> HsPat p
forall a b. (a -> b) -> a -> b
$ Text -> HsName p
forall p. Text -> HsName p
hsVarName Text
"actual"] (HsExpr p -> HsExpr p) -> HsExpr p -> HsExpr p
forall a b. (a -> b) -> a -> b
$
        HsExpr p -> [(HsPat p, HsExpr p)] -> HsExpr p
forall p. HsExpr p -> [(HsPat p, HsExpr p)] -> HsExpr p
hsExprCase (HsExpr p -> [HsExpr p] -> HsExpr p
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprVar (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'pure) [HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprVar (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Text -> HsName p
forall p. Text -> HsName p
hsVarName Text
"actual"]) ([(HsPat p, HsExpr p)] -> HsExpr p)
-> [(HsPat p, HsExpr p)] -> HsExpr p
forall a b. (a -> b) -> a -> b
$
          [ (HsName p -> [HsPat p] -> HsPat p
forall p. HsName p -> [HsPat p] -> HsPat p
HsPatCon (Name -> HsName p
forall p. Name -> HsName p
hsName 'Just) [HsPat p
pat], HsExpr p -> [HsExpr p] -> HsExpr p
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprCon (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'Just) [[HsName p] -> HsExpr p
forall {p}. [HsName p] -> HsExpr p
mkValsList [HsName p]
argNames])
          , (HsPat p
forall p. HsPat p
HsPatWild, HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprCon (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'Nothing)
          ]

    mkHList :: (t -> HsExpr p) -> [t] -> HsExpr p
mkHList t -> HsExpr p
f = \case
      [] -> HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprCon (Name -> HsName p
forall p. Name -> HsName p
hsName 'HNil)
      t
x : [t]
xs ->
        HsExpr p -> [HsExpr p] -> HsExpr p
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprCon (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'HCons) ([HsExpr p] -> HsExpr p) -> [HsExpr p] -> HsExpr p
forall a b. (a -> b) -> a -> b
$
          [ t -> HsExpr p
f t
x
          , (t -> HsExpr p) -> [t] -> HsExpr p
mkHList t -> HsExpr p
f [t]
xs
          ]

    mkNamesList :: [HsName p] -> HsExpr p
mkNamesList = (HsName p -> HsExpr p) -> [HsName p] -> HsExpr p
forall {t} {p}. (t -> HsExpr p) -> [t] -> HsExpr p
mkHList ((HsName p -> HsExpr p) -> [HsName p] -> HsExpr p)
-> (HsName p -> HsExpr p) -> [HsName p] -> HsExpr p
forall a b. (a -> b) -> a -> b
$ \HsName p
name -> HsExpr p -> [HsExpr p] -> HsExpr p
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprCon (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'Const) [Text -> HsExpr p
forall p. Text -> HsExpr p
hsExprLitString (Text -> HsExpr p) -> Text -> HsExpr p
forall a b. (a -> b) -> a -> b
$ HsName p -> Text
forall p. HsName p -> Text
getHsName HsName p
name]
    mkValsList :: [HsName p] -> HsExpr p
mkValsList = (HsName p -> HsExpr p) -> [HsName p] -> HsExpr p
forall {t} {p}. (t -> HsExpr p) -> [t] -> HsExpr p
mkHList ((HsName p -> HsExpr p) -> [HsName p] -> HsExpr p)
-> (HsName p -> HsExpr p) -> [HsName p] -> HsExpr p
forall a b. (a -> b) -> a -> b
$ \HsName p
val -> HsExpr p -> [HsExpr p] -> HsExpr p
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprVar (HsName p -> HsExpr p) -> HsName p -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Name -> HsName p
forall p. Name -> HsName p
hsName 'pure) [HsName p -> HsExpr p
forall p. HsName p -> HsExpr p
hsExprVar HsName p
val]
    mkPredList :: [HsExpr p] -> HsExpr p
mkPredList = (HsExpr p -> HsExpr p) -> [HsExpr p] -> HsExpr p
forall {t} {p}. (t -> HsExpr p) -> [t] -> HsExpr p
mkHList HsExpr p -> HsExpr p
forall a. a -> a
id

-- | Replace all uses of P.=== with inlined IsoChecker value, with
-- function name filled in.
--
-- (encode . decode) P.=== id
-- ====>
-- IsoChecker (Fun "encode . decode" (encode . decode)) (Fun "id" id)
replaceIsoChecker :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn
replaceIsoChecker :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn
replaceIsoChecker Ctx
ctx HsExpr GhcRn
e =
  case HsExpr GhcRn -> HsExprData GhcRn
forall p. HsExpr p -> HsExprData p
getExpr HsExpr GhcRn
e of
    HsExprOp HsExpr GhcRn
l (HsExpr GhcRn -> HsExprData GhcRn
forall p. HsExpr p -> HsExprData p
getExpr -> HsExprVar HsName GhcRn
eqeqeq) HsExpr GhcRn
r
      | Ctx -> HsName GhcRn -> HsName GhcRn -> Bool
matchesName Ctx
ctx (Name -> HsName GhcRn
forall p. Name -> HsName p
hsName '(P.===)) HsName GhcRn
eqeqeq ->
          HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
inlineIsoChecker HsExpr GhcRn
l HsExpr GhcRn
r
    HsExprData GhcRn
_ -> HsExpr GhcRn
e
  where
    inlineIsoChecker :: HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
inlineIsoChecker HsExpr GhcRn
l HsExpr GhcRn
r = HsExpr GhcRn -> [HsExpr GhcRn] -> HsExpr GhcRn
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName GhcRn -> HsExpr GhcRn
forall p. HsName p -> HsExpr p
hsExprCon (HsName GhcRn -> HsExpr GhcRn) -> HsName GhcRn -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> HsName GhcRn
forall p. Name -> HsName p
hsName 'P.IsoChecker) [HsExpr GhcRn -> HsExpr GhcRn
mkFun HsExpr GhcRn
l, HsExpr GhcRn -> HsExpr GhcRn
mkFun HsExpr GhcRn
r]
    mkFun :: HsExpr GhcRn -> HsExpr GhcRn
mkFun HsExpr GhcRn
f = HsExpr GhcRn -> [HsExpr GhcRn] -> HsExpr GhcRn
forall p. HsExpr p -> [HsExpr p] -> HsExpr p
hsExprApps (HsName GhcRn -> HsExpr GhcRn
forall p. HsName p -> HsExpr p
hsExprCon (HsName GhcRn -> HsExpr GhcRn) -> HsName GhcRn -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ Name -> HsName GhcRn
forall p. Name -> HsName p
hsName 'P.Fun) [Text -> HsExpr GhcRn
forall p. Text -> HsExpr p
hsExprLitString (Text -> HsExpr GhcRn) -> Text -> HsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ HsExpr GhcRn -> Text
renderHsExpr HsExpr GhcRn
f, HsExpr GhcRn
f]