-- TODO finish this
module Mello.Recognize
  (
  )
where

import Control.Foldl (Fold (..))
import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT)
import Control.Monad.State.Strict (State, gets, modify', runState)
import Mello.Text (Brace, readCloseBrace, readOpenBrace)

data X e s = X !(Maybe e) !s

foldUntilErr :: (a -> ExceptT e (State s) ()) -> s -> (Maybe e -> s -> b) -> Fold a b
foldUntilErr :: forall a e s b.
(a -> ExceptT e (State s) ())
-> s -> (Maybe e -> s -> b) -> Fold a b
foldUntilErr a -> ExceptT e (State s) ()
step s
initial Maybe e -> s -> b
extract = (X e s -> a -> X e s) -> X e s -> (X e s -> b) -> Fold a b
forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold X e s -> a -> X e s
step' X e s
initial' X e s -> b
extract'
 where
  step' :: X e s -> a -> X e s
step' x :: X e s
x@(X Maybe e
me s
s) a
a =
    case Maybe e
me of
      Just e
_ -> X e s
x
      Maybe e
Nothing ->
        let (Either e ()
ea, s
s') = State s (Either e ()) -> s -> (Either e (), s)
forall s a. State s a -> s -> (a, s)
runState (ExceptT e (State s) () -> State s (Either e ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExceptT e (State s) ()
step a
a)) s
s
        in  case Either e ()
ea of
              Left e
e -> Maybe e -> s -> X e s
forall e s. Maybe e -> s -> X e s
X (e -> Maybe e
forall a. a -> Maybe a
Just e
e) s
s'
              Right ()
_ -> Maybe e -> s -> X e s
forall e s. Maybe e -> s -> X e s
X Maybe e
forall a. Maybe a
Nothing s
s'
  initial' :: X e s
initial' = Maybe e -> s -> X e s
forall e s. Maybe e -> s -> X e s
X Maybe e
forall a. Maybe a
Nothing s
initial
  extract' :: X e s -> b
extract' (X Maybe e
me s
s) = Maybe e -> s -> b
extract Maybe e
me s
s

data RecogElem
  = RecogElemString
  | RecogElemChar
  | RecogElemComment
  | RecogElemSlashEsc
  | RecogElemQuote
  | RecogElemUnquote
  | RecogElemBrace !Brace
  deriving stock (RecogElem -> RecogElem -> Bool
(RecogElem -> RecogElem -> Bool)
-> (RecogElem -> RecogElem -> Bool) -> Eq RecogElem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecogElem -> RecogElem -> Bool
== :: RecogElem -> RecogElem -> Bool
$c/= :: RecogElem -> RecogElem -> Bool
/= :: RecogElem -> RecogElem -> Bool
Eq, Eq RecogElem
Eq RecogElem =>
(RecogElem -> RecogElem -> Ordering)
-> (RecogElem -> RecogElem -> Bool)
-> (RecogElem -> RecogElem -> Bool)
-> (RecogElem -> RecogElem -> Bool)
-> (RecogElem -> RecogElem -> Bool)
-> (RecogElem -> RecogElem -> RecogElem)
-> (RecogElem -> RecogElem -> RecogElem)
-> Ord RecogElem
RecogElem -> RecogElem -> Bool
RecogElem -> RecogElem -> Ordering
RecogElem -> RecogElem -> RecogElem
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 :: RecogElem -> RecogElem -> Ordering
compare :: RecogElem -> RecogElem -> Ordering
$c< :: RecogElem -> RecogElem -> Bool
< :: RecogElem -> RecogElem -> Bool
$c<= :: RecogElem -> RecogElem -> Bool
<= :: RecogElem -> RecogElem -> Bool
$c> :: RecogElem -> RecogElem -> Bool
> :: RecogElem -> RecogElem -> Bool
$c>= :: RecogElem -> RecogElem -> Bool
>= :: RecogElem -> RecogElem -> Bool
$cmax :: RecogElem -> RecogElem -> RecogElem
max :: RecogElem -> RecogElem -> RecogElem
$cmin :: RecogElem -> RecogElem -> RecogElem
min :: RecogElem -> RecogElem -> RecogElem
Ord, Int -> RecogElem -> ShowS
[RecogElem] -> ShowS
RecogElem -> String
(Int -> RecogElem -> ShowS)
-> (RecogElem -> String)
-> ([RecogElem] -> ShowS)
-> Show RecogElem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecogElem -> ShowS
showsPrec :: Int -> RecogElem -> ShowS
$cshow :: RecogElem -> String
show :: RecogElem -> String
$cshowList :: [RecogElem] -> ShowS
showList :: [RecogElem] -> ShowS
Show)

newtype RecogErr
  = RecogErrMismatch Brace
  deriving stock (RecogErr -> RecogErr -> Bool
(RecogErr -> RecogErr -> Bool)
-> (RecogErr -> RecogErr -> Bool) -> Eq RecogErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecogErr -> RecogErr -> Bool
== :: RecogErr -> RecogErr -> Bool
$c/= :: RecogErr -> RecogErr -> Bool
/= :: RecogErr -> RecogErr -> Bool
Eq, Eq RecogErr
Eq RecogErr =>
(RecogErr -> RecogErr -> Ordering)
-> (RecogErr -> RecogErr -> Bool)
-> (RecogErr -> RecogErr -> Bool)
-> (RecogErr -> RecogErr -> Bool)
-> (RecogErr -> RecogErr -> Bool)
-> (RecogErr -> RecogErr -> RecogErr)
-> (RecogErr -> RecogErr -> RecogErr)
-> Ord RecogErr
RecogErr -> RecogErr -> Bool
RecogErr -> RecogErr -> Ordering
RecogErr -> RecogErr -> RecogErr
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 :: RecogErr -> RecogErr -> Ordering
compare :: RecogErr -> RecogErr -> Ordering
$c< :: RecogErr -> RecogErr -> Bool
< :: RecogErr -> RecogErr -> Bool
$c<= :: RecogErr -> RecogErr -> Bool
<= :: RecogErr -> RecogErr -> Bool
$c> :: RecogErr -> RecogErr -> Bool
> :: RecogErr -> RecogErr -> Bool
$c>= :: RecogErr -> RecogErr -> Bool
>= :: RecogErr -> RecogErr -> Bool
$cmax :: RecogErr -> RecogErr -> RecogErr
max :: RecogErr -> RecogErr -> RecogErr
$cmin :: RecogErr -> RecogErr -> RecogErr
min :: RecogErr -> RecogErr -> RecogErr
Ord, Int -> RecogErr -> ShowS
[RecogErr] -> ShowS
RecogErr -> String
(Int -> RecogErr -> ShowS)
-> (RecogErr -> String) -> ([RecogErr] -> ShowS) -> Show RecogErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecogErr -> ShowS
showsPrec :: Int -> RecogErr -> ShowS
$cshow :: RecogErr -> String
show :: RecogErr -> String
$cshowList :: [RecogErr] -> ShowS
showList :: [RecogErr] -> ShowS
Show)

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

initRecogState :: RecogState
initRecogState :: RecogState
initRecogState = Int -> [RecogElem] -> RecogState
RecogState Int
0 []

type RecogM = ExceptT RecogErr (State RecogState)

data CharCase
  = CharCaseNewline
  | CharCaseDoubleQuote
  | CharCaseSingleQuote
  | CharCaseOpenComment
  | CharCaseSlashEsc
  | CharCaseOpenBrace !Brace
  | CharCaseCloseBrace !Brace
  deriving stock (CharCase -> CharCase -> Bool
(CharCase -> CharCase -> Bool)
-> (CharCase -> CharCase -> Bool) -> Eq CharCase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CharCase -> CharCase -> Bool
== :: CharCase -> CharCase -> Bool
$c/= :: CharCase -> CharCase -> Bool
/= :: CharCase -> CharCase -> Bool
Eq, Eq CharCase
Eq CharCase =>
(CharCase -> CharCase -> Ordering)
-> (CharCase -> CharCase -> Bool)
-> (CharCase -> CharCase -> Bool)
-> (CharCase -> CharCase -> Bool)
-> (CharCase -> CharCase -> Bool)
-> (CharCase -> CharCase -> CharCase)
-> (CharCase -> CharCase -> CharCase)
-> Ord CharCase
CharCase -> CharCase -> Bool
CharCase -> CharCase -> Ordering
CharCase -> CharCase -> CharCase
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 :: CharCase -> CharCase -> Ordering
compare :: CharCase -> CharCase -> Ordering
$c< :: CharCase -> CharCase -> Bool
< :: CharCase -> CharCase -> Bool
$c<= :: CharCase -> CharCase -> Bool
<= :: CharCase -> CharCase -> Bool
$c> :: CharCase -> CharCase -> Bool
> :: CharCase -> CharCase -> Bool
$c>= :: CharCase -> CharCase -> Bool
>= :: CharCase -> CharCase -> Bool
$cmax :: CharCase -> CharCase -> CharCase
max :: CharCase -> CharCase -> CharCase
$cmin :: CharCase -> CharCase -> CharCase
min :: CharCase -> CharCase -> CharCase
Ord, Int -> CharCase -> ShowS
[CharCase] -> ShowS
CharCase -> String
(Int -> CharCase -> ShowS)
-> (CharCase -> String) -> ([CharCase] -> ShowS) -> Show CharCase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CharCase -> ShowS
showsPrec :: Int -> CharCase -> ShowS
$cshow :: CharCase -> String
show :: CharCase -> String
$cshowList :: [CharCase] -> ShowS
showList :: [CharCase] -> ShowS
Show)

readCharCase :: Char -> Maybe CharCase
readCharCase :: Char -> Maybe CharCase
readCharCase Char
c =
  if
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' -> CharCase -> Maybe CharCase
forall a. a -> Maybe a
Just CharCase
CharCaseNewline
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' -> CharCase -> Maybe CharCase
forall a. a -> Maybe a
Just CharCase
CharCaseDoubleQuote
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' -> CharCase -> Maybe CharCase
forall a. a -> Maybe a
Just CharCase
CharCaseSingleQuote
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';' -> CharCase -> Maybe CharCase
forall a. a -> Maybe a
Just CharCase
CharCaseOpenComment
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' -> CharCase -> Maybe CharCase
forall a. a -> Maybe a
Just CharCase
CharCaseSlashEsc
    | Bool
otherwise ->
        case Char -> Maybe Brace
readOpenBrace Char
c of
          Just Brace
b -> CharCase -> Maybe CharCase
forall a. a -> Maybe a
Just (Brace -> CharCase
CharCaseOpenBrace Brace
b)
          Maybe Brace
Nothing -> case Char -> Maybe Brace
readCloseBrace Char
c of
            Just Brace
b -> CharCase -> Maybe CharCase
forall a. a -> Maybe a
Just (Brace -> CharCase
CharCaseCloseBrace Brace
b)
            Maybe Brace
Nothing -> Maybe CharCase
forall a. Maybe a
Nothing

stepR :: Char -> RecogM ()
stepR :: Char -> RecogM ()
stepR Char
c = RecogM ()
goRet
 where
  goRet :: RecogM ()
goRet = RecogM ()
goStart RecogM () -> RecogM () -> RecogM ()
forall a b.
ExceptT RecogErr (State RecogState) a
-> ExceptT RecogErr (State RecogState) b
-> ExceptT RecogErr (State RecogState) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RecogM ()
incOffset
  goStart :: RecogM ()
goStart = do
    Maybe RecogElem
mh <- ExceptT RecogErr (State RecogState) (Maybe RecogElem)
peekStack
    case Maybe RecogElem
mh of
      Just RecogElem
RecogElemString -> RecogM ()
goString
      Just RecogElem
RecogElemChar -> RecogM ()
goChar
      Just RecogElem
RecogElemComment -> RecogM ()
goComment
      Just RecogElem
RecogElemSlashEsc -> RecogM ()
goSlashEsc
      Just RecogElem
RecogElemQuote -> RecogM ()
forall {a}. a
goQuote
      Just RecogElem
RecogElemUnquote -> RecogM ()
forall {a}. a
goUnquote
      Just (RecogElemBrace Brace
b) -> Maybe Brace -> RecogM ()
goDefault (Brace -> Maybe Brace
forall a. a -> Maybe a
Just Brace
b)
      Maybe RecogElem
Nothing -> Maybe Brace -> RecogM ()
goDefault Maybe Brace
forall a. Maybe a
Nothing
  goString :: RecogM ()
goString = case Char -> Maybe CharCase
readCharCase Char
c of
    Just CharCase
CharCaseDoubleQuote -> RecogM ()
popStack
    Just CharCase
CharCaseSlashEsc -> RecogElem -> RecogM ()
forall {m :: * -> *}. MonadState RecogState m => RecogElem -> m ()
pushStack RecogElem
RecogElemSlashEsc
    Maybe CharCase
_ -> () -> RecogM ()
forall a. a -> ExceptT RecogErr (State RecogState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  goChar :: RecogM ()
goChar = case Char -> Maybe CharCase
readCharCase Char
c of
    Just CharCase
CharCaseSingleQuote -> RecogM ()
popStack
    Just CharCase
CharCaseSlashEsc -> RecogElem -> RecogM ()
forall {m :: * -> *}. MonadState RecogState m => RecogElem -> m ()
pushStack RecogElem
RecogElemSlashEsc
    Maybe CharCase
_ -> () -> RecogM ()
forall a. a -> ExceptT RecogErr (State RecogState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  goComment :: RecogM ()
goComment = case Char -> Maybe CharCase
readCharCase Char
c of
    Just CharCase
CharCaseNewline -> RecogM ()
popStack
    Maybe CharCase
_ -> () -> RecogM ()
forall a. a -> ExceptT RecogErr (State RecogState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  goSlashEsc :: RecogM ()
goSlashEsc = RecogM ()
popStack -- just ignore input and leave slash esc mode
  goQuote :: a
goQuote = String -> a
forall a. HasCallStack => String -> a
error String
"TODO"
  goUnquote :: a
goUnquote = String -> a
forall a. HasCallStack => String -> a
error String
"TODO"
  goDefault :: Maybe Brace -> RecogM ()
goDefault Maybe Brace
mb = case Char -> Maybe CharCase
readCharCase Char
c of
    Just CharCase
CharCaseDoubleQuote -> RecogElem -> RecogM ()
forall {m :: * -> *}. MonadState RecogState m => RecogElem -> m ()
pushStack RecogElem
RecogElemString
    Just CharCase
CharCaseSingleQuote -> RecogElem -> RecogM ()
forall {m :: * -> *}. MonadState RecogState m => RecogElem -> m ()
pushStack RecogElem
RecogElemChar
    Just CharCase
CharCaseOpenComment -> RecogElem -> RecogM ()
forall {m :: * -> *}. MonadState RecogState m => RecogElem -> m ()
pushStack RecogElem
RecogElemComment
    Just (CharCaseOpenBrace Brace
b) -> RecogElem -> RecogM ()
forall {m :: * -> *}. MonadState RecogState m => RecogElem -> m ()
pushStack (Brace -> RecogElem
RecogElemBrace Brace
b)
    Just (CharCaseCloseBrace Brace
b) ->
      case Maybe Brace
mb of
        Just Brace
b0 | Brace
b Brace -> Brace -> Bool
forall a. Eq a => a -> a -> Bool
== Brace
b0 -> RecogM ()
popStack
        Maybe Brace
_ -> RecogErr -> RecogM ()
forall a. RecogErr -> ExceptT RecogErr (State RecogState) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Brace -> RecogErr
RecogErrMismatch Brace
b)
    Maybe CharCase
_ -> () -> RecogM ()
forall a. a -> ExceptT RecogErr (State RecogState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  incOffset :: RecogM ()
incOffset = (RecogState -> RecogState) -> RecogM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\RecogState
s -> RecogState
s {rsOffset = rsOffset s + 1})
  pushStack :: RecogElem -> m ()
pushStack RecogElem
h = (RecogState -> RecogState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\RecogState
s -> RecogState
s {rsStack = h : rsStack s})
  popStack :: RecogM ()
popStack = (RecogState -> RecogState) -> RecogM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((RecogState -> RecogState) -> RecogM ())
-> (RecogState -> RecogState) -> RecogM ()
forall a b. (a -> b) -> a -> b
$ \RecogState
s ->
    case RecogState -> [RecogElem]
rsStack RecogState
s of
      [] -> RecogState
s
      RecogElem
_ : [RecogElem]
t -> RecogState
s {rsStack = t}
  peekStack :: ExceptT RecogErr (State RecogState) (Maybe RecogElem)
peekStack = (RecogState -> Maybe RecogElem)
-> ExceptT RecogErr (State RecogState) (Maybe RecogElem)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((RecogState -> Maybe RecogElem)
 -> ExceptT RecogErr (State RecogState) (Maybe RecogElem))
-> (RecogState -> Maybe RecogElem)
-> ExceptT RecogErr (State RecogState) (Maybe RecogElem)
forall a b. (a -> b) -> a -> b
$ \RecogState
s ->
    case RecogState -> [RecogElem]
rsStack RecogState
s of
      [] -> Maybe RecogElem
forall a. Maybe a
Nothing
      RecogElem
h : [RecogElem]
_ -> RecogElem -> Maybe RecogElem
forall a. a -> Maybe a
Just RecogElem
h

extractR :: Maybe RecogErr -> RecogState -> Either RecogErr Bool
extractR :: Maybe RecogErr -> RecogState -> Either RecogErr Bool
extractR Maybe RecogErr
me RecogState
s = Either RecogErr Bool
-> (RecogErr -> Either RecogErr Bool)
-> Maybe RecogErr
-> Either RecogErr Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Either RecogErr Bool
forall a b. b -> Either a b
Right ([RecogElem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RecogState -> [RecogElem]
rsStack RecogState
s))) RecogErr -> Either RecogErr Bool
forall a b. a -> Either a b
Left Maybe RecogErr
me

-- TODO expose this when quote/unquote recognition is implemented
-- and it's all tested
sexpRecognizer :: Fold Char (Either RecogErr Bool)
sexpRecognizer :: Fold Char (Either RecogErr Bool)
sexpRecognizer = (Char -> RecogM ())
-> RecogState
-> (Maybe RecogErr -> RecogState -> Either RecogErr Bool)
-> Fold Char (Either RecogErr Bool)
forall a e s b.
(a -> ExceptT e (State s) ())
-> s -> (Maybe e -> s -> b) -> Fold a b
foldUntilErr Char -> RecogM ()
stepR RecogState
initRecogState Maybe RecogErr -> RecogState -> Either RecogErr Bool
extractR