{-# LANGUAGE OverloadedStrings #-}

module Mello.Parse
  ( OffsetSpan
  , OffsetSexp
  , Loc (..)
  , LocSpan
  , LocSexp
  , sexpParser
  , parseSexp
  , parseSexpI
  )
where

import Bowtie (Memo, pattern MemoP)
import Control.Monad (guard, unless, void)
import Data.Char (isSpace)
import Data.Sequence (Seq (..))
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void (Void)
import Looksee (Err, ParserT, Span (..))
import Looksee qualified as L
import Mello.Syntax (Atom (..), Doc (..), SexpF (..), Sym (..))
import Mello.Text
  ( Brace
  , closeBraceChar
  , isAtomStart
  , isCharStart
  , isListStart
  , isNumStart
  , isQuoteStart
  , isStringStart
  , isSymCont
  , isSymStart
  , isUnquoteStart
  , openBraceChar
  )

-- Generic parser combinators

guard1P :: (Monad m) => (Char -> Bool) -> ParserT e m ()
guard1P :: forall (m :: * -> *) e. Monad m => (Char -> Bool) -> ParserT e m ()
guard1P Char -> Bool
f = ParserT e m Char
forall (m :: * -> *) e. Monad m => ParserT e m Char
L.headP ParserT e m Char -> (Char -> ParserT e m ()) -> ParserT e m ()
forall a b. ParserT e m a -> (a -> ParserT e m b) -> ParserT e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> ParserT e m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParserT e m ())
-> (Char -> Bool) -> Char -> ParserT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
f

cons1P :: (Monad m) => (Char -> Bool) -> (Char -> Bool) -> ParserT e m Text
cons1P :: forall (m :: * -> *) e.
Monad m =>
(Char -> Bool) -> (Char -> Bool) -> ParserT e m Text
cons1P Char -> Bool
f Char -> Bool
g = (Char -> Text -> Text)
-> ParserT e m Char -> ParserT e m Text -> ParserT e m Text
forall a b c.
(a -> b -> c) -> ParserT e m a -> ParserT e m b -> ParserT e m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Char -> Text -> Text
T.cons (ParserT e m Char
forall (m :: * -> *) e. Monad m => ParserT e m Char
L.headP ParserT e m Char -> (Char -> ParserT e m Char) -> ParserT e m Char
forall a b. ParserT e m a -> (a -> ParserT e m b) -> ParserT e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Char
c -> Char
c Char -> ParserT e m () -> ParserT e m Char
forall a b. a -> ParserT e m b -> ParserT e m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> ParserT e m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char -> Bool
f Char
c)) ((Char -> Bool) -> ParserT e m Text
forall (m :: * -> *) e.
Monad m =>
(Char -> Bool) -> ParserT e m Text
L.takeWhileP Char -> Bool
g)

