{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :   Grisette.Internal.TH.Derivation.ShowPPrintCommon
-- Copyright   :   (c) Sirui Lu 2024
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
module Grisette.Internal.TH.Derivation.ShowPPrintCommon (showPrintFieldFunExp) where

import qualified Data.Map as M
import qualified Data.Set as S
import Grisette.Internal.TH.Derivation.UnaryOpCommon (FieldFunExp)
import Language.Haskell.TH (Name, Type (AppT, VarT), varE)
import Language.Haskell.TH.Datatype (TypeSubstitution (freeVariables))

-- | Common 'FieldFunExp' for 'Show' and 'Grisette.Core.PPrint' on a GADT.
showPrintFieldFunExp :: [Name] -> [Name] -> FieldFunExp
showPrintFieldFunExp :: [Name] -> [Name] -> FieldFunExp
showPrintFieldFunExp [Name]
precNames [Name]
listNames Map Name Name
argToFunPat Map Name [Name]
liftedExps = Type -> Q Exp
forall {m :: * -> *}. (MonadFail m, Quote m) => Type -> m Exp
go
  where
    allArgNames :: Set Name
allArgNames = Map Name Name -> Set Name
forall k a. Map k a -> Set k
M.keysSet Map Name Name
argToFunPat
    typeHasNoArg :: a -> Bool
typeHasNoArg a
ty =
      [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [a
ty])
        Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set Name
allArgNames
        Set Name -> Set Name -> Bool
forall a. Eq a => a -> a -> Bool
== Set Name
forall a. Set a
S.empty
    goLst :: Type -> m Exp
goLst Type
ty = do
      let fun0 :: m Exp
fun0 = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
listNames)
          fun1 :: Type -> m Exp
fun1 Type
b = [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
listNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) $(Type -> m Exp
go Type
b) $(Type -> m Exp
goLst Type
b)|]
          fun2 :: Type -> Type -> m Exp
fun2 Type
b Type
c =
            [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
listNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
2) $(Type -> m Exp
go Type
b) $(Type -> m Exp
goLst Type
b) $(Type -> m Exp
go Type
c) $(Type -> m Exp
goLst Type
c)|]
      case Type
ty of
        AppT (AppT (VarT Name
_) Type
b) Type
c -> Type -> Type -> m Exp
fun2 Type
b Type
c
        AppT (VarT Name
_) Type
b -> Type -> m Exp
fun1 Type
b
        Type
_ | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
ty -> m Exp
fun0
        AppT Type
a Type
b | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a -> Type -> m Exp
fun1 Type
b
        AppT (AppT Type
a Type
b) Type
c | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a -> Type -> Type -> m Exp
fun2 Type
b Type
c
        VarT Name
nm -> case Name -> Map Name [Name] -> Maybe [Name]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
nm Map Name [Name]
liftedExps of
          Just [Name
p] -> Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p
          Maybe [Name]
_ -> String -> m Exp
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
ty
        Type
_ -> String -> m Exp
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
ty
    go :: Type -> m Exp
go Type
ty = do
      let fun0 :: m Exp
fun0 = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
precNames)
          fun1 :: Type -> m Exp
fun1 Type
b = [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
precNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) $(Type -> m Exp
go Type
b) $(Type -> m Exp
goLst Type
b)|]
          fun2 :: Type -> Type -> m Exp
fun2 Type
b Type
c =
            [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
precNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
2) $(Type -> m Exp
go Type
b) $(Type -> m Exp
goLst Type
b) $(Type -> m Exp
go Type
c) $(Type -> m Exp
goLst Type
c)|]
      case Type
ty of
        AppT (AppT (VarT Name
_) Type
b) Type
c -> Type -> Type -> m Exp
fun2 Type
b Type
c
        AppT (VarT Name
_) Type
b -> Type -> m Exp
fun1 Type
b
        Type
_ | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
ty -> m Exp
fun0
        AppT Type
a Type
b | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a -> Type -> m Exp
fun1 Type
b
        AppT (AppT Type
a Type
b) Type
c | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a -> Type -> Type -> m Exp
fun2 Type
b Type
c
        VarT Name
nm -> case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
nm Map Name Name
argToFunPat of
          Just Name
pname -> Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pname
          Maybe Name
_ -> String -> m Exp
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
ty
        Type
_ -> String -> m Exp
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
ty