{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TypeFamilies #-}

module Aihc.Parser.Types
  ( TokStream (..),
    ParseErrorBundle,
    lexerErrorBundle,
    ParseResult (..),
    ParserConfig (..),
  )
where

import Aihc.Parser.Lex (LexToken (..))
import Aihc.Parser.Syntax (Extension, SourceSpan (..))
import Control.DeepSeq (NFData (..))
import Data.List.NonEmpty qualified as NE
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Void (Void)
import GHC.Generics (Generic)
import Text.Megaparsec qualified as MP
import Text.Megaparsec.Error qualified as MPE
import Text.Megaparsec.Pos (SourcePos (..), mkPos)
import Text.Megaparsec.Stream (Stream (..), TraversableStream (..), VisualStream (..))

-- | Parse error from token parser. Use 'errorBundlePretty' from "Parser" to render.
type ParseErrorBundle = MPE.ParseErrorBundle TokStream Void

lexerErrorBundle :: FilePath -> String -> ParseErrorBundle
lexerErrorBundle :: FilePath -> FilePath -> ParseErrorBundle
lexerErrorBundle FilePath
sourcePath FilePath
message =
  NonEmpty (ParseError TokStream Void)
-> PosState TokStream -> ParseErrorBundle
forall s e.
NonEmpty (ParseError s e) -> PosState s -> ParseErrorBundle s e
MPE.ParseErrorBundle
    (ParseError TokStream Void -> NonEmpty (ParseError TokStream Void)
forall a. a -> NonEmpty a
NE.singleton (Int -> Set (ErrorFancy Void) -> ParseError TokStream Void
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
MPE.FancyError Int
0 (ErrorFancy Void -> Set (ErrorFancy Void)
forall a. a -> Set a
Set.singleton (FilePath -> ErrorFancy Void
forall e. FilePath -> ErrorFancy e
MPE.ErrorFail FilePath
message))))
    MP.PosState
      { pstateInput :: TokStream
MP.pstateInput = [LexToken] -> TokStream
TokStream [],
        pstateOffset :: Int
MP.pstateOffset = Int
0,
        pstateSourcePos :: SourcePos
MP.pstateSourcePos = FilePath -> Pos -> Pos -> SourcePos
SourcePos FilePath
sourcePath (Int -> Pos
mkPos Int
1) (Int -> Pos
mkPos Int
1),
        pstateTabWidth :: Pos
MP.pstateTabWidth = Int -> Pos
mkPos Int
8,
        pstateLinePrefix :: FilePath
MP.pstateLinePrefix = FilePath
""
      }

newtype TokStream = TokStream
  { TokStream -> [LexToken]
unTokStream :: [LexToken]
  }
  deriving (TokStream -> TokStream -> Bool
(TokStream -> TokStream -> Bool)
-> (TokStream -> TokStream -> Bool) -> Eq TokStream
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TokStream -> TokStream -> Bool
== :: TokStream -> TokStream -> Bool
$c/= :: TokStream -> TokStream -> Bool
/= :: TokStream -> TokStream -> Bool
Eq, Eq TokStream
Eq TokStream =>
(TokStream -> TokStream -> Ordering)
-> (TokStream -> TokStream -> Bool)
-> (TokStream -> TokStream -> Bool)
-> (TokStream -> TokStream -> Bool)
-> (TokStream -> TokStream -> Bool)
-> (TokStream -> TokStream -> TokStream)
-> (TokStream -> TokStream -> TokStream)
-> Ord TokStream
TokStream -> TokStream -> Bool
TokStream -> TokStream -> Ordering
TokStream -> TokStream -> TokStream
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 :: TokStream -> TokStream -> Ordering
compare :: TokStream -> TokStream -> Ordering
$c< :: TokStream -> TokStream -> Bool
< :: TokStream -> TokStream -> Bool
$c<= :: TokStream -> TokStream -> Bool
<= :: TokStream -> TokStream -> Bool
$c> :: TokStream -> TokStream -> Bool
> :: TokStream -> TokStream -> Bool
$c>= :: TokStream -> TokStream -> Bool
>= :: TokStream -> TokStream -> Bool
$cmax :: TokStream -> TokStream -> TokStream
max :: TokStream -> TokStream -> TokStream
$cmin :: TokStream -> TokStream -> TokStream
min :: TokStream -> TokStream -> TokStream
Ord, Int -> TokStream -> ShowS
[TokStream] -> ShowS
TokStream -> FilePath
(Int -> TokStream -> ShowS)
-> (TokStream -> FilePath)
-> ([TokStream] -> ShowS)
-> Show TokStream
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TokStream -> ShowS
showsPrec :: Int -> TokStream -> ShowS
$cshow :: TokStream -> FilePath
show :: TokStream -> FilePath
$cshowList :: [TokStream] -> ShowS
showList :: [TokStream] -> ShowS
Show, (forall x. TokStream -> Rep TokStream x)
-> (forall x. Rep TokStream x -> TokStream) -> Generic TokStream
forall x. Rep TokStream x -> TokStream
forall x. TokStream -> Rep TokStream x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TokStream -> Rep TokStream x
from :: forall x. TokStream -> Rep TokStream x
$cto :: forall x. Rep TokStream x -> TokStream
to :: forall x. Rep TokStream x -> TokStream
Generic)
  deriving newtype (TokStream -> ()
(TokStream -> ()) -> NFData TokStream
forall a. (a -> ()) -> NFData a
$crnf :: TokStream -> ()
rnf :: TokStream -> ()
NFData)

instance Stream TokStream where
  type Token TokStream = LexToken
  type Tokens TokStream = [LexToken]

  tokenToChunk :: Proxy TokStream -> Token TokStream -> Tokens TokStream
tokenToChunk Proxy TokStream
_ Token TokStream
tok = [Token TokStream
LexToken
tok]
  tokensToChunk :: Proxy TokStream -> [Token TokStream] -> Tokens TokStream
tokensToChunk Proxy TokStream
_ = [Token TokStream] -> Tokens TokStream
[LexToken] -> [LexToken]
forall a. a -> a
id
  chunkToTokens :: Proxy TokStream -> Tokens TokStream -> [Token TokStream]
chunkToTokens Proxy TokStream
_ = [LexToken] -> [LexToken]
Tokens TokStream -> [Token TokStream]
forall a. a -> a
id
  chunkLength :: Proxy TokStream -> Tokens TokStream -> Int
chunkLength Proxy TokStream
_ = [LexToken] -> Int
Tokens TokStream -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
  chunkEmpty :: Proxy TokStream -> Tokens TokStream -> Bool
chunkEmpty Proxy TokStream
_ = [LexToken] -> Bool
Tokens TokStream -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null

  take1_ :: TokStream -> Maybe (Token TokStream, TokStream)
take1_ (TokStream [LexToken]
toks) =
    case [LexToken]
toks of
      [] -> Maybe (Token TokStream, TokStream)
Maybe (LexToken, TokStream)
forall a. Maybe a
Nothing
      LexToken
tok : [LexToken]
rest -> (LexToken, TokStream) -> Maybe (LexToken, TokStream)
forall a. a -> Maybe a
Just (LexToken
tok, [LexToken] -> TokStream
TokStream [LexToken]
rest)

  takeN_ :: Int -> TokStream -> Maybe (Tokens TokStream, TokStream)
takeN_ Int
n (TokStream [LexToken]
toks)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = ([LexToken], TokStream) -> Maybe ([LexToken], TokStream)
forall a. a -> Maybe a
Just ([], [LexToken] -> TokStream
TokStream [LexToken]
toks)
    | [LexToken] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LexToken]
