{-# 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 _ =
False
instance QShow U1 where
qshowsPrec_ _ _ U1 =
id
qshowsNullary _ =
True
instance Show c => QShow (K1 i c) where
qshowsPrec_ _ n (K1 a) =
showsPrec n a
instance (QShow a, Constructor c) => QShow (M1 C c a) where
qshowsPrec_ _ n c@(M1 x) =
let
fixity =
conFixity c
t =
case fixity of
Prefix ->
ConPrefix
Infix _ _ ->
ConInfix $ conName c
in
case fixity of
Prefix ->
showParen (n > appPrec && not (qshowsNullary x)) $
showString (conName c) .
if qshowsNullary x then id else showChar ' ' .
qshowsPrec_ t appPrec1 x
Infix _ m ->
showParen (n > m) $ qshowsPrec_ t (m+1) x
instance QShow a => QShow (M1 S s a) where
qshowsPrec_ t n (M1 x) =
qshowsPrec_ t n x
qshowsNullary (M1 x) =
qshowsNullary x
instance QShow a => QShow (M1 D d a) where
qshowsPrec_ t n (M1 x) =
qshowsPrec_ t n x
instance (QShow a, QShow b) => QShow (a :+: b) where
qshowsPrec_ t n = \case
L1 x ->
qshowsPrec_ t n x
R1 x ->
qshowsPrec_ t n x
instance (QShow a, QShow b) => QShow (a :*: b) where
qshowsPrec_ t n (a :*: b) =
case t of
ConPrefix ->
qshowsPrec_ t n a .
showChar ' ' .
qshowsPrec_ t n b
ConInfix s ->
let
isInfixTypeCon = \case
':':_ ->
True
_ ->
False
showBacktick =
if isInfixTypeCon s then
id
else
showChar '`'
in
qshowsPrec_ t n a .
showChar ' ' .
showBacktick .
showString s .
showBacktick .
showChar ' ' .
qshowsPrec_ t n b
class QRead f where
qreadPrec_ :: ConType -> ReadPrec (f a)
qreadNullary :: Proxy f -> Bool
qreadNullary _ =
False
instance QRead U1 where
qreadPrec_ _ =
pure U1
qreadNullary _ =
True
instance Read c => QRead (K1 i c) where
qreadPrec_ _ =
K1 <$> Read.readPrec
instance (QRead a, Constructor c) => QRead (M1 C c a) where
qreadPrec_ _ =
let
proxy =
Proxy @(M1 C c a)
con =
undefined :: M1 C c a p
in
Read.parens $
case conFixity con of
Prefix ->
if qreadNullary proxy then do
Read.expectP (Lex.Ident (conName con))
M1 <$> ReadPrec.step (qreadPrec_ ConPrefix)
else
ReadPrec.prec appPrec $ do
Read.expectP (Lex.Ident (conName con))
M1 <$> ReadPrec.step (qreadPrec_ ConPrefix)
Infix _ m ->
ReadPrec.prec m $
M1 <$> ReadPrec.step (qreadPrec_ (ConInfix (conName con)))
instance QRead a => QRead (M1 S s a) where
qreadPrec_ t =
M1 <$> qreadPrec_ t
qreadNullary x =
qreadNullary x
instance QRead a => QRead (M1 D d a) where
qreadPrec_ t =
M1 <$> qreadPrec_ t
instance (QRead a, QRead b) => QRead (a :+: b) where
qreadPrec_ t =
(L1 <$> qreadPrec_ t)
ReadPrec.+++
(R1 <$> qreadPrec_ t)
instance (QRead a, QRead b) => QRead (a :*: b) where
qreadPrec_ t =
Read.parens $
case t of
ConPrefix ->
(:*:)
<$> qreadPrec_ t
<*> qreadPrec_ t
ConInfix s ->
(:*:)
<$> qreadPrec_ t <* expectInfix s
<*> qreadPrec_ t
expectInfix :: String -> ReadPrec ()
expectInfix = \case
xs@(':':_) ->
Read.expectP (Lex.Symbol xs)
xs -> do
Read.expectP (Lex.Punc "`")
Read.expectP (Lex.Ident xs)
Read.expectP (Lex.Punc "`")