{-# LANGUAGE UndecidableInstances #-}

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
  PathMod :: (Path -> Path) -> m a -> Parser m a


type instance DispatchOf Parser = 'Dynamic


runParser
  :: Eff (Parser : es) a
  -> Eff es (Either ParseError a)
runParser :: forall (es :: [(* -> *) -> * -> *]) a.
Eff (Parser : es) a -> Eff es (Either ParseError a)
runParser = (Eff (Reader Path : Error ParseError : es) a
 -> Eff es (Either ParseError a))
-> (forall {a} {localEs :: [(* -> *) -> * -> *]}.
    (HasCallStack, Parser :> localEs) =>
    LocalEnv localEs (Reader Path : Error ParseError : es)
    -> Parser (Eff localEs) a
    -> Eff (Reader Path : Error ParseError : es) a)
-> Eff (Parser : es) a
-> Eff es (Either ParseError a)
forall (e :: (* -> *) -> * -> *)
       (handlerEs :: [(* -> *) -> * -> *]) a (es :: [(* -> *) -> * -> *])
       b.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret (forall e (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @ParseError (Eff (Error ParseError : es) a -> Eff es (Either ParseError a))
-> (Eff (Reader Path : Error ParseError : es) a
    -> Eff (Error ParseError : es) a)
-> Eff (Reader Path : Error ParseError : es) a
-> Eff es (Either ParseError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (es :: [(* -> *) -> * -> *]) a.
HasCallStack =>
r -> Eff (Reader r : es) a -> Eff es a
runReader @Path Path
forall a. Monoid a => a
mempty) ((forall {a} {localEs :: [(* -> *) -> * -> *]}.
  (HasCallStack, Parser :> localEs) =>
  LocalEnv localEs (Reader Path : Error ParseError : es)
  -> Parser (Eff localEs) a
  -> Eff (Reader Path : Error ParseError : es) a)
 -> Eff (Parser : es) a -> Eff es (Either ParseError a))
-> (forall {a} {localEs :: [(* -> *) -> * -> *]}.
    (HasCallStack, Parser :> localEs) =>
    LocalEnv localEs (Reader Path : Error ParseError : es)
    -> Parser (Eff localEs) a
    -> Eff (Reader Path : Error ParseError : es) a)
-> Eff (Parser : es) a
-> Eff es (Either ParseError a)
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs (Reader Path : Error ParseError : es)
env -> \case
  ParseFail String
e -> do
    Path
path <- forall r (es :: [(* -> *) -> * -> *]).
(HasCallStack, Reader r :> es) =>
Eff es r
ask @Path
    ParseError -> Eff (Reader Path : Error ParseError : es) a
forall e (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError (ParseError -> Eff (Reader Path : Error ParseError : es) a)
-> ParseError -> Eff (Reader Path : Error ParseError : es) a
forall a b. (a -> b) -> a -> b
$ Path -> String -> ParseError
ParseFailure Path
path String
e
  PathMod Path -> Path
mp Eff localEs a
m -> do
    LocalEnv localEs (Reader Path : Error ParseError : es)
-> ((forall {r}.
     Eff localEs r -> Eff (Reader Path : Error ParseError : es) r)
    -> Eff (Reader Path : Error ParseError : es) a)
-> Eff (Reader Path : Error ParseError : es) a
forall (es :: [(* -> *) -> * -> *])
       (handlerEs :: [(* -> *) -> * -> *])
       (localEs :: [(* -> *) -> * -> *]) 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 : Error ParseError : es)
env (((forall {r}.
   Eff localEs r -> Eff (Reader Path : Error ParseError : es) r)
  -> Eff (Reader Path : Error ParseError : es) a)
 -> Eff (Reader Path : Error ParseError : es) a)
-> ((forall {r}.
     Eff localEs r -> Eff (Reader Path : Error ParseError : es) r)
    -> Eff (Reader Path : Error ParseError : es) a)
-> Eff (Reader Path : Error ParseError : es) a
forall a b. (a -> b) -> a -> b
$ \forall {r}.
Eff localEs r -> Eff (Reader Path : Error ParseError : es) r
unlift -> (Path -> Path)
-> Eff (Reader Path : Error ParseError : es) a
-> Eff (Reader Path : Error ParseError : es) a
forall r (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Reader r :> es) =>
(r -> r) -> Eff es a -> Eff es a
local Path -> Path
mp (Eff localEs a -> Eff (Reader Path : Error ParseError : es) a
forall {r}.
Eff localEs r -> Eff (Reader Path : Error ParseError : es) r
unlift Eff localEs a
m)


-- copied from Effectful.Reader.Dynamic
-- localSeqUnlift env $ \unlift -> local (<> Path [p]) (unlift m)

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 :: [(* -> *) -> * -> *]) a.
(Show value, Parser :> es) =>
String -> value -> Eff es a
expected String
ex value
n =
  String -> Eff es a
forall (es :: [(* -> *) -> * -> *]) 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 :: [(* -> *) -> * -> *]) a.
(Parser :> es) =>
String -> Eff es a
parseFail String
e = Parser (Eff es) a -> Eff es a
forall (e :: (* -> *) -> * -> *) (es :: [(* -> *) -> * -> *]) 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 :: [(* -> *) -> * -> *]) 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 :: (* -> *) -> * -> *) (es :: [(* -> *) -> * -> *]) 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
$ (Path -> Path) -> Eff es a -> Parser (Eff es) a
forall (m :: * -> *) a. (Path -> Path) -> m a -> Parser m a
PathMod (Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> [Ref] -> Path
Path [Ref
p]) Eff es a
parse