commitSameP :: (Monad m) => [ParserT e m a] -> ParserT e m a
commitSameP :: forall (m :: * -> *) e a.
Monad m =>
[ParserT e m a] -> ParserT e m a
commitSameP = [(ParserT e m (), ParserT e m a)] -> ParserT e m a
forall (m :: * -> *) (f :: * -> *) e a.
(Monad m, Foldable f) =>
f (ParserT e m (), ParserT e m a) -> ParserT e m a
L.commitP ([(ParserT e m (), ParserT e m a)] -> ParserT e m a)
-> ([ParserT e m a] -> [(ParserT e m (), ParserT e m a)])
-> [ParserT e m a]
-> ParserT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParserT e m a -> (ParserT e m (), ParserT e m a))
-> [ParserT e m a] -> [(ParserT e m (), ParserT e m a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ParserT e m a
p -> (ParserT e m a -> ParserT e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParserT e m a
p, ParserT e m a
p))

explainEmptyP :: (Monad m) => Text -> ParserT e m a -> ParserT e m a
explainEmptyP :: forall (m :: * -> *) e a.
Monad m =>
Text -> ParserT e m a -> ParserT e m a
explainEmptyP Text
msg = (Reason e (Err e) -> Maybe (Text, Bool))
-> ParserT e m a -> ParserT e m a
forall (m :: * -> *) e a.
Monad m =>
(Reason e (Err e) -> Maybe (Text, Bool))
-> ParserT e m a -> ParserT e m a
L.explainP ((Reason e (Err e) -> Maybe (Text, Bool))
 -> ParserT e m a -> ParserT e m a)
-> (Reason e (Err e) -> Maybe (Text, Bool))
-> ParserT e m a
-> ParserT e m a
forall a b. (a -> b) -> a -> b
$ \case
  Reason e (Err e)
L.ReasonEmpty -> (Text, Bool) -> Maybe (Text, Bool)
forall a. a -> Maybe a
Just (Text
msg, Bool
True)
  Reason e (Err e)
_ -> Maybe (Text, Bool)
forall a. Maybe a
Nothing

-- The final recursive types

type OffsetSpan = Span Int

type OffsetSexp = Memo SexpF OffsetSpan

data Loc = Loc
  { Loc -> Int
locLine :: !Int
  , Loc -> Int
locCol :: !Int
  , Loc -> Int
locOffset :: !Int
  }
  deriving stock (Loc -> Loc -> Bool
(Loc -> Loc -> Bool) -> (Loc -> Loc -> Bool) -> Eq Loc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Loc -> Loc -> Bool
== :: Loc -> Loc -> Bool
$c/= :: Loc -> Loc -> Bool
/= :: Loc -> Loc -> Bool
Eq, Eq Loc
Eq Loc =>
(Loc -> Loc -> Ordering)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Loc)
-> (Loc -> Loc -> Loc)
-> Ord Loc
Loc -> Loc -> Bool
Loc -> Loc -> Ordering
Loc -> Loc -> Loc
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 :: Loc -> Loc -> Ordering
compare :: Loc -> Loc -> Ordering
$c< :: Loc -> Loc -> Bool
< :: Loc -> Loc -> Bool
$c<= :: Loc -> Loc -> Bool
<= :: Loc -> Loc -> Bool
$c> :: Loc -> Loc -> Bool
> :: Loc -> Loc -> Bool
$c>= :: Loc -> Loc -> Bool
>= :: Loc -> Loc -> Bool
$cmax :: Loc -> Loc -> Loc
max :: Loc -> Loc -> Loc
$cmin :: Loc -> Loc -> Loc
min :: Loc -> Loc -> Loc
Ord, Int -> Loc -> ShowS
[Loc] -> ShowS
Loc -> String
(Int -> Loc -> ShowS)
-> (Loc -> String) -> ([Loc] -> ShowS) -> Show Loc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Loc -> ShowS
showsPrec :: Int -> Loc -> ShowS
$cshow :: Loc -> String
show :: Loc -> String
$cshowList :: [Loc] -> ShowS
showList :: [Loc] -> ShowS
Show)

type LocSpan = Span Loc

type LocSexp = Memo SexpF LocSpan

-- Specific parsers

docStartP :: (Monad m) => ParserT e m ()
docStartP :: forall (m :: * -> *) e. Monad m => ParserT e m ()
docStartP = Text -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Text -> ParserT e m ()
L.textP_ Text
";|"

commentStartP :: (Monad m) => ParserT e m ()
commentStartP :: forall (m :: * -> *) e. Monad m => ParserT e m ()
commentStartP = Char -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Char -> ParserT e m ()
L.charP_ Char
';'

spaceNP :: (Monad m) => Int -> ParserT e m Int
spaceNP :: forall (m :: * -> *) e. Monad m => Int -> ParserT e m Int
spaceNP !Int
acc = do
  Maybe Char
mc <- ParserT e m (Maybe Char) -> ParserT e m (Maybe Char)
forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
L.lookP ParserT e m (Maybe Char)
forall (m :: * -> *) e. Monad m => ParserT e m (Maybe Char)
L.unconsP
  case Maybe Char
mc of
    Just Char
';' -> do
      Maybe ()
mds <- ParserT e m (Maybe ()) -> ParserT e m (Maybe ())
forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
L.lookP (ParserT e m () -> ParserT e m (Maybe ())
forall (m :: * -> *) e a.
Monad m =>
ParserT e m a -> ParserT e m (Maybe a)
L.optP ParserT e m ()
forall (m :: * -> *) e. Monad m => ParserT e m ()
docStartP)
      case Maybe ()
mds of
        Just ()
