{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
module Quiet.Internal (
ConType(..)
, QShow(..)
, QRead(..)
, expectInfix
) where
import Data.Proxy (Proxy(..))
import GHC.Generics ((:*:)(..), (:+:)(..))
import GHC.Generics (Constructor(..))
import GHC.Generics (Fixity(..))
import GHC.Generics (U1(..), K1(..), M1(..), D, C, S)
import qualified GHC.Read as Read
import GHC.Show (appPrec, appPrec1, showChar, showParen)
import Text.ParserCombinators.ReadPrec (ReadPrec)
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified Text.Read.Lex as Lex
data ConType =
ConPrefix
| ConInfix String
class QShow f where
qshowsPrec_ :: ConType -> Int -> f a -> ShowS
qshowsNullary :: f a -> Bool
qshowsNullary f a
_ =
Bool
False
instance QShow U1 where
qshowsPrec_ :: ConType -> Int -> U1 a -> ShowS
qshowsPrec_ ConType
_ Int
_ U1 a
U1 =
ShowS
forall a. a -> a
id
qshowsNullary :: U1 a -> Bool
qshowsNullary U1 a
_ =
Bool
True
instance Show c => QShow (K1 i c) where
qshowsPrec_ :: ConType -> Int -> K1 i c a -> ShowS
qshowsPrec_ ConType
_ Int
n (K1 c
a) =
Int -> c -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
n c
a
instance (QShow a, Constructor c) => QShow (M1 C c a) where
qshowsPrec_ :: ConType -> Int -> M1 C c a a -> ShowS
qshowsPrec_ ConType
_ Int
n c :: M1 C c a a
c@(M1 a a
x) =
let
fixity :: Fixity
fixity =
M1 C c a a -> Fixity
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity M1 C c a a
c
t :: ConType
t =
case Fixity
fixity of
Fixity
Prefix ->
ConType
ConPrefix
Infix Associativity
_ Int
_ ->
String -> ConType
ConInfix (String -> ConType) -> String -> ConType
forall a b. (a -> b) -> a -> b
$ M1 C c a a -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c a a
c
in
case Fixity
fixity of
Fixity
Prefix ->
Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec Bool -> Bool -> Bool
&& Bool -> Bool
not (a a -> Bool
forall (f :: * -> *) a. QShow f => f a -> Bool
qshowsNullary a a
x)) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
String -> ShowS
showString (M1 C c a a -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c a a
c) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
if a a -> Bool
forall (f :: * -> *) a. QShow f => f a -> Bool
qshowsNullary a a
x then ShowS
forall a. a -> a
id else Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ConType -> Int -> a a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t Int
appPrec1 a a
x
Infix Associativity
_ Int
m ->
Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
m) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ConType -> Int -> a a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) a a
x
instance QShow a => QShow (M1 S s a) where
qshowsPrec_ :: ConType -> Int -> M1 S s a a -> ShowS
qshowsPrec_ ConType
t Int
n (M1 a a
x) =
ConType -> Int -> a a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t Int
n a a
x
qshowsNullary :: M1 S s a a -> Bool
qshowsNullary (M1 a a
x) =
a a -> Bool
forall (f :: * -> *) a. QShow f => f a -> Bool
qshowsNullary a a
x
instance QShow a => QShow (M1 D d a) where
qshowsPrec_ :: ConType -> Int -> M1 D d a a -> ShowS
qshowsPrec_ ConType
t Int
n (M1 a a
x) =
ConType -> Int -> a a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t Int
n a a
x
instance (QShow a, QShow b) => QShow (a :+: b) where
qshowsPrec_ :: ConType -> Int -> (:+:) a b a -> ShowS
qshowsPrec_ ConType
t Int
n = \case
L1 a a
x ->
ConType -> Int -> a a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t Int
n a a
x
R1 b a
x ->
ConType -> Int -> b a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t Int
n b a
x
instance (QShow a, QShow b) => QShow (a :*: b) where
qshowsPrec_ :: ConType -> Int -> (:*:) a b a -> ShowS
qshowsPrec_ ConType
t Int
n (a a
a :*: b a
b) =
case ConType
t of
ConType
ConPrefix ->
ConType -> Int -> a a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t Int
n a a
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ConType -> Int -> b a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t Int
n b a
b
ConInfix String
s ->
let
isInfixTypeCon :: String -> Bool
isInfixTypeCon = \case
Char
':':String
_ ->
Bool
True
String
_ ->
Bool
False
showBacktick :: ShowS
showBacktick =
if String -> Bool
isInfixTypeCon String
s then
ShowS
forall a. a -> a
id
else
Char -> ShowS
showChar Char
'`'
in
ConType -> Int -> a a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t Int
n a a
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ShowS
showBacktick ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ShowS
showBacktick ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ConType -> Int -> b a -> ShowS
forall (f :: * -> *) a. QShow f => ConType -> Int -> f a -> ShowS
qshowsPrec_ ConType
t Int
n b a
b
class QRead f where
qreadPrec_ :: ConType -> ReadPrec (f a)
qreadNullary :: Proxy f -> Bool
qreadNullary Proxy f
_ =
Bool
False
instance QRead U1 where
qreadPrec_ :: ConType -> ReadPrec (U1 a)
qreadPrec_ ConType
_ =
U1 a -> ReadPrec (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
qreadNullary :: Proxy U1 -> Bool
qreadNullary Proxy U1
_ =
Bool
True
instance Read c => QRead (K1 i c) where
qreadPrec_ :: ConType -> ReadPrec (K1 i c a)
qreadPrec_ ConType
_ =
c -> K1 i c a
forall k i c (p :: k). c -> K1 i c p
K1 (c -> K1 i c a) -> ReadPrec c -> ReadPrec (K1 i c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec c
forall a. Read a => ReadPrec a
Read.readPrec
instance (QRead a, Constructor c) => QRead (M1 C c a) where
qreadPrec_ :: ConType -> ReadPrec (M1 C c a a)
qreadPrec_ ConType
_ =
let
proxy :: Proxy (M1 C c a)
proxy =
Proxy (M1 C c a)
forall k (t :: k). Proxy t
Proxy @(M1 C c a)
con :: M1 C c a p
con =
forall p. M1 C c a p
forall a. HasCallStack => a
undefined :: M1 C c a p
in
ReadPrec (M1 C c a a) -> ReadPrec (M1 C c a a)
forall a. ReadPrec a -> ReadPrec a
Read.parens (ReadPrec (M1 C c a a) -> ReadPrec (M1 C c a a))
-> ReadPrec (M1 C c a a) -> ReadPrec (M1 C c a a)
forall a b. (a -> b) -> a -> b
$
case M1 C c a Any -> Fixity
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity M1 C c a Any
forall p. M1 C c a p
con of
Fixity
Prefix ->
if Proxy (M1 C c a) -> Bool
forall (f :: * -> *). QRead f => Proxy f -> Bool
qreadNullary Proxy (M1 C c a)
proxy then do
Lexeme -> ReadPrec ()
Read.expectP (String -> Lexeme
Lex.Ident (M1 C c a Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c a Any
forall p. M1 C c a p
con))
a a -> M1 C c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 C c a a) -> ReadPrec (a a) -> ReadPrec (M1 C c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec (a a) -> ReadPrec (a a)
forall a. ReadPrec a -> ReadPrec a
ReadPrec.step (ConType -> ReadPrec (a a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
ConPrefix)
else
Int -> ReadPrec (M1 C c a a) -> ReadPrec (M1 C c a a)
forall a. Int -> ReadPrec a -> ReadPrec a
ReadPrec.prec Int
appPrec (ReadPrec (M1 C c a a) -> ReadPrec (M1 C c a a))
-> ReadPrec (M1 C c a a) -> ReadPrec (M1 C c a a)
forall a b. (a -> b) -> a -> b
$ do
Lexeme -> ReadPrec ()
Read.expectP (String -> Lexeme
Lex.Ident (M1 C c a Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c a Any
forall p. M1 C c a p
con))
a a -> M1 C c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 C c a a) -> ReadPrec (a a) -> ReadPrec (M1 C c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec (a a) -> ReadPrec (a a)
forall a. ReadPrec a -> ReadPrec a
ReadPrec.step (ConType -> ReadPrec (a a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
ConPrefix)
Infix Associativity
_ Int
m ->
Int -> ReadPrec (M1 C c a a) -> ReadPrec (M1 C c a a)
forall a. Int -> ReadPrec a -> ReadPrec a
ReadPrec.prec Int
m (ReadPrec (M1 C c a a) -> ReadPrec (M1 C c a a))
-> ReadPrec (M1 C c a a) -> ReadPrec (M1 C c a a)
forall a b. (a -> b) -> a -> b
$
a a -> M1 C c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 C c a a) -> ReadPrec (a a) -> ReadPrec (M1 C c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec (a a) -> ReadPrec (a a)
forall a. ReadPrec a -> ReadPrec a
ReadPrec.step (ConType -> ReadPrec (a a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ (String -> ConType
ConInfix (M1 C c a Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c a Any
forall p. M1 C c a p
con)))
instance QRead a => QRead (M1 S s a) where
qreadPrec_ :: ConType -> ReadPrec (M1 S s a a)
qreadPrec_ ConType
t =
a a -> M1 S s a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 S s a a) -> ReadPrec (a a) -> ReadPrec (M1 S s a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConType -> ReadPrec (a a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
t
qreadNullary :: Proxy (M1 S s a) -> Bool
qreadNullary Proxy (M1 S s a)
x =
Proxy (M1 S s a) -> Bool
forall (f :: * -> *). QRead f => Proxy f -> Bool
qreadNullary Proxy (M1 S s a)
x
instance QRead a => QRead (M1 D d a) where
qreadPrec_ :: ConType -> ReadPrec (M1 D d a a)
qreadPrec_ ConType
t =
a a -> M1 D d a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 D d a a) -> ReadPrec (a a) -> ReadPrec (M1 D d a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConType -> ReadPrec (a a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
t
instance (QRead a, QRead b) => QRead (a :+: b) where
qreadPrec_ :: ConType -> ReadPrec ((:+:) a b a)
qreadPrec_ ConType
t =
(a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a a -> (:+:) a b a) -> ReadPrec (a a) -> ReadPrec ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConType -> ReadPrec (a a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
t)
ReadPrec ((:+:) a b a)
-> ReadPrec ((:+:) a b a) -> ReadPrec ((:+:) a b a)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
ReadPrec.+++
(b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b a -> (:+:) a b a) -> ReadPrec (b a) -> ReadPrec ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConType -> ReadPrec (b a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
t)
instance (QRead a, QRead b) => QRead (a :*: b) where
qreadPrec_ :: ConType -> ReadPrec ((:*:) a b a)
qreadPrec_ ConType
t =
ReadPrec ((:*:) a b a) -> ReadPrec ((:*:) a b a)
forall a. ReadPrec a -> ReadPrec a
Read.parens (ReadPrec ((:*:) a b a) -> ReadPrec ((:*:) a b a))
-> ReadPrec ((:*:) a b a) -> ReadPrec ((:*:) a b a)
forall a b. (a -> b) -> a -> b
$
case ConType
t of
ConType
ConPrefix ->
a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
(a a -> b a -> (:*:) a b a)
-> ReadPrec (a a) -> ReadPrec (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConType -> ReadPrec (a a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
t
ReadPrec (b a -> (:*:) a b a)
-> ReadPrec (b a) -> ReadPrec ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConType -> ReadPrec (b a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
t
ConInfix String
s ->
a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
(a a -> b a -> (:*:) a b a)
-> ReadPrec (a a) -> ReadPrec (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConType -> ReadPrec (a a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
t ReadPrec (b a -> (:*:) a b a)
-> ReadPrec () -> ReadPrec (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> ReadPrec ()
expectInfix String
s
ReadPrec (b a -> (:*:) a b a)
-> ReadPrec (b a) -> ReadPrec ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConType -> ReadPrec (b a)
forall (f :: * -> *) a. QRead f => ConType -> ReadPrec (f a)
qreadPrec_ ConType
t
expectInfix :: String -> ReadPrec ()
expectInfix :: String -> ReadPrec ()
expectInfix = \case
xs :: String
xs@(Char
':':String
_) ->
Lexeme -> ReadPrec ()
Read.expectP (String -> Lexeme
Lex.Symbol String
xs)
String
xs -> do
Lexeme -> ReadPrec ()
Read.expectP (String -> Lexeme
Lex.Punc String
"`")
Lexeme -> ReadPrec ()
Read.expectP (String -> Lexeme
Lex.Ident String
xs)
Lexeme -> ReadPrec ()
Read.expectP (String -> Lexeme
Lex.Punc String
"`")