{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}

-- | The primitive parser combinators.

module Text.Cassette.Prim
  ( -- * Data types
    K7(..)
  , Tr
  , PP
  , PP0
    -- * Composition
  , (-->)
    -- * Extraction
  , parse
  , pretty
  , sscanf
  , sprintf
    -- * Primitive combinators
  , nothing
  , set
  , unset
  , string
  , satisfy
  , lookAhead
  , eof
  ) where

import Control.Category (Category(..))
import Data.List (stripPrefix)
import GHC.Stack (HasCallStack)
import Prelude hiding (flip, id, (.))
import Text.Cassette.Internal.Tr (Tr(..))
import Text.Cassette.Internal.Tr qualified as Tr

-- | A cassette consists of two tracks, represented by profunctors. The second
-- track has its polarities flipped relative to the first.
data K7 p a b = K7
  { forall (p :: * -> * -> *) a b. K7 p a b -> p a b
sideA :: p a b
  , forall (p :: * -> * -> *) a b.
K7 p a b -> forall t. p (a -> t) (b -> t)
sideB :: forall t. p (a -> t) (b -> t)
  }

instance (forall r r'. Semigroup (p r r')) => Semigroup (K7 p r r') where
  K7 p r r'
f forall t. p (r -> t) (r' -> t)
f' <> :: K7 p r r' -> K7 p r r' -> K7 p r r'
<> K7 p r r'
g forall t. p (r -> t) (r' -> t)
g' = p r r' -> (forall t. p (r -> t) (r' -> t)) -> K7 p r r'
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 (p r r'
f p r r' -> p r r' -> p r r'
forall a. Semigroup a => a -> a -> a
<> p r r'
g) (p (r -> t) (r' -> t)
forall t. p (r -> t) (r' -> t)
f' p (r -> t) (r' -> t)
-> p (r -> t) (r' -> t) -> p (r -> t) (r' -> t)
forall a. Semigroup a => a -> a -> a
<> p (r -> t) (r' -> t)
forall t. p (r -> t) (r' -> t)
g')

instance (forall r r'. Monoid (p r r')) => Monoid (K7 p r r') where
  mempty :: K7 p r r'
mempty = p r r' -> (forall t. p (r -> t) (r' -> t)) -> K7 p r r'
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 p r r'
forall a. Monoid a => a
mempty p (r -> t) (r' -> t)
forall t. p (r -> t) (r' -> t)
forall a. Monoid a => a
mempty

instance Category p => Category (K7 p) where
  id :: forall a. K7 p a a
id = p a a -> (forall t. p (a -> t) (a -> t)) -> K7 p a a
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 p a a
forall a. p a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id p (a -> t) (a -> t)
forall a. p a a
forall t. p (a -> t) (a -> t)
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  -- Irrefutable patterns to support definitions of combinators by coinduction.
  ~(K7 p b c
f forall t. p (b -> t) (c -> t)
f') . :: forall b c a. K7 p b c -> K7 p a b -> K7 p a c
. ~(K7 p a b
g forall t. p (a -> t) (b -> t)
g') = p a c -> (forall t. p (a -> t) (c -> t)) -> K7 p a c
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 (p b c
f p b c -> p a b -> p a c
forall b c a. p b c -> p a b -> p a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. p a b
g) (p (b -> t) (c -> t)
forall t. p (b -> t) (c -> t)
f' p (b -> t) (c -> t) -> p (a -> t) (b -> t) -> p (a -> t) (c -> t)
forall b c a. p b c -> p a b -> p a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. p (a -> t) (b -> t)
forall t. p (a -> t) (b -> t)
g')

infixr 9 -->

-- | A synonym to '(.)'
(-->) :: Category p => K7 p b c -> K7 p a b -> K7 p a c
--> :: forall (p :: * -> * -> *) b c a.
Category p =>
K7 p b c -> K7 p a b -> K7 p a c
(-->) = K7 p b c -> K7 p a b -> K7 p a c
forall b c a. K7 p b c -> K7 p a b -> K7 p a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)

-- | The type of cassettes with a string transformer on each side. The A-side
-- produces a value in addition to transforming the string, /i.e./ it is
-- a parser. The B-side consumes a value to transform the string, /i.e./ it is
-- a printer.
type PP a = forall r. K7 Tr r (a -> r)

-- | The type of cassettes only useful for their effect on the input or output
-- strings, but do not produce\/consume any value.
type PP0 = forall r. K7 Tr r r

-- | Extract the parser from a cassette.
parse :: PP a -> String -> Maybe a
parse :: forall a. PP a -> String -> Maybe a
parse (K7 Tr a (a -> a)
_ forall t. Tr (a -> t) ((a -> a) -> t)
f') String
s = Tr (a -> Maybe a) ((a -> a) -> Maybe a)
-> C (a -> Maybe a) -> C ((a -> a) -> Maybe a)
forall r r'. Tr r r' -> C r -> C r'
unTr Tr (a -> Maybe a) ((a -> a) -> Maybe a)
forall t. Tr (a -> t) ((a -> a) -> t)
f' (\String -> a -> Maybe a
_ String
_ a
x -> a -> Maybe a
forall a. a -> Maybe a
Just a
x) (\String
_ a -> a
_ -> Maybe a
forall a. Maybe a
Nothing) String
s a -> a
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | Flip the cassette around to extract the pretty printer.
pretty :: PP a -> a -> Maybe String
pretty :: forall a. PP a -> a -> Maybe String
pretty (K7 Tr (Maybe String) (a -> Maybe String)
f forall t. Tr (Maybe String -> t) ((a -> Maybe String) -> t)
_) = Tr (Maybe String) (a -> Maybe String)
-> C (Maybe String) -> C (a -> Maybe String)
forall r r'. Tr r r' -> C r -> C r'
unTr Tr (Maybe String) (a -> Maybe String)
f ((String -> Maybe String) -> C (Maybe String)
forall a b. a -> b -> a
const String -> Maybe String
forall a. a -> Maybe a
Just) (\String
_ a
_ -> Maybe String
forall a. Maybe a
Nothing) String
""

-- | An equivalent to @sscanf()@ in C: @'sscanf' fmt k s@ extracts data from
-- string @s@ according to format descriptor @fmt@ and hands the data to
-- continuation @k@.
--
-- >>> spec = satisfy (=='A') . satisfy (=='B') . satisfy (=='C')
-- >>> sscanf spec "ABC" (,,)
-- ('A','B','C')
sscanf :: HasCallStack => K7 Tr r r' -> String -> r' -> r
sscanf :: forall r r'. HasCallStack => K7 Tr r r' -> String -> r' -> r
sscanf (K7 Tr r r'
_ forall t. Tr (r -> t) (r' -> t)
f') = Tr (r -> r) (r' -> r) -> C (r -> r) -> C (r' -> r)
forall r r'. Tr r r' -> C r -> C r'
unTr Tr (r -> r) (r' -> r)
forall t. Tr (r -> t) (r' -> t)
f' (\String -> r -> r
_ String
_ -> r -> r
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id) (\String
_ r'
_ -> String -> r
forall a. HasCallStack => String -> a
error String
msg)
  where
    msg :: String
msg = String
"sscanf: formatting error"

-- | An equivalent to @sprintf()@ in C: @'sprintf' fmt@ returns a function that
-- returns a string and whose number of arguments depends on format descriptor
-- @fmt@.
--
-- >>> spec = satisfy (=='A') . satisfy (=='B') . satisfy (=='C')
-- >>> sprintf spec 'A' 'B' 'C'
-- "ABC"
sprintf :: HasCallStack => K7 Tr String r -> r
sprintf :: forall r. HasCallStack => K7 Tr String r -> r
sprintf (K7 Tr String r
f forall t. Tr (String -> t) (r -> t)
_) = Tr String r -> C String -> C r
forall r r'. Tr r r' -> C r -> C r'
unTr Tr String r
f (\String -> String
_ -> String -> String
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id) (\String
_ -> String -> r
forall a. HasCallStack => String -> a
error String
msg) String
""
  where
    msg :: String
msg = String
"sprintf: formatting error"

-- | Do nothing.
--
-- >>> pretty (set () nothing) ()
-- Just ""
nothing :: PP0
nothing :: PP0
nothing = K7 Tr r r
PP0
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | Turn the given pure transformer into a parsing\/printing pair. That is,
-- return a cassette that provides an output on the one side, and consumes an
-- input on the other, in addition to the string transformations of the given
-- pure transformer. @'set' x p@ provides @x@ as the output of @p@ on the
-- parsing side, and on the printing side accepts an input that is ignored.
set :: a -> PP0 -> PP a
set :: forall a. a -> PP0 -> PP a
set a
x ~(K7 Tr r r
f forall t. Tr (r -> t) (r -> t)
f') = Tr r (a -> r)
-> (forall t. Tr (r -> t) ((a -> r) -> t)) -> K7 Tr r (a -> r)
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 (Tr r (a -> r)
forall r a. Tr r (a -> r)
Tr.popNeg Tr r (a -> r) -> Tr r r -> Tr r (a -> r)
forall b c a. Tr b c -> Tr a b -> Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Tr r r
f) (a -> Tr (r -> t) ((a -> r) -> t)
forall a r r'. a -> Tr (r -> r') ((a -> r) -> r')
Tr.pushPos a
x Tr (r -> t) ((a -> r) -> t)
-> Tr (r -> t) (r -> t) -> Tr (r -> t) ((a -> r) -> t)
forall b c a. Tr b c -> Tr a b -> Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Tr (r -> t) (r -> t)
forall t. Tr (r -> t) (r -> t)
f')

-- | Turn the given parsing\/printing pair into a pure string transformer. That
-- is, return a cassette that does not produce an output or consume an input.
-- @'unset' x p@ throws away the output of @p@ on the parsing side, and on the
-- printing side sets the input to @x@.
unset :: a -> PP a -> PP0
unset :: forall a. a -> PP a -> PP0
unset a
x ~(K7 Tr r (a -> r)
f forall t. Tr (r -> t) ((a -> r) -> t)
f') = Tr r r -> (forall t. Tr (r -> t) (r -> t)) -> K7 Tr r r
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 (a -> Tr (a -> r) r
forall a r. a -> Tr (a -> r) r
Tr.pushNeg a
x Tr (a -> r) r -> Tr r (a -> r) -> Tr r r
forall b c a. Tr b c -> Tr a b -> Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Tr r (a -> r)
f) (Tr ((a -> r) -> t) (r -> t)
forall a r r'. Tr ((a -> r) -> r') (r -> r')
Tr.popPos Tr ((a -> r) -> t) (r -> t)
-> Tr (r -> t) ((a -> r) -> t) -> Tr (r -> t) (r -> t)
forall b c a. Tr b c -> Tr a b -> Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Tr (r -> t) ((a -> r) -> t)
forall t. Tr (r -> t) ((a -> r) -> t)
f')

write :: (a -> String) -> Tr r (a -> r)
write :: forall a r. (a -> String) -> Tr r (a -> r)
write a -> String
f = (C r -> C (a -> r)) -> Tr r (a -> r)
forall r r'. (C r -> C r') -> Tr r r'
Tr \C r
k String -> a -> r
k' String
s a
x -> C r
k (\String
s -> String -> a -> r
k' String
s a
x) (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
f a
x)

write0 :: String -> Tr r r
write0 :: forall r. String -> Tr r r
write0 String
x = (C r -> C r) -> Tr r r
forall r r'. (C r -> C r') -> Tr r r'
Tr \C r
k String -> r
k' String
s -> Tr r (String -> r) -> C r -> C (String -> r)
forall r r'. Tr r r' -> C r -> C r'
unTr ((String -> String) -> Tr r (String -> r)
forall a r. (a -> String) -> Tr r (a -> r)
write String -> String
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id) C r
k (\String
s String
_ -> String -> r
k' String
s) String
s String
x

-- | Strip\/add the given string from\/to the output string.
string :: String -> PP0
-- We could implement 'string' in terms of many, satisfy, char and unshift, but
-- don't, purely to reduce unnecessary choice points during parsing.
string :: String -> PP0
string String
x = Tr r r -> (forall t. Tr (r -> t) (r -> t)) -> K7 Tr r r
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 (String -> Tr r r
forall r. String -> Tr r r
write0 String
x) ((C (r -> t) -> C (r -> t)) -> Tr (r -> t) (r -> t)
forall r r'. (C r -> C r') -> Tr r r'
Tr \C (r -> t)
k String -> r -> t
k' String
s -> (r -> t) -> (String -> r -> t) -> Maybe String -> r -> t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> r -> t
k' String
s) (C (r -> t)
k String -> r -> t
k') (Maybe String -> r -> t) -> Maybe String -> r -> t
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
x String
s)

-- | Successful only if predicate holds.
satisfy :: (Char -> Bool) -> PP Char
satisfy :: (Char -> Bool) -> PP Char
satisfy Char -> Bool
p = Tr r (Char -> r)
-> (forall t. Tr (r -> t) ((Char -> r) -> t))
-> K7 Tr r (Char -> r)
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 ((C r -> C (Char -> r)) -> Tr r (Char -> r)
forall r r'. (C r -> C r') -> Tr r r'
Tr C r -> C (Char -> r)
forall {t}.
((String -> t) -> String -> t)
-> (String -> Char -> t) -> String -> Char -> t
f) ((C (r -> t) -> C ((Char -> r) -> t))
-> Tr (r -> t) ((Char -> r) -> t)
forall r r'. (C r -> C r') -> Tr r r'
Tr C (r -> t) -> C ((Char -> r) -> t)
forall {p} {t} {t}.
((String -> p -> t) -> String -> t -> t)
-> (String -> (Char -> t) -> t) -> String -> (Char -> t) -> t
f')
  where
    f :: ((String -> t) -> String -> t)
-> (String -> Char -> t) -> String -> Char -> t
f (String -> t) -> String -> t
k String -> Char -> t
k' String
s Char
x
      | Char -> Bool
p Char
x = (String -> t) -> String -> t
k (\String
s -> String -> Char -> t
k' String
s Char
x) (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
x])
      | Bool
otherwise = String -> Char -> t
k' String
s Char
x
    f' :: ((String -> p -> t) -> String -> t -> t)
-> (String -> (Char -> t) -> t) -> String -> (Char -> t) -> t
f' (String -> p -> t) -> String -> t -> t
k String -> (Char -> t) -> t
k' (Char
c:String
cs) Char -> t
u
      | Char -> Bool
p Char
c = (String -> p -> t) -> String -> t -> t
k (\String
cs p
_ -> String -> (Char -> t) -> t
k' String
cs Char -> t
u) String
cs (Char -> t
u Char
c)
    f' (String -> p -> t) -> String -> t -> t
_ String -> (Char -> t) -> t
k' String
s Char -> t
u = String -> (Char -> t) -> t
k' String
s Char -> t
u

-- | Parse\/print without consuming\/producing any input.
--
-- >>> let spec = lookAhead (satisfy (=='A')) . string "A"
-- >>> parse spec "ABCD"
-- Just 'A'
lookAhead :: PP a -> PP a
lookAhead :: forall a. PP a -> PP a
lookAhead PP a
csst = Tr r (a -> r)
-> (forall t. Tr (r -> t) ((a -> r) -> t)) -> K7 Tr r (a -> r)
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 ((C r -> C (a -> r)) -> Tr r (a -> r)
forall r r'. (C r -> C r') -> Tr r r'
Tr C r -> C (a -> r)
forall {r}.
((String -> r) -> String -> r)
-> (String -> a -> r) -> String -> a -> r
g) ((C (r -> t) -> C ((a -> r) -> t)) -> Tr (r -> t) ((a -> r) -> t)
forall r r'. (C r -> C r') -> Tr r r'
Tr C (r -> t) -> C ((a -> r) -> t)
forall {a} {t}.
((String -> a -> t) -> String -> a -> t)
-> (String -> (a -> a) -> t) -> String -> (a -> a) -> t
g')
  where
    g :: ((String -> r) -> String -> r)
-> (String -> a -> r) -> String -> a -> r
g (String -> r) -> String -> r
k String -> a -> r
k' String
s = Tr r (a -> r)
-> ((String -> r) -> String -> r)
-> (String -> a -> r)
-> String
-> a
-> r
forall r r'. Tr r r' -> C r -> C r'
unTr (K7 Tr r (a -> r) -> Tr r (a -> r)
forall (p :: * -> * -> *) a b. K7 p a b -> p a b
sideA K7 Tr r (a -> r)
PP a
csst) (\String -> r
k' String
_ -> (String -> r) -> String -> r
k String -> r
k' String
s) String -> a -> r
k' String
s
    g' :: ((String -> a -> t) -> String -> a -> t)
-> (String -> (a -> a) -> t) -> String -> (a -> a) -> t
g' (String -> a -> t) -> String -> a -> t
k String -> (a -> a) -> t
k' String
s = Tr (a -> t) ((a -> a) -> t)
-> ((String -> a -> t) -> String -> a -> t)
-> (String -> (a -> a) -> t)
-> String
-> (a -> a)
-> t
forall r r'. Tr r r' -> C r -> C r'
unTr (K7 Tr a (a -> a) -> forall t. Tr (a -> t) ((a -> a) -> t)
forall (p :: * -> * -> *) a b.
K7 p a b -> forall t. p (a -> t) (b -> t)
sideB K7 Tr a (a -> a)
PP a
csst) (\String -> a -> t
k' String
_ -> (String -> a -> t) -> String -> a -> t
k String -> a -> t
k' String
s) String -> (a -> a) -> t
k' String
s

-- | Succeeds if input string is empty.
--
-- >>> parse (set () eof) ""
-- Just ()
--
-- >>> parse (set () eof) "ABCD"
-- Nothing
eof :: PP0
eof :: PP0
eof = Tr r r -> (forall t. Tr (r -> t) (r -> t)) -> K7 Tr r r
forall (p :: * -> * -> *) a b.
p a b -> (forall t. p (a -> t) (b -> t)) -> K7 p a b
K7 ((C r -> C r) -> Tr r r
forall r r'. (C r -> C r') -> Tr r r'
Tr C r -> C r
forall {t}.
((String -> t) -> String -> t) -> (String -> t) -> String -> t
isEmpty) ((C (r -> t) -> C (r -> t)) -> Tr (r -> t) (r -> t)
forall r r'. (C r -> C r') -> Tr r r'
Tr C (r -> t) -> C (r -> t)
forall {t}.
((String -> t) -> String -> t) -> (String -> t) -> String -> t
isEmpty)
  where
    isEmpty :: ((String -> t) -> String -> t) -> (String -> t) -> String -> t
isEmpty (String -> t) -> String -> t
k String -> t
k' String
"" = (String -> t) -> String -> t
k String -> t
k' String
""
    isEmpty (String -> t) -> String -> t
_ String -> t
k' String
s  = String -> t
k' String
s