_ -> Int -> ParserT e m Int
forall a. a -> ParserT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
acc
        Maybe ()
Nothing -> (Char -> Bool) -> ParserT e m Int
forall (m :: * -> *) e.
Monad m =>
(Char -> Bool) -> ParserT e m Int
L.dropWhileP (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') ParserT e m Int -> (Int -> ParserT e m Int) -> ParserT e m Int
forall a b. ParserT e m a -> (a -> ParserT e m b) -> ParserT e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ParserT e m Int
forall (m :: * -> *) e. Monad m => Int -> ParserT e m Int
spaceNP (Int -> ParserT e m Int) -> (Int -> Int) -> Int -> ParserT e m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
acc +)
    Just Char
c | Char -> Bool
isSpace Char
c -> (Char -> Bool) -> ParserT e m Int
forall (m :: * -> *) e.
Monad m =>
(Char -> Bool) -> ParserT e m Int
L.dropWhileP Char -> Bool
isSpace ParserT e m Int -> (Int -> ParserT e m Int) -> ParserT e m Int
forall a b. ParserT e m a -> (a -> ParserT e m b) -> ParserT e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> ParserT e m Int
forall (m :: * -> *) e. Monad m => Int -> ParserT e m Int
spaceNP (Int -> ParserT e m Int) -> (Int -> Int) -> Int -> ParserT e m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
acc +)
    Maybe Char
_ -> Int -> ParserT e m Int
forall a. a -> ParserT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
acc

spaceP, space1P :: (Monad m) => ParserT e m ()
spaceP :: forall (m :: * -> *) e. Monad m => ParserT e m ()
spaceP = ParserT e m Int -> ParserT e m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int -> ParserT e m Int
forall (m :: * -> *) e. Monad m => Int -> ParserT e m Int
spaceNP Int
0)
space1P :: forall (m :: * -> *) e. Monad m => ParserT e m ()
space1P = do
  Int
acc <- Int -> ParserT e m Int
forall (m :: * -> *) e. Monad m => Int -> ParserT e m Int
spaceNP Int
0
  Bool -> ParserT e m () -> ParserT e m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ParserT e m ()
forall (m :: * -> *) e. Monad m => ParserT e m ()
L.space1P -- Use this to fail

stripP, stripEndP :: (Monad m) => ParserT e m a -> ParserT e m a
stripP :: forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripP ParserT e m a
p = ParserT e m ()
forall (m :: * -> *) e. Monad m => ParserT e m ()
spaceP ParserT e m () -> ParserT e m a -> ParserT e m a
forall a b. ParserT e m a -> ParserT e m b -> ParserT e m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT e m a
p ParserT e m a -> ParserT e m () -> ParserT e m a
forall a b. ParserT e m a -> ParserT e m b -> ParserT e m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT e m ()
forall (m :: * -> *) e. Monad m => ParserT e m ()
spaceP
stripEndP :: forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP ParserT e m a
p = ParserT e m a
p ParserT e m a -> ParserT e m () -> ParserT e m a
forall a b. ParserT e m a -> ParserT e m b -> ParserT e m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParserT e m ()
forall (m :: * -> *) e. Monad m => ParserT e m ()
spaceP

symP :: (Monad m) => ParserT e m Sym
symP :: forall (m :: * -> *) e. Monad m => ParserT e m Sym
symP = (Text -> Sym) -> ParserT e m Text -> ParserT e m Sym
forall a b. (a -> b) -> ParserT e m a -> ParserT e m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Sym
Sym ((Char -> Bool) -> (Char -> Bool) -> ParserT e m Text
forall (m :: * -> *) e.
Monad m =>
(Char -> Bool) -> (Char -> Bool) -> ParserT e m Text
cons1P Char -> Bool
isSymStart Char -> Bool
isSymCont)

charLitP :: (Monad m) => ParserT e m Char
charLitP :: forall (m :: * -> *) e. Monad m => ParserT e m Char
charLitP = Char -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Char -> ParserT e m ()
L.charP_ Char
'\'' ParserT e m () -> ParserT e m Char -> ParserT e m Char
forall a b. ParserT e m a -> ParserT e m b -> ParserT e m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT e m Char
forall (m :: * -> *) e. Monad m => ParserT e m Char
L.headP ParserT e m Char -> ParserT e m () -> ParserT e m Char
forall a b. ParserT e m a -> ParserT e m b -> ParserT e m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Char -> ParserT e m ()
L.charP_ Char
'\''

