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

module Skeletest.Internal.PreprocessorPlugin (
  plugin,
) where

import Data.Functor.Const (Const (..))
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text qualified as Text
import Skeletest.Internal.Constants (mainFileSpecsListIdentifier)
import Skeletest.Internal.Error (skeletestPluginError)
import Skeletest.Internal.GHC
import Skeletest.Internal.Paths (setOriginalDirectory)
import Skeletest.Internal.Predicate qualified as P
import Skeletest.Internal.Preprocessor qualified as Preprocessor
import Skeletest.Internal.Utils.HList (HList (..))
import Skeletest.Internal.Utils.Text (showT)
import Skeletest.Main qualified as Main
import Skeletest.Plugin qualified as Plugin
import Skeletest.Prop.Internal qualified as P

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

-- | 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 :: [CommandLineOption] -> Text -> ParsedModule -> ParsedModule
modifyParsed = \[CommandLineOption]
opts Text
modName ParsedModule
modl ->
          let options :: Options
options = [CommandLineOption] -> Options
decodeOptions [CommandLineOption]
opts
           in if Text
modName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Options
options.mainModuleName
                then Options -> ParsedModule -> ParsedModule
transformMainModule Options
options ParsedModule
modl
                else ParsedModule
modl
      , onRename :: [CommandLineOption] -> Ctx -> Text -> HsExpr GhcRn -> HsExpr GhcRn
onRename = \[CommandLineOption]
_ 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
      }
 where
  decodeOptions :: [CommandLineOption] -> Options
decodeOptions =
    (Text -> Options)
-> (Options -> Options) -> Either Text Options -> Options
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CommandLineOption -> Options
forall a. HasCallStack => CommandLineOption -> a
error (CommandLineOption -> Options)
-> (Text -> CommandLineOption) -> Text -> Options
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CommandLineOption
Text.unpack) Options -> Options
forall a. a -> a
id (Either Text Options -> Options)
-> ([CommandLineOption] -> Either Text Options)
-> [CommandLineOption]
-> Options
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      [CommandLineOption
opts] -> Text -> Either Text Options
Preprocessor.decodeOptions (CommandLineOption -> Text
Text.pack CommandLineOption
opts)
      [CommandLineOption]
_ -> Text -> Either Text Options
forall a b. a -> Either a b
Left Text
""

-- | Add 'main' function.
transformMainModule :: Preprocessor.Options -> ParsedModule -> ParsedModule
transformMainModule :: Options -> ParsedModule -> ParsedModule
transformMainModule Options
options ParsedModule
modl =
  ParsedModule
modl
    { moduleFuncs = (hsVarName options.mainFuncName, Just mainFun) : modl.moduleFuncs
    }
 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
modl.moduleFuncs
      , 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
forall p. [HsExpr p] -> HsExpr p
sequenceExpr
            [ HsExpr GhcPs
forall {p}. HsExpr p
setOriginalDirectoryExpr
            , HsExpr GhcPs
runSkeletestExpr
            ]
      }
  sequenceExpr :: [HsExpr p] -> HsExpr p
sequenceExpr [HsExpr p]
exprs = 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 'sequence_) [[HsExpr p] -> HsExpr p
forall p. [HsExpr p] -> HsExpr p
hsExprList [HsExpr p]
exprs]
  setOriginalDirectoryExpr :: HsExpr p
setOriginalDirectoryExpr =
    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 'setOriginalDirectory) ([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)
-> (CommandLineOption -> Text) -> CommandLineOption -> HsExpr p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> Text
Text.pack (CommandLineOption -> HsExpr p) -> CommandLineOption -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Options
options.originalDirectory]
  runSkeletestExpr :: HsExpr GhcPs
runSkeletestExpr =
    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 -> CommandLineOption -> HsName GhcPs
forall p. Name -> CommandLineOption -> HsName p
hsFieldName 'Plugin.Plugin CommandLineOption
"cliFlags", HsExpr GhcPs
cliFlagsExpr)
              , (Name -> CommandLineOption -> HsName GhcPs
forall p. Name -> CommandLineOption -> HsName p
hsFieldName 'Plugin.Plugin CommandLineOption
"snapshotRenderers", HsExpr GhcPs
snapshotRenderersExpr)
              , (Name -> CommandLineOption -> HsName GhcPs
forall p. Name -> CommandLineOption -> HsName p
hsFieldName 'Plugin.Plugin CommandLineOption
"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 (P.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
ctx.matchesName (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 ->
          Maybe SrcSpan -> CommandLineOption -> HsExpr GhcRn
forall a. Maybe SrcSpan -> CommandLineOption -> a
skeletestPluginError (HsExpr GhcRn -> Maybe SrcSpan
forall p. HsExpr p -> Maybe SrcSpan
getLoc HsExpr GhcRn
e) CommandLineOption
"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 ->
          Maybe SrcSpan -> CommandLineOption -> HsExpr GhcRn
forall a. Maybe SrcSpan -> CommandLineOption -> a
skeletestPluginError (HsExpr GhcRn -> Maybe SrcSpan
forall p. HsExpr p -> Maybe SrcSpan
getLoc HsExpr GhcRn
e) CommandLineOption
"P.con must be applied to exactly one argument"
    HsExprData GhcRn
_ -> HsExpr GhcRn
e
 where
  isCon :: HsName GhcRn -> Bool
isCon = Ctx
ctx.matchesName (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
_ -> Maybe SrcSpan -> CommandLineOption -> HsExpr p
forall a. Maybe SrcSpan -> CommandLineOption -> a
skeletestPluginError (HsExpr GhcRn -> Maybe SrcSpan
forall p. HsExpr p -> Maybe SrcSpan
getLoc HsExpr GhcRn
e) CommandLineOption
"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
<> a -> Text
forall a. Show a => a -> Text
showT 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
ctx.matchesName (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]