toks = Maybe ([LexToken], TokStream)
Maybe (Tokens TokStream, TokStream)
forall a. Maybe a
Nothing
    | Bool
otherwise =
        let ([LexToken]
chunk, [LexToken]
rest) = Int -> [LexToken] -> ([LexToken], [LexToken])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [LexToken]
toks
         in ([LexToken], TokStream) -> Maybe ([LexToken], TokStream)
forall a. a -> Maybe a
Just ([LexToken]
chunk, [LexToken] -> TokStream
TokStream [LexToken]
rest)

  takeWhile_ :: (Token TokStream -> Bool)
-> TokStream -> (Tokens TokStream, TokStream)
takeWhile_ Token TokStream -> Bool
f (TokStream [LexToken]
toks) =
    let ([LexToken]
chunk, [LexToken]
rest) = (LexToken -> Bool) -> [LexToken] -> ([LexToken], [LexToken])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Token TokStream -> Bool
LexToken -> Bool
f [LexToken]
toks
     in ([LexToken]
Tokens TokStream
chunk, [LexToken] -> TokStream
TokStream [LexToken]
rest)

instance VisualStream TokStream where
  showTokens :: Proxy TokStream -> NonEmpty (Token TokStream) -> FilePath
showTokens Proxy TokStream
_ NonEmpty (Token TokStream)
toks =
    Text -> FilePath