stringLitP :: (Monad m) => ParserT e m Text
stringLitP :: forall (m :: * -> *) e. Monad m => ParserT e m Text
stringLitP = Char -> ParserT e m Text
forall (m :: * -> *) e. Monad m => Char -> ParserT e m Text
L.strP Char
'"'

openBraceP :: (Monad m) => ParserT e m Brace
openBraceP :: forall (m :: * -> *) e. Monad m => ParserT e m Brace
openBraceP = [ParserT e m Brace] -> ParserT e m Brace
forall (m :: * -> *) e a.
Monad m =>
[ParserT e m a] -> ParserT e m a
commitSameP ((Brace -> ParserT e m Brace) -> [Brace] -> [ParserT e m Brace]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Brace
b -> Brace
b Brace -> ParserT e m () -> ParserT e m Brace
forall a b. a -> ParserT e m b -> ParserT e m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Char -> ParserT e m ()
L.charP_ (Brace -> Char
openBraceChar Brace
b)) [Brace
forall a. Bounded a => a
minBound .. Brace
forall a. Bounded a => a
maxBound])

closeBraceP :: (Monad m) => Brace -> ParserT e m ()
closeBraceP :: forall (m :: * -> *) e. Monad m => Brace -> ParserT e m ()
closeBraceP = Char -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Char -> ParserT e m ()
L.charP_ (Char -> ParserT e m ())
-> (Brace -> Char) -> Brace -> ParserT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Brace -> Char
closeBraceChar

docLinesP :: (Monad m) => ParserT e m Doc
docLinesP :: forall (m :: * -> *) e. Monad m => ParserT e m Doc
docLinesP = Bool -> Seq Text -> ParserT e m Doc
forall {m :: * -> *} {e}.
Monad m =>
Bool -> Seq Text -> ParserT e m Doc
go Bool
True Seq Text
forall a. Seq a
Empty
 where
  lineStartP :: Bool -> ParserT e m ()
lineStartP Bool
isFirst = if Bool
isFirst then ParserT e m ()
forall (m :: * -> *) e. Monad m => ParserT e m ()
docStartP else ParserT e m ()
forall (m :: * -> *) e. Monad m => ParserT e m ()
commentStartP
  lineP :: Bool -> ParserT e m Text
lineP Bool
isFirst = do
    Bool -> ParserT e m ()
forall {m :: * -> *} {e}. Monad m => Bool -> ParserT e m ()
lineStartP Bool
isFirst
    Text
lin <- (Char -> Bool) -> ParserT e m Text
forall (m :: * -> *) e.
Monad m =>
(Char -> Bool) -> ParserT e m Text
L.takeWhileP (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
    Char -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Char -> ParserT e m ()
L.charP_ Char
'\n'
    Text -> ParserT e m Text
forall a. a -> ParserT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
lin
  go :: Bool -> Seq Text -> ParserT e m Doc
go !Bool
isFirst !Seq Text
acc = do
    Maybe ()
mx <- ParserT e m (Maybe ()) -> ParserT e m (Maybe ())
forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
L.lookP (ParserT e m () -> ParserT e m (Maybe ())
forall (m :: * -> *) e a.
Monad m =>
ParserT e m a -> ParserT e m (Maybe a)
L.optP (Bool -> ParserT e m ()
forall {m :: * -> *} {e}. Monad m => Bool -> ParserT e m ()
lineStartP Bool
isFirst))
    case Maybe ()
mx of
      Maybe ()
Nothing -> Doc -> ParserT e m Doc
forall a. a -> ParserT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Text -> Doc
Doc Seq Text
acc)
      Just ()
_ -> do
        Text
lin <- Bool -> ParserT e m Text
forall {m :: * -> *} {e}. Monad m => Bool -> ParserT e m Text
lineP Bool
isFirst
        Bool -> Seq Text -> ParserT e m Doc
go Bool
False (Seq Text
acc Seq Text -> Text -> Seq Text
forall a. Seq a -> a -> Seq a
:|> Text
lin)

