{-# LANGUAGE UndecidableInstances #-}
module Data.Type.Symbol.Parser.Run ( Run ) where
import Data.Type.Symbol.Parser.Types
import GHC.TypeLits
import DeFun.Core ( type (@@) )
type Run :: Parser s r -> Symbol -> Either ErrorMessage (r, Symbol)
type family Run p sym where
Run '(pCh, pEnd, s) sym =
MapLeftPrettyERun (RunStart pCh pEnd s (UnconsSymbol sym))
type family RunStart pCh pEnd s msym where
RunStart pCh pEnd s (Just '(ch, sym)) =
RunCh pCh pEnd 0 ch (UnconsSymbol sym) (pCh @@ ch @@ s)
RunStart pCh pEnd s Nothing = RunEnd0 (pEnd @@ s)
type family RunCh pCh pEnd idx ch' msym res where
RunCh pCh pEnd idx ch' (Just '(ch, sym)) (Cont s) =
RunCh pCh pEnd (idx+1) ch (UnconsSymbol sym) (pCh @@ ch @@ s)
RunCh pCh pEnd idx ch' Nothing (Cont s) =
RunEnd idx ch' (pEnd @@ s)
RunCh pCh pEnd idx ch' msym (Done r) =
Right '(r, ReconsSymbol msym)
RunCh pCh pEnd idx ch' msym (Err e) =
Left ('ERun idx ch' e)
type RunEnd :: Natural -> Char -> Either E r -> Either ERun (r, Symbol)
type family RunEnd idx ch res where
RunEnd idx ch (Right r) = Right '(r, "")
RunEnd idx ch (Left e) = Left ('ERun idx ch e)
type family RunEnd0 res where
RunEnd0 (Right r) = Right '(r, "")
RunEnd0 (Left e) = Left (ERun0 e)
type PrettyERun :: ERun -> ErrorMessage
type family PrettyERun e where
PrettyERun (ERun0 e) = Text "parse error on empty string" :$$: PrettyE e
PrettyERun ('ERun idx ch e) =
Text "parse error at index " :<>: ShowType idx
:<>: Text ", char " :<>: ShowType ch :$$: PrettyE e
type family PrettyE e where
PrettyE (EBase name emsg) = Text name :<>: Text ": " :<>: emsg
PrettyE (EIn name e) = Text name :<>: Text ": " :<>: PrettyE e
type family MapLeftPrettyERun eea where
MapLeftPrettyERun (Left e) = Left (PrettyERun e)
MapLeftPrettyERun (Right a) = Right a
type family ReconsSymbol msym where
ReconsSymbol Nothing = ""
ReconsSymbol (Just '(ch, sym)) = ConsSymbol ch sym
data ERun
= ERun Natural Char E
| ERun0 E