T.unpack (Text -> [Text] -> Text
T.intercalate (FilePath -> Text
T.pack FilePath
" ") [LexToken -> Text
lexTokenText LexToken
tok | LexToken
tok <- NonEmpty LexToken -> [LexToken]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Token TokStream)
NonEmpty LexToken
toks])

instance TraversableStream TokStream where
  reachOffset :: Int -> PosState TokStream -> (Maybe FilePath, PosState TokStream)
reachOffset Int
o PosState TokStream
pst =
    let currOff :: Int
currOff = PosState TokStream -> Int
forall s. PosState s -> Int
MP.pstateOffset PosState TokStream
pst
        currInput :: [LexToken]
currInput = TokStream -> [LexToken]
unTokStream (PosState TokStream -> TokStream
forall s. PosState s -> s
MP.pstateInput PosState TokStream
pst)
        advance :: Int
advance = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currOff)
        ([LexToken]
consumed, [LexToken]
rest) = Int -> [LexToken] -> ([LexToken], [LexToken])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
advance [LexToken]
currInput
        currPos :: SourcePos
currPos = PosState TokStream -> SourcePos
forall s. PosState s -> SourcePos
MP.pstateSourcePos PosState TokStream
pst
        newPos :: SourcePos
newPos =
          case [LexToken]
rest of
            LexToken
tok : [LexToken]
_ -> FilePath -> SourceSpan -> SourcePos
sourcePosFromStartSpan (SourcePos -> FilePath
sourceName SourcePos
currPos) (LexToken -> SourceSpan
lexTokenSpan LexToken
tok)
            [] ->
              case [LexToken] -> [LexToken]
forall a. [a] -> [a]
reverse [LexToken]
consumed of
                LexToken
tok : [LexToken]
_ -> FilePath -> SourceSpan -> SourcePos
sourcePosFromEndSpan (SourcePos -> FilePath
sourceName SourcePos
currPos) (LexToken -> SourceSpan
lexTokenSpan LexToken
tok)
                [] -> SourcePos
currPos
        pst' :: PosState TokStream
pst' =
          PosState TokStream