-- | A parser for S-expressions
sexpParser :: (Monad m) => ParserT e m OffsetSexp
sexpParser :: forall (m :: * -> *) e. Monad m => ParserT e m OffsetSexp
sexpParser = ParserT e m OffsetSexp -> ParserT e m OffsetSexp
forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripP ParserT e m OffsetSexp
rootP
 where
  rootP :: ParserT e m OffsetSexp
rootP =
    Text -> ParserT e m OffsetSexp -> ParserT e m OffsetSexp
forall (m :: * -> *) e a.
Monad m =>
Text -> ParserT e m a -> ParserT e m a
explainEmptyP Text
"Not a recognizable Sexp" (ParserT e m OffsetSexp -> ParserT e m OffsetSexp)
-> ParserT e m OffsetSexp -> ParserT e m OffsetSexp
forall a b. (a -> b) -> a -> b
$
      (Span Int -> SexpF OffsetSexp -> OffsetSexp)
-> ParserT e m (SexpF OffsetSexp) -> ParserT e m OffsetSexp
forall (m :: * -> *) a b e.
Monad m =>
(Span Int -> a -> b) -> ParserT e m a -> ParserT e m b
L.spanAroundP Span Int -> SexpF OffsetSexp -> OffsetSexp
forall k (f :: * -> *). k -> f (Memo f k) -> Memo f k
MemoP (ParserT e m (SexpF OffsetSexp) -> ParserT e m OffsetSexp)
-> ParserT e m (SexpF OffsetSexp) -> ParserT e m OffsetSexp
forall a b. (a -> b) -> a -> b
$
        [(ParserT e m (), ParserT e m (SexpF OffsetSexp))]
-> ParserT e m (SexpF OffsetSexp)
forall (m :: * -> *) (f :: * -> *) e a.
(Monad m, Foldable f) =>
f (ParserT e m (), ParserT e m a) -> ParserT e m a
L.commitP
          [ ((Char -> Bool) -> ParserT e m ()
forall (m :: * -> *) e. Monad m => (Char -> Bool) -> ParserT e m ()
guard1P Char -> Bool
isListStart, Label
-> ParserT e m (SexpF OffsetSexp) -> ParserT e m (SexpF OffsetSexp)
forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
L.labelP Label
"list" ParserT e m (SexpF OffsetSexp)
listP)
          , ((Char -> Bool) -> ParserT e m ()
forall (m :: * -> *) e. Monad m => (Char -> Bool) -> ParserT e m ()
guard1P Char -> Bool
isQuoteStart, Label
-> ParserT e m (SexpF OffsetSexp) -> ParserT e m (SexpF OffsetSexp)
forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
L.labelP Label
"quote" ParserT e m (SexpF OffsetSexp)
quoteP)
          , ((Char -> Bool) -> ParserT e m ()
forall (m :: * -> *) e. Monad m => (Char -> Bool) -> ParserT e m ()
guard1P Char -> Bool
isUnquoteStart, Label
-> ParserT e m (SexpF OffsetSexp) -> ParserT e m (SexpF OffsetSexp)
forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
L.labelP Label
"unquote" ParserT e m (SexpF OffsetSexp)
unquoteP)
          , ((Char -> Bool) -> ParserT e m ()
forall (m :: * -> *) e. Monad m => (Char -> Bool) -> ParserT e m ()
guard1P Char -> Bool
isAtomStart, Label
-> ParserT e m (SexpF OffsetSexp) -> ParserT e m (SexpF OffsetSexp)
forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
L.labelP Label
"atom" ParserT e m (SexpF OffsetSexp)
forall {e} {r}. ParserT e m (SexpF r)
atomP)
          , (ParserT e m ()
forall (m :: * -> *) e. Monad m => ParserT e m ()
docStartP, Label
-> ParserT e m (SexpF OffsetSexp) -> ParserT e m (SexpF OffsetSexp)
forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
L.labelP Label
"doc" ParserT e m (SexpF OffsetSexp)
docP)
          ]
  listP :: ParserT e m (SexpF OffsetSexp)
listP = do
    Brace
b <- ParserT e m Brace -> ParserT e m Brace
forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP ParserT e m Brace
forall (m :: * -> *) e. Monad m => ParserT e m Brace
openBraceP
    Seq OffsetSexp
