-- Some Parts: Copyright 2010, Universiteit Utrecht, All Rights Reserved.
-- License: BSD3

{-# 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

--------------------------------------------------------------
-- ConType

data ConType =
    ConPrefix
  | ConInfix String

--------------------------------------------------------------
-- QShow

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

------------------------------------------------------------------------
-- QRead

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
"`")