pst
            { MP.pstateInput = TokStream rest,
              MP.pstateOffset = currOff + advance,
              MP.pstateSourcePos = newPos
            }
     in (Maybe FilePath
forall a. Maybe a
Nothing, PosState TokStream
pst')

sourcePosFromStartSpan :: FilePath -> SourceSpan -> SourcePos
sourcePosFromStartSpan :: FilePath -> SourceSpan -> SourcePos
sourcePosFromStartSpan FilePath
file SourceSpan
span' =
  case SourceSpan
span' of
    SourceSpan Int
line Int
col Int
_ Int
_ -> FilePath -> Pos -> Pos -> SourcePos
SourcePos FilePath
file (Int -> Pos
mkPos (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
line)) (Int -> Pos
mkPos (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
col))
    SourceSpan
NoSourceSpan -> FilePath -> Pos -> Pos -> SourcePos
SourcePos FilePath
file (Int -> Pos
mkPos Int
1) (Int -> Pos
mkPos Int
1)

sourcePosFromEndSpan :: FilePath -> SourceSpan -> SourcePos
sourcePosFromEndSpan :: FilePath -> SourceSpan -> SourcePos
sourcePosFromEndSpan FilePath
file SourceSpan
span' =
  case SourceSpan
span' of
    SourceSpan Int
_ Int
_ Int
line Int
col -> FilePath -> Pos -> Pos -> SourcePos
SourcePos FilePath
file (Int -> Pos
mkPos (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
line)) (Int -> Pos
mkPos (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
col))
    SourceSpan
NoSourceSpan -> FilePath -> Pos -> Pos -> SourcePos
SourcePos FilePath
file (Int -> Pos
mkPos Int
1) (Int -> Pos
mkPos Int
1)

data ParserConfig = ParserConfig
  { ParserConfig -> FilePath
parserSourceName :: FilePath,
    ParserConfig -> [Extension]
parserExtensions :: [Extension]
  }
  deriving (ParserConfig -> ParserConfig -> Bool
(ParserConfig -> ParserConfig -> Bool)
-> (ParserConfig -> ParserConfig -> Bool) -> Eq ParserConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParserConfig -> ParserConfig -> Bool
== :: ParserConfig -> ParserConfig -> Bool
$c/= :: ParserConfig -> ParserConfig -> Bool
/= :: ParserConfig -> ParserConfig -> Bool
Eq, Int -> ParserConfig -> ShowS
[ParserConfig] -> ShowS
ParserConfig -> FilePath
(Int -> ParserConfig -> ShowS)
-> (ParserConfig -> FilePath)
-> ([ParserConfig] -> ShowS)
-> Show ParserConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParserConfig -> ShowS
showsPrec :: Int -> ParserConfig -> ShowS
$cshow :: ParserConfig -> FilePath
show :: ParserConfig -> FilePath
$cshowList :: [ParserConfig] -> ShowS
showList :: [ParserConfig] -> ShowS
Show, (forall x. ParserConfig -> Rep ParserConfig x)
-> (forall x. Rep ParserConfig x -> ParserConfig)
-> Generic ParserConfig
forall x. Rep ParserConfig x -> ParserConfig
forall x. ParserConfig -> Rep ParserConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ParserConfig -> Rep ParserConfig x
from :: forall x. ParserConfig -> Rep ParserConfig x
$cto :: forall x. Rep ParserConfig x -> ParserConfig
to :: forall x. Rep ParserConfig x -> ParserConfig
Generic, ParserConfig -> ()
(ParserConfig -> ()) -> NFData ParserConfig
forall a. (a -> ()) -> NFData a
$crnf :: ParserConfig -> ()
rnf :: ParserConfig -> ()
NFData)

data ParseResult a
  = ParseOk a
  | ParseErr ParseErrorBundle
  deriving (ParseResult a -> ParseResult a -> Bool
(ParseResult a -> ParseResult a -> Bool)
-> (ParseResult a -> ParseResult a -> Bool) -> Eq (ParseResult a)
forall a. Eq a => ParseResult a -> ParseResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => ParseResult a -> ParseResult a -> Bool
== :: ParseResult a -> ParseResult a -> Bool
$c/= :: forall a. Eq a => ParseResult a -> ParseResult a -> Bool
/= :: ParseResult a -> ParseResult a -> Bool
Eq, Int -> ParseResult a -> ShowS
[ParseResult a] -> ShowS
ParseResult a -> FilePath
(Int -> ParseResult a -> ShowS)
-> (ParseResult a -> FilePath)
-> ([ParseResult a] -> ShowS)
-> Show (ParseResult a)
forall a. Show a => Int -> ParseResult a -> ShowS
forall a. Show a => [ParseResult a] -> ShowS
forall a. Show a => ParseResult a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ParseResult a -> ShowS
showsPrec :: Int -> ParseResult a -> ShowS
$cshow :: forall a. Show a => ParseResult a -> FilePath
show :: ParseResult a -> FilePath
$cshowList :: forall a. Show a => [ParseResult a] -> ShowS
showList :: [ParseResult a] -> ShowS
Show)

instance (NFData a) => NFData (ParseResult a) where
  rnf :: ParseResult a -> ()
rnf ParseResult a
parseResult =
    case ParseResult a
parseResult of
      ParseOk a
parsed -> a -> ()
forall a. NFData a => a -> ()
rnf a
parsed
      ParseErr ParseErrorBundle
bundle -> FilePath -> ()
forall a. NFData a => a -> ()
rnf (ParseErrorBundle -> FilePath
forall a. Show a => a -> FilePath
show ParseErrorBundle
bundle)