ss <- ParserT e m (Seq OffsetSexp) -> ParserT e m (Seq OffsetSexp)
forall (m :: * -> *) e a. Monad m => ParserT e m a -> ParserT e m a
stripEndP (ParserT e m ()
-> ParserT e m OffsetSexp -> ParserT e m (Seq OffsetSexp)
forall (m :: * -> *) e a.
Monad m =>
ParserT e m () -> ParserT e m a -> ParserT e m (Seq a)
L.sepByP ParserT e m ()
forall (m :: * -> *) e. Monad m => ParserT e m ()
space1P ParserT e m OffsetSexp
rootP)
    Brace -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Brace -> ParserT e m ()
closeBraceP Brace
b
    SexpF OffsetSexp -> ParserT e m (SexpF OffsetSexp)
forall a. a -> ParserT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Brace -> Seq OffsetSexp -> SexpF OffsetSexp
forall r. Brace -> Seq r -> SexpF r
SexpListF Brace
b Seq OffsetSexp
ss)
  quoteP :: ParserT e m (SexpF OffsetSexp)
quoteP = Char -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Char -> ParserT e m ()
L.charP_ Char
'`' ParserT e m ()
-> ParserT e m (SexpF OffsetSexp) -> ParserT e m (SexpF OffsetSexp)
forall a b. ParserT e m a -> ParserT e m b -> ParserT e m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (OffsetSexp -> SexpF OffsetSexp)
-> ParserT e m OffsetSexp -> ParserT e m (SexpF OffsetSexp)
forall a b. (a -> b) -> ParserT e m a -> ParserT e m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OffsetSexp -> SexpF OffsetSexp
forall r. r -> SexpF r
SexpQuoteF ParserT e m OffsetSexp
rootP
  unquoteP :: ParserT e m (SexpF OffsetSexp)
unquoteP = Char -> ParserT e m ()
forall (m :: * -> *) e. Monad m => Char -> ParserT e m ()
L.charP_ Char
',' ParserT e m ()
-> ParserT e m (SexpF OffsetSexp) -> ParserT e m (SexpF OffsetSexp)
forall a b. ParserT e m a -> ParserT e m b -> ParserT e m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (OffsetSexp -> SexpF OffsetSexp)
-> ParserT e m OffsetSexp -> ParserT e m (SexpF OffsetSexp)
forall a b. (a -> b) -> ParserT e m a -> ParserT e m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OffsetSexp -> SexpF OffsetSexp
forall r. r -> SexpF r
SexpUnquoteF ParserT e m OffsetSexp
rootP
  atomP :: ParserT e m (SexpF r)
atomP =
    Atom -> SexpF r
forall r. Atom -> SexpF r
SexpAtomF
      (Atom -> SexpF r) -> ParserT e m Atom -> ParserT e m (SexpF r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ParserT e m (), ParserT e m Atom)] -> ParserT e m Atom
