{-# LANGUAGE UndecidableInstances #-}

module Symparsec.Parser.Literal where

import Symparsec.Parser.Common
import GHC.TypeLits hiding ( ErrorMessage(..) )
import TypeLevelShow.Utils ( ShowChar, sShowChar )
import Data.Type.Equality
import DeFun.Core
import Singleraeh.Tuple
import Singleraeh.Either
import Singleraeh.Maybe
import Singleraeh.Symbol
import Unsafe.Coerce
import TypeLevelShow.Doc

-- | Parse the given 'Symbol'.
type Literal :: Symbol -> PParser Symbol ()
type Literal str = 'PParser LiteralChSym LiteralEndSym str

sLiteral :: SSymbol str -> SParser SSymbol SUnit (Literal str)
sLiteral :: forall (str :: Symbol).
SSymbol str -> SParser SSymbol SUnit (Literal str)
sLiteral SSymbol str
str = SParserChSym SSymbol SUnit LiteralChSym
-> SParserEndSym SSymbol SUnit LiteralEndSym
-> SSymbol str
-> SParser SSymbol SUnit ('PParser LiteralChSym LiteralEndSym str)
forall {s} {r} (ss :: s -> Type) (sr :: r -> Type)
       (pCh :: ParserChSym s r) (pEnd :: ParserEndSym s r) (s0 :: s).
SParserChSym ss sr pCh
-> SParserEndSym ss sr pEnd
-> ss s0
-> SParser ss sr ('PParser pCh pEnd s0)
SParser SParserChSym SSymbol SUnit LiteralChSym
sLiteralChSym SParserEndSym SSymbol SUnit LiteralEndSym
sLiteralEndSym SSymbol str
str

instance KnownSymbol str => SingParser (Literal str) where
    type PS (Literal str) = SSymbol
    type PR (Literal str) = SUnit
    singParser' :: SParser (PS (Literal str)) (PR (Literal str)) (Literal str)
singParser' = SSymbol str -> SParser SSymbol SUnit (Literal str)
forall (str :: Symbol).
SSymbol str -> SParser SSymbol SUnit (Literal str)
sLiteral SSymbol str
forall (s :: Symbol). KnownSymbol s => SSymbol s
SSymbol

type LiteralCh ch str = LiteralCh' ch (UnconsSymbol str)
type family LiteralCh' ch str where
    LiteralCh' ch (Just '(ch, str))     = Cont str
    LiteralCh' ch (Just '(chNext, str)) = Err (EWrongChar chNext ch)
    LiteralCh' ch Nothing               = Done '()

type EWrongChar chNext ch = EBase "Literal"
    (      Text "expected " :<>: Text (ShowChar chNext)
      :<>: Text    ", got " :<>: Text (ShowChar ch))

eWrongChar :: SChar chNext -> SChar ch -> SE (EWrongChar chNext ch)
eWrongChar :: forall (chNext :: Char) (ch :: Char).
SChar chNext -> SChar ch -> SE (EWrongChar chNext ch)
eWrongChar SChar chNext
chNext SChar ch
ch = SSymbol "Literal"
-> SDoc
     ((('Text "expected " ':<>: 'Text (ShowChar chNext))
       ':<>: 'Text ", got ")
      ':<>: 'Text (ShowChar ch))
-> SE
     ('EBase
        "Literal"
        ((('Text "expected " ':<>: 'Text (ShowChar chNext))
          ':<>: 'Text ", got ")
         ':<>: 'Text (ShowChar ch)))
forall (name :: Symbol) (doc :: Doc Symbol).
SSymbol name -> SDoc doc -> SE ('EBase name doc)
SEBase SSymbol "Literal"
forall (s :: Symbol). KnownSymbol s => SSymbol s
symbolSing (SDoc
   ((('Text "expected " ':<>: 'Text (ShowChar chNext))
     ':<>: 'Text ", got ")
    ':<>: 'Text (ShowChar ch))
 -> SE
      ('EBase
         "Literal"
         ((('Text "expected " ':<>: 'Text (ShowChar chNext))
           ':<>: 'Text ", got ")
          ':<>: 'Text (ShowChar ch))))
-> SDoc
     ((('Text "expected " ':<>: 'Text (ShowChar chNext))
       ':<>: 'Text ", got ")
      ':<>: 'Text (ShowChar ch))
-> SE
     ('EBase
        "Literal"
        ((('Text "expected " ':<>: 'Text (ShowChar chNext))
          ':<>: 'Text ", got ")
         ':<>: 'Text (ShowChar ch)))
forall a b. (a -> b) -> a -> b
$
          SSymbol "expected " -> SDoc ('Text "expected ")
forall (s :: Symbol). SSymbol s -> SDoc ('Text s)
SText SSymbol "expected "
forall (s :: Symbol). KnownSymbol s => SSymbol s
symbolSing SDoc ('Text "expected ")
-> SDoc ('Text (ShowChar chNext))
-> SDoc ('Text "expected " ':<>: 'Text (ShowChar chNext))
forall (docl :: Doc Symbol) (docr :: Doc Symbol).
SDoc docl -> SDoc docr -> SDoc (docl ':<>: docr)
:$<>: SSymbol (ShowChar chNext) -> SDoc ('Text (ShowChar chNext))
forall (s :: Symbol). SSymbol s -> SDoc ('Text s)
SText (SChar chNext -> SSymbol (ShowChar chNext)
forall (ch :: Char). SChar ch -> SSymbol (ShowChar ch)
sShowChar SChar chNext
chNext)
    SDoc ('Text "expected " ':<>: 'Text (ShowChar chNext))
-> SDoc ('Text ", got ")
-> SDoc
     (('Text "expected " ':<>: 'Text (ShowChar chNext))
      ':<>: 'Text ", got ")
forall (docl :: Doc Symbol) (docr :: Doc Symbol).
SDoc docl -> SDoc docr -> SDoc (docl ':<>: docr)
:$<>: SSymbol ", got " -> SDoc ('Text ", got ")
forall (s :: Symbol). SSymbol s -> SDoc ('Text s)
SText SSymbol ", got "
forall (s :: Symbol). KnownSymbol s => SSymbol s
symbolSing SDoc
  (('Text "expected " ':<>: 'Text (ShowChar chNext))
   ':<>: 'Text ", got ")
-> SDoc ('Text (ShowChar ch))
-> SDoc
     ((('Text "expected " ':<>: 'Text (ShowChar chNext))
       ':<>: 'Text ", got ")
      ':<>: 'Text (ShowChar ch))
forall (docl :: Doc Symbol) (docr :: Doc Symbol).
SDoc docl -> SDoc docr -> SDoc (docl ':<>: docr)
:$<>: SSymbol (ShowChar ch) -> SDoc ('Text (ShowChar ch))
forall (s :: Symbol). SSymbol s -> SDoc ('Text s)
SText (SChar ch -> SSymbol (ShowChar ch)
forall (ch :: Char). SChar ch -> SSymbol (ShowChar ch)
sShowChar SChar ch
ch)

type LiteralChSym :: ParserChSym Symbol ()
data LiteralChSym f
type instance App LiteralChSym f = LiteralChSym1 f

type LiteralChSym1 :: ParserChSym1 Symbol ()
data LiteralChSym1 ch s
type instance App (LiteralChSym1 ch) s = LiteralCh ch s

sLiteralChSym :: SParserChSym SSymbol SUnit LiteralChSym
sLiteralChSym :: SParserChSym SSymbol SUnit LiteralChSym
sLiteralChSym = LamRep2 SChar SSymbol (SResult SSymbol SUnit) LiteralChSym
-> SParserChSym SSymbol SUnit LiteralChSym
forall {a1} {a2} {b1} (a3 :: a1 -> Type) (b2 :: a2 -> Type)
       (c :: b1 -> Type) (fun :: a1 ~> (a2 ~> b1)).
LamRep2 a3 b2 c fun -> Lam2 a3 b2 c fun
Lam2 (LamRep2 SChar SSymbol (SResult SSymbol SUnit) LiteralChSym
 -> SParserChSym SSymbol SUnit LiteralChSym)
-> LamRep2 SChar SSymbol (SResult SSymbol SUnit) LiteralChSym
-> SParserChSym SSymbol SUnit LiteralChSym
forall a b. (a -> b) -> a -> b
$ \SChar x
ch SSymbol y
str ->
    case SSymbol y -> SMaybe (STuple2 SChar SSymbol) (UnconsSymbol y)
forall (str :: Symbol).
SSymbol str -> SMaybe (STuple2 SChar SSymbol) (UnconsSymbol str)
sUnconsSymbol SSymbol y
str of
      SJust (STuple2 SChar a1
chNext SSymbol b1
str') ->
        case SChar x -> SChar a1 -> Maybe (x :~: a1)
forall (a :: Char) (b :: Char).
SChar a -> SChar b -> Maybe (a :~: b)
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality SChar x
ch SChar a1
chNext of
          Just x :~: a1
Refl -> SSymbol b1 -> SResult SSymbol SUnit ('Cont b1)
forall {s} {r} (ss :: s -> Type) (s1 :: s) (sr :: r -> Type).
ss s1 -> SResult ss sr ('Cont s1)
SCont SSymbol b1
str'
          Maybe (x :~: a1)
Nothing   -> SResult
  Any
  Any
  ('Err
     ('EBase
        "Literal"
        ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
          ':<>: 'Text ", got ")
         ':<>: 'Text (ConsSymbol x ""))))
-> SResult SSymbol SUnit ((LiteralChSym @@ x) @@ y)
forall a b. a -> b
unsafeCoerce (SResult
   Any
   Any
   ('Err
      ('EBase
         "Literal"
         ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
           ':<>: 'Text ", got ")
          ':<>: 'Text (ConsSymbol x ""))))
 -> SResult SSymbol SUnit ((LiteralChSym @@ x) @@ y))
-> SResult
     Any
     Any
     ('Err
        ('EBase
           "Literal"
           ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
             ':<>: 'Text ", got ")
            ':<>: 'Text (ConsSymbol x ""))))
-> SResult SSymbol SUnit ((LiteralChSym @@ x) @@ y)
forall a b. (a -> b) -> a -> b
$ SE
  ('EBase
     "Literal"
     ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
       ':<>: 'Text ", got ")
      ':<>: 'Text (ConsSymbol x "")))
-> SResult
     Any
     Any
     ('Err
        ('EBase
           "Literal"
           ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
             ':<>: 'Text ", got ")
            ':<>: 'Text (ConsSymbol x ""))))
forall {s} {r} (e :: E Symbol) (ss :: s -> Type) (sr :: r -> Type).
SE e -> SResult ss sr ('Err e)
SErr (SE
   ('EBase
      "Literal"
      ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
        ':<>: 'Text ", got ")
       ':<>: 'Text (ConsSymbol x "")))
 -> SResult
      Any
      Any
      ('Err
         ('EBase
            "Literal"
            ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
              ':<>: 'Text ", got ")
             ':<>: 'Text (ConsSymbol x "")))))
-> SE
     ('EBase
        "Literal"
        ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
          ':<>: 'Text ", got ")
         ':<>: 'Text (ConsSymbol x "")))
-> SResult
     Any
     Any
     ('Err
        ('EBase
           "Literal"
           ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
             ':<>: 'Text ", got ")
            ':<>: 'Text (ConsSymbol x ""))))
forall a b. (a -> b) -> a -> b
$ SChar a1
-> SChar x
-> SE
     ('EBase
        "Literal"
        ((('Text "expected " ':<>: 'Text (ConsSymbol a1 ""))
          ':<>: 'Text ", got ")
         ':<>: 'Text (ConsSymbol x "")))
forall (chNext :: Char) (ch :: Char).
SChar chNext -> SChar ch -> SE (EWrongChar chNext ch)
eWrongChar SChar a1
chNext SChar x
ch
      SMaybe (STuple2 SChar SSymbol) (UnconsSymbol y)
SNothing -> SUnit '() -> SResult SSymbol SUnit ('Done '())
forall {r} {s} (sr :: r -> Type) (r1 :: r) (ss :: s -> Type).
sr r1 -> SResult ss sr ('Done r1)
SDone SUnit '()
SUnit

type LiteralEnd :: PParserEnd Symbol ()
type family LiteralEnd str where
    LiteralEnd ""  = Right '()
    LiteralEnd str = Left (EStillParsing str)

type EStillParsing str =
    EBase "Literal" (Text "still parsing literal: " :<>: Text str)

eStillParsing :: SSymbol str -> SE (EStillParsing str)
eStillParsing :: forall (str :: Symbol). SSymbol str -> SE (EStillParsing str)
eStillParsing SSymbol str
str = SSymbol str
-> (KnownSymbol str => SE (EStillParsing str))
-> SE (EStillParsing str)
forall (s :: Symbol) r. SSymbol s -> (KnownSymbol s => r) -> r
withKnownSymbol SSymbol str
str SE (EStillParsing str)
KnownSymbol str => SE (EStillParsing str)
forall (e :: E Symbol). SingE e => SE e
singE

type LiteralEndSym :: ParserEndSym Symbol ()
data LiteralEndSym s
type instance App LiteralEndSym s = LiteralEnd s

sLiteralEndSym :: SParserEndSym SSymbol SUnit LiteralEndSym
sLiteralEndSym :: SParserEndSym SSymbol SUnit LiteralEndSym
sLiteralEndSym = LamRep SSymbol (SResultEnd SUnit) LiteralEndSym
-> SParserEndSym SSymbol SUnit LiteralEndSym
forall a b (a1 :: a -> Type) (b1 :: b -> Type) (f :: a ~> b).
LamRep a1 b1 f -> Lam a1 b1 f
Lam (LamRep SSymbol (SResultEnd SUnit) LiteralEndSym
 -> SParserEndSym SSymbol SUnit LiteralEndSym)
-> LamRep SSymbol (SResultEnd SUnit) LiteralEndSym
-> SParserEndSym SSymbol SUnit LiteralEndSym
forall a b. (a -> b) -> a -> b
$ \SSymbol x
str ->
    case SSymbol x -> SSymbol "" -> Maybe (x :~: "")
forall {k} (f :: k -> Type) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Symbol) (b :: Symbol).
SSymbol a -> SSymbol b -> Maybe (a :~: b)
testEquality SSymbol x
str (forall (s :: Symbol). KnownSymbol s => SSymbol s
SSymbol @"") of
      Just x :~: ""
Refl -> SUnit '() -> SEither SE SUnit ('Right '())
forall {r} {l} (sr :: r -> Type) (r1 :: r) (sl :: l -> Type).
sr r1 -> SEither sl sr ('Right r1)
SRight SUnit '()
SUnit
      Maybe (x :~: "")
Nothing   -> SEither SE Any ('Left (EStillParsing x))
-> SResultEnd SUnit (LiteralEndSym @@ x)
forall a b. a -> b
unsafeCoerce (SEither SE Any ('Left (EStillParsing x))
 -> SResultEnd SUnit (LiteralEndSym @@ x))
-> SEither SE Any ('Left (EStillParsing x))
-> SResultEnd SUnit (LiteralEndSym @@ x)
forall a b. (a -> b) -> a -> b
$ SE (EStillParsing x) -> SEither SE Any ('Left (EStillParsing x))
forall {l} {r} (sl :: l -> Type) (l1 :: l) (sr :: r -> Type).
sl l1 -> SEither sl sr ('Left l1)
SLeft (SE (EStillParsing x) -> SEither SE Any ('Left (EStillParsing x)))
-> SE (EStillParsing x) -> SEither SE Any ('Left (EStillParsing x))
forall a b. (a -> b) -> a -> b
$ SSymbol x -> SE (EStillParsing x)
forall (str :: Symbol). SSymbol str -> SE (EStillParsing str)
eStillParsing SSymbol x
str