Parser.hs

{-# LANGUAGE InstanceSigs #-}
module Parser.Parser where

import Common

import Control.Applicative
import Control.Monad.IO.Class
import Data.String (IsString(..))
import Data.Text as T

data ParseErrorWithParsed a = ParseErrorWithParsed
  { parialResult :: Maybe a
  , errorAt :: Location
  , parseError :: ParseError
  } deriving (Eq, Show)

instance HReadable (ParseErrorWithParsed a) where
  hReadable ParseErrorWithParsed {..} = "Incomplete parse: Error at: " <> (hReadable errorAt) <> " Error:" <> (hReadable parseError)

data FatalParseError
  = IncompleteParse
  | CustomError Text
  deriving (Show, Eq)

instance HReadable FatalParseError where
  hReadable = \case
    IncompleteParse -> "Input does not match any known pattern at location"
    CustomError msg -> "Fatal parse error:" <> msg

moveLines :: Location -> Int -> Location
moveLines Location {..} lc = let
  lcNewLine = lcLine + lc
  in Location {lcLine = lcNewLine, lcColumn = 0, ..}

moveCols :: Location -> Int -> Location
moveCols Location {..} lc = let
  lcNewColumn = lcColumn + lc
  in Location {lcColumn = lcNewColumn, ..}

data ParseError
  = CantHandle
  | Empty
  | FatalErrorWithLocation Location FatalParseError
  | FatalError FatalParseError
  deriving (Show, Eq)

instance HReadable ParseError where
  hReadable = \case
    CantHandle -> "Parser can't handle this input"
    Empty -> "The input was empty"
    FatalErrorWithLocation l fp -> "Fatal parse error:" <> (hReadable fp) <>  " at:" <> (hReadable l)
    FatalError fp -> "Fatal parse error:" <> (hReadable fp)

class HaveLocation a where
  getLocation :: a -> Location

getParserLocation :: (Monad m, HaveLocation s) => ParserM m s Location
getParserLocation = ParserM "" $ \s -> pure (Right $ getLocation s, s)

data ParserM m s a = ParserM Text (s -> m (Either ParseError a, s))

data TextWithOffset = TextWithOffset
  { twText     :: Text
  , twLocation :: Location
  } deriving (Eq, Show)

class HasEof a where
  isEof :: a -> Bool

instance ToSource TextWithOffset where
  toSource = twText

instance HasEof TextWithOffset where
  isEof (TextWithOffset "" _) = True
  isEof _                     = False

instance HasEmpty TextWithOffset where
  isEmpty t = twText t == ""

toTextWithOffset :: Text -> TextWithOffset
toTextWithOffset t = TextWithOffset t emptyLocation

instance HaveLocation TextWithOffset where
  getLocation = twLocation

instance IsString s => IsString TextWithOffset where
  fromString s = toTextWithOffset $ T.pack s

class HasLogIndent a where
  incIndent :: a -> a
  decIndent :: a -> a
  logInfo :: MonadIO m => Text -> a -> m ()

instance Show a => HasLogIndent a where
  incIndent a = a
  decIndent a = a
  logInfo _ _ = pure ()

type Parser a = ParserM IO TextWithOffset a

type ParserC m s = (MonadIO m, HasLogIndent s, ToSource s)

instance ParserC m s => Functor (ParserM m s) where
  fmap f (ParserM name a) = ParserM name (\s -> (a $ incIndent s) >>= \case
    (Right a', s') -> pure (Right $ f a', s')
    (Left e, _)    -> pure (Left e, s))

instance ParserC m s => Applicative (ParserM m s) where
  pure a = ParserM "pure" (\s -> pure (Right a, s))
  (ParserM name1 f1) <*> (ParserM name2 f2) = ParserM (name2 <> " after " <> name1)
    (\s -> (do logInfo name1 s; f1 $ incIndent s) >>= \case
      (Right fn, rst)  -> (f2 $ decIndent rst) >>= \case
        (mf, rst1) -> pure (fn <$> mf, decIndent rst1)
      (Left err, s') -> pure (Left err, decIndent s')
    )

instance ParserC m s => Monad (ParserM m s) where
  return = pure
  (ParserM name1 f1) >>= f  =
    ParserM name1 (\s -> (do logInfo name1 s; f1 $ incIndent s) >>= \case
          (Right a1, rst) ->
            let
              (ParserM name2 f2) = f a1
              rst' = decIndent rst
            in do
              logInfo ("success " <> name1) rst'
              logInfo ("parsing " <> name2) rst'
              f2 rst'
          (Left err, s') -> do
            logInfo ("failed " <> name1) s'
            pure (Left err, s'))

instance ParserC m s => Alternative (ParserM m s) where
  (ParserM name1 f1) <|> (ParserM name2 f2) = ParserM ("(" <> name1 <> ")"  <> " or (" <> name2 <> ")") (\s -> (do logInfo name1 s; f1 s)>>= \case
    (Left e@(FatalError _), s')               -> pure (Left e, s')
    (Left e@(FatalErrorWithLocation _ _), s') -> pure (Left e, s')
    (Left _, _)                               -> f2 s
    a                                         -> pure a )
  empty = ParserM "empty" (\s -> pure (Left Empty, s))
  many p@(ParserM name _) = let (ParserM _ fn) = ((some p) <|> (pure [])) in ParserM ("many of " <> name) fn
  some (ParserM name fn) = ParserM ("some of " <> name) (\s -> collect ([], s) >>= \case
      (Right [], _)          -> pure (Left CantHandle, s)
      (Right (r@(_:_)), rst) -> pure (Right (Prelude.reverse r), rst)
      (Left err, rst)        -> pure (Left err, rst))
    where
      collect (i, s) = fn s >>= \case
        (Right a, rst)                            -> collect ((a:i), rst)
        (Left e@(FatalError _), s')               -> pure (Left e, s')
        (Left e@(FatalErrorWithLocation _ _), s') -> pure (Left e, s')
        (Left _, _)                               -> pure (Right i, s)

instance (ParserC m s, HaveLocation s) => MonadFail (ParserM m s) where
  fail err = ParserM "fail" (\s -> pure (Left (FatalErrorWithLocation (getLocation s) $ CustomError $ pack err), s))

instance (ParserC m s, MonadIO m) => MonadIO (ParserM m s) where
  liftIO io = ParserM "liftIO" (\s -> do
    r <- liftIO io
    pure (Right r, s))