forall (m :: * -> *) (f :: * -> *) e a.
(Monad m, Foldable f) =>
f (ParserT e m (), ParserT e m a) -> ParserT e m a
L.commitP
        [ ((Char -> Bool) -> ParserT e m ()
forall (m :: * -> *) e. Monad m => (Char -> Bool) -> ParserT e m ()
guard1P Char -> Bool
isSymStart, Label -> ParserT e m Atom -> ParserT e m Atom
forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
L.labelP Label
"sym" ((Sym -> Atom) -> ParserT e m Sym -> ParserT e m Atom
forall a b. (a -> b) -> ParserT e m a -> ParserT e m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Sym -> Atom
AtomSym ParserT e m Sym
forall (m :: * -> *) e. Monad m => ParserT e m Sym
symP))
        , ((Char -> Bool) -> ParserT e m ()
forall (m :: * -> *) e. Monad m => (Char -> Bool) -> ParserT e m ()
guard1P Char -> Bool
isNumStart, Label -> ParserT e m Atom -> ParserT e m Atom
forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
L.labelP Label
"num" ((Either Integer Scientific -> Atom)
-> ParserT e m (Either Integer Scientific) -> ParserT e m Atom
forall a b. (a -> b) -> ParserT e m a -> ParserT e m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Integer -> Atom)
-> (Scientific -> Atom) -> Either Integer Scientific -> Atom
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Integer -> Atom
AtomInt Scientific -> Atom
AtomSci) ParserT e m (Either Integer Scientific)
forall (m :: * -> *) e.
Monad m =>
ParserT e m (Either Integer Scientific)
L.numP))
        , ((Char -> Bool) -> ParserT e m ()
forall (m :: * -> *) e. Monad m => (Char -> Bool) -> ParserT e m ()
guard1P Char -> Bool
isStringStart, Label -> ParserT e m Atom -> ParserT e m Atom
forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
L.labelP Label
"str" ((Text -> Atom) -> ParserT e m Text -> ParserT e m Atom
forall a b. (a -> b) -> ParserT e m a -> ParserT e m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Atom
AtomStr ParserT e m Text
forall (m :: * -> *) e. Monad m => ParserT e m Text
stringLitP))
        , ((Char -> Bool) -> ParserT e m ()
forall (m :: * -> *) e. Monad m => (Char -> Bool) -> ParserT e m ()
guard1P Char -> Bool
isCharStart, Label -> ParserT e m Atom -> ParserT e m Atom
forall (m :: * -> *) e a.
Monad m =>
Label -> ParserT e m a -> ParserT e m a
L.labelP Label
"char" ((Char -> Atom) -> ParserT e m Char -> ParserT e m Atom
forall a b. (a -> b) -> ParserT e m a -> ParserT e m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Atom
AtomChar ParserT e m Char
forall (m :: * -> *) e. Monad m => ParserT e m Char
charLitP))
        ]
  docP :: ParserT e m (SexpF OffsetSexp)
docP = do
    Doc
doc <- ParserT e m Doc
forall (m :: * -> *) e. Monad m => ParserT e m Doc
docLinesP
    (OffsetSexp -> SexpF OffsetSexp)
-> ParserT e m OffsetSexp -> ParserT e m (SexpF OffsetSexp)
forall a b. (a -> b) -> ParserT e m a -> ParserT e m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> OffsetSexp -> SexpF OffsetSexp
forall r. Doc -> r -> SexpF r
SexpDocF Doc
doc) ParserT e m OffsetSexp
rootP

parseSexp :: Text -> Either (Err Void) LocSexp
parseSexp :: Text -> Either (Err Void) LocSexp
parseSexp Text
txt = do
  OffsetSexp
sexp <- Parser Void OffsetSexp -> Text -> Either (Err Void) OffsetSexp
forall e a. Parser e a -> Text -> Either (Err e) a
L.parse Parser Void OffsetSexp
forall (m :: * -> *) e. Monad m => ParserT e m OffsetSexp
sexpParser Text
txt
  let v :: LineColLookup
v = Text -> LineColLookup
L.calculateLineCol Text
txt
      mkLoc :: Int -> Loc
mkLoc Int
o = let (Int
l, Int
c) = Int -> LineColLookup -> (Int, Int)
L.lookupLineCol Int
o LineColLookup
v in Int -> Int -> Int -> Loc
Loc Int
l Int
c Int
o
  LocSexp -> Either (Err Void) LocSexp
forall a. a -> Either (Err Void) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Span Int -> LocSpan) -> OffsetSexp -> LocSexp
forall a b. (a -> b) -> Memo SexpF a -> Memo SexpF b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Loc) -> Span Int -> LocSpan
forall a b. (a -> b) -> Span a -> Span b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Loc
mkLoc) OffsetSexp
sexp)

parseSexpI :: Text -> IO (Either (Err Void) LocSexp)
parseSexpI :: Text -> IO (Either (Err Void) LocSexp)
parseSexpI Text
txt = do
  let ea :: Either (Err Void) LocSexp
ea = Text -> Either (Err Void) LocSexp
parseSexp Text
txt
  case Either (Err Void) LocSexp
ea of
    Left Err Void
e -> String -> Text -> Err Void -> IO ()
forall e. HasErrMessage e => String -> Text -> Err e -> IO ()
L.printE String
"<interactive>" Text
txt Err Void
e
    Right LocSexp
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Either (Err Void) LocSexp -> IO (Either (Err Void) LocSexp)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either (Err Void) LocSexp
ea