module Telescope.Data.Parser where

import Control.Monad.Catch (Exception)
import Data.List (intercalate)
import Data.Text (Text, unpack)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
import Effectful.Reader.Static


data Parser :: Effect where
  ParseFail :: String -> Parser m a
  PathAdd :: Ref -> m a -> Parser m a


type instance DispatchOf Parser = 'Dynamic


runParser
  :: (Error ParseError :> es)
  => Eff (Parser : es) a
  -> Eff es a
runParser :: forall (es :: [Effect]) a.
(Error ParseError :> es) =>
Eff (Parser : es) a -> Eff es a
runParser = (Eff (Reader Path : es) a -> Eff es a)
-> EffectHandler Parser (Reader Path : es)
-> Eff (Parser : es) a
-> Eff es a
forall (e :: Effect) (handlerEs :: [Effect]) a (es :: [Effect]) b.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret (forall r (es :: [Effect]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader @Path Path
forall a. Monoid a => a
mempty) (EffectHandler Parser (Reader Path : es)
 -> Eff (Parser : es) a -> Eff es a)
-> EffectHandler Parser (Reader Path : es)
-> Eff (Parser : es) a
-> Eff es a
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs (Reader Path : es)
env -> \case
  ParseFail String
e -> do
    Path
path <- forall r (es :: [Effect]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask @Path
    ParseError -> Eff (Reader Path : es) a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError (ParseError -> Eff (Reader Path : es) a)
-> ParseError -> Eff (Reader Path : es) a
forall a b. (a -> b) -> a -> b
$ Path -> String -> ParseError
ParseFailure Path
path String
e
  PathAdd Ref
p Eff localEs a
m -> do
    -- copied from Effectful.Reader.Dynamic
    LocalEnv localEs (Reader Path : es)
-> ((forall {r}. Eff localEs r -> Eff (Reader Path : es) r)
    -> Eff (Reader Path : es) a)
-> Eff (Reader Path : es) a
forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) a.
(HasCallStack, SharedSuffix es handlerEs) =>
LocalEnv localEs handlerEs
-> ((forall r. Eff localEs r -> Eff es r) -> Eff es a) -> Eff es a
localSeqUnlift LocalEnv localEs (Reader Path : es)
env (((forall {r}. Eff localEs r -> Eff (Reader Path : es) r)
  -> Eff (Reader Path : es) a)
 -> Eff (Reader Path : es) a)
-> ((forall {r}. Eff localEs r -> Eff (Reader Path : es) r)
    -> Eff (Reader Path : es) a)
-> Eff (Reader Path : es) a
forall a b. (a -> b) -> a -> b
$ \forall {r}. Eff localEs r -> Eff (Reader Path : es) r
unlift -> (Path -> Path)
-> Eff (Reader Path : es) a -> Eff (Reader Path : es) a
forall r (es :: [Effect]) a.
(HasCallStack, Reader r :> es) =>
(r -> r) -> Eff es a -> Eff es a
local (Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> [Ref] -> Path
Path [Ref
p]) (Eff localEs a -> Eff (Reader Path : es) a
forall {r}. Eff localEs r -> Eff (Reader Path : es) r
unlift Eff localEs a
m)


runPureParser :: Eff '[Parser, Error ParseError] a -> Either ParseError a
runPureParser :: forall a. Eff '[Parser, Error ParseError] a -> Either ParseError a
runPureParser Eff '[Parser, Error ParseError] a
eff = Eff '[] (Either ParseError a) -> Either ParseError a
forall a. HasCallStack => Eff '[] a -> a
runPureEff (Eff '[] (Either ParseError a) -> Either ParseError a)
-> (Eff '[Error ParseError] a -> Eff '[] (Either ParseError a))
-> Eff '[Error ParseError] a
-> Either ParseError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (es :: [Effect]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @ParseError (Eff '[Error ParseError] a -> Either ParseError a)
-> Eff '[Error ParseError] a -> Either ParseError a
forall a b. (a -> b) -> a -> b
$ Eff '[Parser, Error ParseError] a -> Eff '[Error ParseError] a
forall (es :: [Effect]) a.
(Error ParseError :> es) =>
Eff (Parser : es) a -> Eff es a
runParser Eff '[Parser, Error ParseError] a
eff


data ParseError
  = ParseFailure Path String
  deriving (Show ParseError
Typeable ParseError
(Typeable ParseError, Show ParseError) =>
(ParseError -> SomeException)
-> (SomeException -> Maybe ParseError)
-> (ParseError -> String)
-> Exception ParseError
SomeException -> Maybe ParseError
ParseError -> String
ParseError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ParseError -> SomeException
toException :: ParseError -> SomeException
$cfromException :: SomeException -> Maybe ParseError
fromException :: SomeException -> Maybe ParseError
$cdisplayException :: ParseError -> String
displayException :: ParseError -> String
Exception, ParseError -> ParseError -> Bool
(ParseError -> ParseError -> Bool)
-> (ParseError -> ParseError -> Bool) -> Eq ParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
/= :: ParseError -> ParseError -> Bool
Eq)


instance Show ParseError where
  show :: ParseError -> String
show (ParseFailure Path
path String
s) =
    String
"at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path -> String
forall a. Show a => a -> String
show Path
path String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n ! " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s


-- | Tracks the location of the parser in the document for error messages
newtype Path = Path [Ref]
  deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
/= :: Path -> Path -> Bool
Eq)
  deriving newtype (NonEmpty Path -> Path
Path -> Path -> Path
(Path -> Path -> Path)
-> (NonEmpty Path -> Path)
-> (forall b. Integral b => b -> Path -> Path)
-> Semigroup Path
forall b. Integral b => b -> Path -> Path
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Path -> Path -> Path
<> :: Path -> Path -> Path
$csconcat :: NonEmpty Path -> Path
sconcat :: NonEmpty Path -> Path
$cstimes :: forall b. Integral b => b -> Path -> Path
stimes :: forall b. Integral b => b -> Path -> Path
Semigroup, Semigroup Path
Path
Semigroup Path =>
Path -> (Path -> Path -> Path) -> ([Path] -> Path) -> Monoid Path
[Path] -> Path
Path -> Path -> Path
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Path
mempty :: Path
$cmappend :: Path -> Path -> Path
mappend :: Path -> Path -> Path
$cmconcat :: [Path] -> Path
mconcat :: [Path] -> Path
Monoid)


instance Show Path where
  show :: Path -> String
show (Path [Ref]
ps) =
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ((Ref -> String) -> [Ref] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref -> String
forall a. Show a => a -> String
show [Ref]
ps)


data Ref
  = Child Text
  | Index Int
  deriving (Ref -> Ref -> Bool
(Ref -> Ref -> Bool) -> (Ref -> Ref -> Bool) -> Eq Ref
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Ref -> Ref -> Bool
== :: Ref -> Ref -> Bool
$c/= :: Ref -> Ref -> Bool
/= :: Ref -> Ref -> Bool
Eq)


instance Show Ref where
  show :: Ref -> String
show (Child Text
c) = Text -> String
unpack Text
c
  show (Index Int
n) = Int -> String
forall a. Show a => a -> String
show Int
n


{- | Easy error message when we expect a particular type:

> instance FromKeyword Int where
>   parseKeywordValue = \case
>     Integer n -> pure n
>     v -> expected "Integer" v
-}
expected :: (Show value, Parser :> es) => String -> value -> Eff es a
expected :: forall value (es :: [Effect]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
ex value
n =
  String -> Eff es a
forall (es :: [Effect]) a. (Parser :> es) => String -> Eff es a
parseFail (String -> Eff es a) -> String -> Eff es a
forall a b. (a -> b) -> a -> b
$ String
"Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ex String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ value -> String
forall a. Show a => a -> String
show value
n


parseFail :: (Parser :> es) => String -> Eff es a
parseFail :: forall (es :: [Effect]) a. (Parser :> es) => String -> Eff es a
parseFail String
e = Parser (Eff es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Parser (Eff es) a -> Eff es a) -> Parser (Eff es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ String -> Parser (Eff es) a
forall (m :: * -> *) a. String -> Parser m a
ParseFail String
e


-- | Add a child to the parsing 'Path'
parseAt :: (Parser :> es) => Ref -> Eff es a -> Eff es a
parseAt :: forall (es :: [Effect]) a.
(Parser :> es) =>
Ref -> Eff es a -> Eff es a
parseAt Ref
p Eff es a
parse = do
  Parser (Eff es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send (Parser (Eff es) a -> Eff es a) -> Parser (Eff es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Ref -> Eff es a -> Parser (Eff es) a
forall (m :: * -> *) a. Ref -> m a -> Parser m a
PathAdd Ref
p Eff es a
parse