{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Codec.CBOR.Cuddle.Comments (
  HasComment (..),
  CollectComments (..),
  hasComment,
  (//-),
  (<*!),
  (!*>),
  WithComment (..),
  (!$>),
  Comment (..),
  unComment,
  withComment,
) where

import Data.ByteString (ByteString)
import Data.Default.Class (Default (..))
import Data.Hashable (Hashable)
import Data.List.NonEmpty (NonEmpty (..))
import Data.String (IsString (..))
import Data.Text qualified as T
import Data.TreeDiff (ToExpr)
import Data.Word (Word16, Word32, Word64, Word8)
import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), V1, (:*:) (..), (:+:) (..))
import Optics.Core (Lens', lens, view, (%~), (&), (.~), (^.))

newtype Comment = Comment T.Text
  deriving (Comment -> Comment -> Bool
(Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool) -> Eq Comment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Comment -> Comment -> Bool
== :: Comment -> Comment -> Bool
$c/= :: Comment -> Comment -> Bool
/= :: Comment -> Comment -> Bool
Eq, Eq Comment
Eq Comment =>
(Comment -> Comment -> Ordering)
-> (Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool)
-> (Comment -> Comment -> Comment)
-> (Comment -> Comment -> Comment)
-> Ord Comment
Comment -> Comment -> Bool
Comment -> Comment -> Ordering
Comment -> Comment -> Comment
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Comment -> Comment -> Ordering
compare :: Comment -> Comment -> Ordering
$c< :: Comment -> Comment -> Bool
< :: Comment -> Comment -> Bool
$c<= :: Comment -> Comment -> Bool
<= :: Comment -> Comment -> Bool
$c> :: Comment -> Comment -> Bool
> :: Comment -> Comment -> Bool
$c>= :: Comment -> Comment -> Bool
>= :: Comment -> Comment -> Bool
$cmax :: Comment -> Comment -> Comment
max :: Comment -> Comment -> Comment
$cmin :: Comment -> Comment -> Comment
min :: Comment -> Comment -> Comment
Ord, (forall x. Comment -> Rep Comment x)
-> (forall x. Rep Comment x -> Comment) -> Generic Comment
forall x. Rep Comment x -> Comment
forall x. Comment -> Rep Comment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Comment -> Rep Comment x
from :: forall x. Comment -> Rep Comment x
$cto :: forall x. Rep Comment x -> Comment
to :: forall x. Rep Comment x -> Comment
Generic, Int -> Comment -> ShowS
[Comment] -> ShowS
Comment -> String
(Int -> Comment -> ShowS)
-> (Comment -> String) -> ([Comment] -> ShowS) -> Show Comment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Comment -> ShowS
showsPrec :: Int -> Comment -> ShowS
$cshow :: Comment -> String
show :: Comment -> String
$cshowList :: [Comment] -> ShowS
showList :: [Comment] -> ShowS
Show)
  deriving newtype (Semigroup Comment
Comment
Semigroup Comment =>
Comment
-> (Comment -> Comment -> Comment)
-> ([Comment] -> Comment)
-> Monoid Comment
[Comment] -> Comment
Comment -> Comment -> Comment
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Comment
mempty :: Comment
$cmappend :: Comment -> Comment -> Comment
mappend :: Comment -> Comment -> Comment
$cmconcat :: [Comment] -> Comment
mconcat :: [Comment] -> Comment
Monoid)
  deriving anyclass ([Comment] -> Expr
Comment -> Expr
(Comment -> Expr) -> ([Comment] -> Expr) -> ToExpr Comment
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: Comment -> Expr
toExpr :: Comment -> Expr
$clistToExpr :: [Comment] -> Expr
listToExpr :: [Comment] -> Expr
ToExpr, Eq Comment
Eq Comment =>
(Int -> Comment -> Int) -> (Comment -> Int) -> Hashable Comment
Int -> Comment -> Int
Comment -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Comment -> Int
hashWithSalt :: Int -> Comment -> Int
$chash :: Comment -> Int
hash :: Comment -> Int
Hashable)

instance Semigroup Comment where
  Comment Text
"" <> :: Comment -> Comment -> Comment
<> Comment
x = Comment
x
  Comment
x <> Comment Text
"" = Comment
x
  Comment Text
x <> Comment Text
y = Text -> Comment
Comment (Text -> Comment) -> Text -> Comment
forall a b. (a -> b) -> a -> b
$ Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y

unComment :: Comment -> [T.Text]
unComment :: Comment -> [Text]
unComment (Comment Text
c) = Text -> [Text]
T.lines Text
c

instance Default Comment where def :: Comment
def = Comment
forall a. Monoid a => a
mempty

class HasComment a where
  commentL :: Lens' a Comment

class GCollectComments f where
  collectCommentsG :: f a -> [Comment]

instance GCollectComments V1 where
  collectCommentsG :: forall (a :: k). V1 a -> [Comment]
collectCommentsG = \case {}

instance GCollectComments U1 where
  collectCommentsG :: forall (a :: k). U1 a -> [Comment]
collectCommentsG U1 a
U1 = []

instance
  ( GCollectComments a
  , GCollectComments b
  ) =>
  GCollectComments (a :+: b)
  where
  collectCommentsG :: forall (a :: k). (:+:) a b a -> [Comment]
collectCommentsG (L1 a a
x) = a a -> [Comment]
forall (a :: k). a a -> [Comment]
forall {k} (f :: k -> *) (a :: k).
GCollectComments f =>
f a -> [Comment]
collectCommentsG a a
x
  collectCommentsG (R1 b a
x) = b a -> [Comment]
forall (a :: k). b a -> [Comment]
forall {k} (f :: k -> *) (a :: k).
GCollectComments f =>
f a -> [Comment]
collectCommentsG b a
x

instance
  ( GCollectComments a
  , GCollectComments b
  ) =>
  GCollectComments (a :*: b)
  where
  collectCommentsG :: forall (a :: k). (:*:) a b a -> [Comment]
collectCommentsG (a a
a :*: b a
b) = a a -> [Comment]
forall (a :: k). a a -> [Comment]
forall {k} (f :: k -> *) (a :: k).
GCollectComments f =>
f a -> [Comment]
collectCommentsG a a
a [Comment] -> [Comment] -> [Comment]
forall a. Semigroup a => a -> a -> a
<> b a -> [Comment]
forall (a :: k). b a -> [Comment]
forall {k} (f :: k -> *) (a :: k).
GCollectComments f =>
f a -> [Comment]
collectCommentsG b a
b

instance CollectComments a => GCollectComments (K1 s a) where
  collectCommentsG :: forall (a :: k). K1 s a a -> [Comment]
collectCommentsG (K1 a
x) = a -> [Comment]
forall a. CollectComments a => a -> [Comment]
collectComments a
x

instance GCollectComments a => GCollectComments (M1 i c a) where
  collectCommentsG :: forall (a :: k). M1 i c a a -> [Comment]
collectCommentsG (M1 a a
x) = a a -> [Comment]
forall (a :: k). a a -> [Comment]
forall {k} (f :: k -> *) (a :: k).
GCollectComments f =>
f a -> [Comment]
collectCommentsG a a
x

class CollectComments a where
  collectComments :: a -> [Comment]
  default collectComments :: (Generic a, GCollectComments (Rep a)) => a -> [Comment]
  collectComments = Rep a Any -> [Comment]
forall a. Rep a a -> [Comment]
forall {k} (f :: k -> *) (a :: k).
GCollectComments f =>
f a -> [Comment]
collectCommentsG (Rep a Any -> [Comment]) -> (a -> Rep a Any) -> a -> [Comment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

instance CollectComments a => CollectComments (Maybe a) where
  collectComments :: Maybe a -> [Comment]
collectComments Maybe a
Nothing = []
  collectComments (Just a
x) = a -> [Comment]
forall a. CollectComments a => a -> [Comment]
collectComments a
x

instance CollectComments a => CollectComments [a]

instance CollectComments a => CollectComments (NonEmpty a)

instance CollectComments Word8 where collectComments :: Word8 -> [Comment]
collectComments = Word8 -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments Word16 where collectComments :: Word16 -> [Comment]
collectComments = Word16 -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments Word32 where collectComments :: Word32 -> [Comment]
collectComments = Word32 -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments Word64 where collectComments :: Word64 -> [Comment]
collectComments = Word64 -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments Integer where collectComments :: Integer -> [Comment]
collectComments = Integer -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments Float where collectComments :: Float -> [Comment]
collectComments = Float -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments Double where collectComments :: Double -> [Comment]
collectComments = Double -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments T.Text where collectComments :: Text -> [Comment]
collectComments = Text -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments ByteString where collectComments :: ByteString -> [Comment]
collectComments = ByteString -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments Bool where collectComments :: Bool -> [Comment]
collectComments = Bool -> [Comment]
forall a. Monoid a => a
mempty

instance CollectComments Comment where
  collectComments :: Comment -> [Comment]
collectComments Comment
x = [Comment
x]

hasComment :: HasComment a => a -> Bool
hasComment :: forall a. HasComment a => a -> Bool
hasComment = (Comment -> Comment -> Bool
forall a. Eq a => a -> a -> Bool
/= Comment
forall a. Monoid a => a
mempty) (Comment -> Bool) -> (a -> Comment) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Lens NoIx a Comment -> a -> Comment
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx a Comment
forall a. HasComment a => Lens' a Comment
commentL

-- | This operator is used to attach comments to terms. It will not overwrite
-- any comments that are already present, but will add the new comments on a
-- new line
-- ```
-- arr [0, 1] //- "This is an array with two values"
-- ```
(//-) :: HasComment a => a -> Comment -> a
a
x //- :: forall a. HasComment a => a -> Comment -> a
//- Comment
c = a
x a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
& Lens' a Comment
forall a. HasComment a => Lens' a Comment
commentL Lens' a Comment -> (Comment -> Comment) -> a -> a
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
%~ (Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
c)

infixr 0 //-

-- | This operator will parse the values from left to right and then append the
-- parsed comment on the right to the parsed value on the left.
(<*!) :: (HasComment a, Applicative m) => m a -> m Comment -> m a
<*! :: forall a (m :: * -> *).
(HasComment a, Applicative m) =>
m a -> m Comment -> m a
(<*!) m a
x m Comment
c = a -> Comment -> a
forall a. HasComment a => a -> Comment -> a
(//-) (a -> Comment -> a) -> m a -> m (Comment -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
x m (Comment -> a) -> m Comment -> m a
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Comment
c

-- | This operator will parse the values from left to right and then append the
-- parsed comment on the left to the parsed value on the right.
(!*>) :: (HasComment a, Applicative m) => m Comment -> m a -> m a
!*> :: forall a (m :: * -> *).
(HasComment a, Applicative m) =>
m Comment -> m a -> m a
(!*>) m Comment
c m a
x = (a -> Comment -> a) -> Comment -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Comment -> a
forall a. HasComment a => a -> Comment -> a
(//-) (Comment -> a -> a) -> m Comment -> m (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Comment
c m (a -> a) -> m a -> m a
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
x

data WithComment a = WithComment
  { forall a. WithComment a -> Comment
unWithComment :: Comment
  , forall a. WithComment a -> a
stripComment :: a
  }
  deriving ((forall a b. (a -> b) -> WithComment a -> WithComment b)
-> (forall a b. a -> WithComment b -> WithComment a)
-> Functor WithComment
forall a b. a -> WithComment b -> WithComment a
forall a b. (a -> b) -> WithComment a -> WithComment b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> WithComment a -> WithComment b
fmap :: forall a b. (a -> b) -> WithComment a -> WithComment b
$c<$ :: forall a b. a -> WithComment b -> WithComment a
<$ :: forall a b. a -> WithComment b -> WithComment a
Functor)

instance Applicative WithComment where
  pure :: forall a. a -> WithComment a
pure = a -> WithComment a
forall a. a -> WithComment a
withComment
  WithComment Comment
cmt a -> b
f <*> :: forall a b. WithComment (a -> b) -> WithComment a -> WithComment b
<*> WithComment Comment
cmt' a
x = Comment -> b -> WithComment b
forall a. Comment -> a -> WithComment a
WithComment (Comment
cmt Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
cmt') (b -> WithComment b) -> b -> WithComment b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x

instance Monad WithComment where
  WithComment Comment
cmt a
x >>= :: forall a b. WithComment a -> (a -> WithComment b) -> WithComment b
>>= a -> WithComment b
f = let WithComment Comment
cmt' b
y = a -> WithComment b
f a
x in Comment -> b -> WithComment b
forall a. Comment -> a -> WithComment a
WithComment (Comment
cmt Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
cmt') b
y

instance HasComment (WithComment a) where
  commentL :: Lens' (WithComment a) Comment
commentL = (WithComment a -> Comment)
-> (WithComment a -> Comment -> WithComment a)
-> Lens' (WithComment a) Comment
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(WithComment Comment
x a
_) -> Comment
x) (\(WithComment Comment
_ a
b) Comment
x -> Comment -> a -> WithComment a
forall a. Comment -> a -> WithComment a
WithComment Comment
x a
b)

instance CollectComments a => CollectComments (WithComment a) where
  collectComments :: WithComment a -> [Comment]
collectComments (WithComment Comment
c a
x) = Comment
c Comment -> [Comment] -> [Comment]
forall a. a -> [a] -> [a]
: a -> [Comment]
forall a. CollectComments a => a -> [Comment]
collectComments a
x

withComment :: a -> WithComment a
withComment :: forall a. a -> WithComment a
withComment = Comment -> a -> WithComment a
forall a. Comment -> a -> WithComment a
WithComment Comment
forall a. Monoid a => a
mempty

-- | This operator maps a function over a functor containing a `WithComment` and
-- applies the comment within to the output of the applied function.
-- ```
-- (\x -> LInt x "a") !$> WithComment "b" (1 :: Integer) == Literal (LInt 1) "a\nb"
-- ```
(!$>) :: (HasComment b, Functor f) => (a -> b) -> f (WithComment a) -> f b
a -> b
f !$> :: forall b (f :: * -> *) a.
(HasComment b, Functor f) =>
(a -> b) -> f (WithComment a) -> f b
!$> f (WithComment a)
wc = (WithComment a -> b) -> f (WithComment a) -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(WithComment Comment
c a
x) -> a -> b
f a
x b -> Comment -> b
forall a. HasComment a => a -> Comment -> a
//- Comment
c) f (WithComment a)
wc

instance HasComment a => HasComment (NonEmpty a) where
  commentL :: Lens' (NonEmpty a) Comment
commentL = (NonEmpty a -> Comment)
-> (NonEmpty a -> Comment -> NonEmpty a)
-> Lens' (NonEmpty a) Comment
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(a
x :| [a]
_) -> a
x a -> Optic' A_Lens NoIx a Comment -> Comment
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx a Comment
forall a. HasComment a => Lens' a Comment
commentL) (\(a
x :| [a]
xs) Comment
y -> (a
x a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
& Optic' A_Lens NoIx a Comment
forall a. HasComment a => Lens' a Comment
commentL Optic' A_Lens NoIx a Comment -> Comment -> a -> a
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Comment
y) a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

instance HasComment Comment where
  commentL :: Lens' Comment Comment
commentL = (Comment -> Comment)
-> (Comment -> Comment -> Comment) -> Lens' Comment Comment
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Comment -> Comment
forall a. a -> a
id Comment -> Comment -> Comment
forall a b. a -> b -> a
const

instance IsString Comment where
  fromString :: String -> Comment
fromString String
s = Text -> Comment
Comment (Text -> Comment) -> Text -> Comment
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s