module Unison.Syntax.Lexer.Unison
  ( Token (..),
    Line,
    Column,
    Err (..),
    Pos (..),
    Lexeme (..),
    lexer,
    preParse,
    escapeChars,
    debugFilePreParse,
    debugPreParse,
    debugPreParse',
    showEscapeChar,
    touches,

    -- * Lexers
    typeOrTerm,

    -- * Character classifiers
    wordyIdChar,
    wordyIdStartChar,
    symbolyIdChar,

    -- * Error formatting
    formatTrivialError,
    displayLexeme,
  )
where

import Control.Lens qualified as Lens
import Control.Monad.State qualified as S
import Data.Char (isAlphaNum, isDigit, isSpace, ord, toLower)
import Data.Foldable qualified as Foldable
import Data.Functor.Classes (Show1 (..), showsPrec1)
import Data.List qualified as List
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as Nel
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import GHC.Exts (sortWith)
import Text.Megaparsec qualified as P
import Text.Megaparsec.Char (char)
import Text.Megaparsec.Char qualified as CP
import Text.Megaparsec.Char.Lexer qualified as LP
import Text.Megaparsec.Error qualified as EP
import Text.Megaparsec.Internal qualified as PI
import U.Codebase.Reference (ReferenceType (..))
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment qualified as NameSegment (docSegment)
import Unison.Prelude
import Unison.ShortHash (ShortHash)
import Unison.ShortHash qualified as SH
import Unison.Syntax.HashQualifiedPrime qualified as HQ' (toText)
import Unison.Syntax.Lexer
import Unison.Syntax.Lexer.Token (posP, tokenP)
import Unison.Syntax.Name qualified as Name (isSymboly, nameP, toText, unsafeParseText)
import Unison.Syntax.NameSegment qualified as NameSegment (ParseErr (..))
import Unison.Syntax.Parser.Doc qualified as Doc
import Unison.Syntax.Parser.Doc.Data qualified as Doc
import Unison.Syntax.ReservedWords (delimiters, typeModifiers, typeOrAbility)
import Unison.Syntax.ShortHash qualified as ShortHash (shortHashP)
import Unison.Util.Bytes qualified as Bytes
import Unison.Util.Monoid (intercalateMap)

type BlockName = String

type Layout = [(BlockName, Column)]

data ParsingEnv = ParsingEnv
  { -- | layout stack
    ParsingEnv -> Layout
layout :: !Layout,
    -- | `Just b` if a block of type `b` is being opened
    ParsingEnv -> Maybe String
opening :: Maybe BlockName,
    -- | are we inside a construct that uses layout?
    ParsingEnv -> Bool
inLayout :: Bool
  }
  deriving (Line -> ParsingEnv -> ShowS
[ParsingEnv] -> ShowS
ParsingEnv -> String
(Line -> ParsingEnv -> ShowS)
-> (ParsingEnv -> String)
-> ([ParsingEnv] -> ShowS)
-> Show ParsingEnv
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Line -> ParsingEnv -> ShowS
showsPrec :: Line -> ParsingEnv -> ShowS
$cshow :: ParsingEnv -> String
show :: ParsingEnv -> String
$cshowList :: [ParsingEnv] -> ShowS
showList :: [ParsingEnv] -> ShowS
Show)

initialEnv :: BlockName -> ParsingEnv
initialEnv :: String -> ParsingEnv
initialEnv String
scope = Layout -> Maybe String -> Bool -> ParsingEnv
ParsingEnv [] (String -> Maybe String
forall a. a -> Maybe a
Just String
scope) Bool
True

type P = P.ParsecT (Token Err) String (S.State ParsingEnv)

data Err
  = ReservedWordyId String
  | InvalidSymbolyId String
  | ReservedSymbolyId String
  | InvalidShortHash String
  | InvalidBytesLiteral String
  | InvalidHexLiteral
  | InvalidOctalLiteral
  | InvalidBinaryLiteral
  | Both Err Err
  | MissingFractional String -- ex `1.` rather than `1.04`
  | MissingExponent String -- ex `1e` rather than `1e3`
  | UnknownLexeme
  | TextLiteralMissingClosingQuote String
  | InvalidEscapeCharacter Char
  | LayoutError
  | CloseWithoutMatchingOpen String String -- open, close
  | UnexpectedDelimiter String
  | UnexpectedTokens String -- Catch-all for all other lexer errors, representing some unexpected tokens.
  deriving stock (Err -> Err -> Bool
(Err -> Err -> Bool) -> (Err -> Err -> Bool) -> Eq Err
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Err -> Err -> Bool
== :: Err -> Err -> Bool
$c/= :: Err -> Err -> Bool
/= :: Err -> Err -> Bool
Eq, Eq Err
Eq Err =>
(Err -> Err -> Ordering)
-> (Err -> Err -> Bool)
-> (Err -> Err -> Bool)
-> (Err -> Err -> Bool)
-> (Err -> Err -> Bool)
-> (Err -> Err -> Err)
-> (Err -> Err -> Err)
-> Ord Err
Err -> Err -> Bool
Err -> Err -> Ordering
Err -> Err -> Err
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 :: Err -> Err -> Ordering
compare :: Err -> Err -> Ordering
$c< :: Err -> Err -> Bool
< :: Err -> Err -> Bool
$c<= :: Err -> Err -> Bool
<= :: Err -> Err -> Bool
$c> :: Err -> Err -> Bool
> :: Err -> Err -> Bool
$c>= :: Err -> Err -> Bool
>= :: Err -> Err -> Bool
$cmax :: Err -> Err -> Err
max :: Err -> Err -> Err
$cmin :: Err -> Err -> Err
min :: Err -> Err -> Err
Ord, Line -> Err -> ShowS
[Err] -> ShowS
Err -> String
(Line -> Err -> ShowS)
-> (Err -> String) -> ([Err] -> ShowS) -> Show Err
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Line -> Err -> ShowS
showsPrec :: Line -> Err -> ShowS
$cshow :: Err -> String
show :: Err -> String
$cshowList :: [Err] -> ShowS
showList :: [Err] -> ShowS
Show) -- richer algebra

-- Design principle:
--   `[Lexeme]` should be sufficient information for parsing without
--   further knowledge of spacing or indentation levels
--   any knowledge of comments
data Lexeme
  = -- | start of a block
    Open String
  | -- | separator between elements of a block
    Semi IsVirtual
  | -- | end of a block
    Close
  | -- | reserved tokens such as `{`, `(`, `type`, `of`, etc
    Reserved String
  | -- | text literals, `"foo bar"`
    Textual String
  | -- | character literals, `?X`
    Character Char
  | -- | a (non-infix) identifier. invariant: last segment is wordy
    WordyId (HQ'.HashQualified Name)
  | -- | an infix identifier. invariant: last segment is symboly
    SymbolyId (HQ'.HashQualified Name)
  | -- | numeric literals, left unparsed
    Numeric String
  | -- | bytes literals
    Bytes Bytes.Bytes
  | -- | hash literals
    Hash ShortHash
  | Err Err
  | Doc (Doc.UntitledSection (Doc.Tree (Token (ReferenceType, HQ'.HashQualified Name)) [Token Lexeme]))
  deriving stock (Lexeme -> Lexeme -> Bool
(Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Bool) -> Eq Lexeme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Lexeme -> Lexeme -> Bool
== :: Lexeme -> Lexeme -> Bool
$c/= :: Lexeme -> Lexeme -> Bool
/= :: Lexeme -> Lexeme -> Bool
Eq, Line -> Lexeme -> ShowS
[Lexeme] -> ShowS
Lexeme -> String
(Line -> Lexeme -> ShowS)
-> (Lexeme -> String) -> ([Lexeme] -> ShowS) -> Show Lexeme
forall a.
(Line -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Line -> Lexeme -> ShowS
showsPrec :: Line -> Lexeme -> ShowS
$cshow :: Lexeme -> String
show :: Lexeme -> String
$cshowList :: [Lexeme] -> ShowS
showList :: [Lexeme] -> ShowS
Show, Eq Lexeme
Eq Lexeme =>
(Lexeme -> Lexeme -> Ordering)
-> (Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Lexeme)
-> (Lexeme -> Lexeme -> Lexeme)
-> Ord Lexeme
Lexeme -> Lexeme -> Bool
Lexeme -> Lexeme -> Ordering
Lexeme -> Lexeme -> Lexeme
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 :: Lexeme -> Lexeme -> Ordering
compare :: Lexeme -> Lexeme -> Ordering
$c< :: Lexeme -> Lexeme -> Bool
< :: Lexeme -> Lexeme -> Bool
$c<= :: Lexeme -> Lexeme -> Bool
<= :: Lexeme -> Lexeme -> Bool
$c> :: Lexeme -> Lexeme -> Bool
> :: Lexeme -> Lexeme -> Bool
$c>= :: Lexeme -> Lexeme -> Bool
>= :: Lexeme -> Lexeme -> Bool
$cmax :: Lexeme -> Lexeme -> Lexeme
max :: Lexeme -> Lexeme -> Lexeme
$cmin :: Lexeme -> Lexeme -> Lexeme
min :: Lexeme -> Lexeme -> Lexeme
Ord)

type IsVirtual = Bool -- is it a virtual semi or an actual semi?

-- Committed failure
err :: (P.TraversableStream s, P.MonadParsec (Token Err) s m) => Pos -> Err -> m x
err :: forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
start Err
t = do
  Pos
stop <- m Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
  -- This consumes a character and therefore produces committed failure,
  -- so `err s t <|> p2` won't try `p2`
  ()
_ <- m (Token s) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m (Token s)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
P.anySingle m () -> m () -> m ()
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof
  Token Err -> m x
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure (Err -> Pos -> Pos -> Token Err
forall a. a -> Pos -> Pos -> Token a
Token Err
t Pos
start Pos
stop)

token :: P Lexeme -> P [Token Lexeme]
token :: P Lexeme -> P [Token Lexeme]
token = (Lexeme -> Pos -> Pos -> [Token Lexeme])
-> P Lexeme -> P [Token Lexeme]
forall a.
(a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token' (\Lexeme
a Pos
start Pos
end -> [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token Lexeme
a Pos
start Pos
end])

-- Token parser: strips trailing whitespace and comments after a
-- successful parse, and also takes care of emitting layout tokens
-- (such as virtual semicolons and closing tokens).
token' :: (a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token' :: forall a.
(a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token' a -> Pos -> Pos -> [Token Lexeme]
tok P a
p = ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme] -> P [Token Lexeme]
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
LP.lexeme ParsecT (Token Err) String (State ParsingEnv) ()
forall e (m :: * -> *). MonadParsec e String m => m ()
space ((a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
forall a.
(a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token'' a -> Pos -> Pos -> [Token Lexeme]
tok P a
p)

-- Token parser implementation which leaves trailing whitespace and comments
-- but does emit layout tokens such as virtual semicolons and closing tokens.
token'' :: (a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token'' :: forall a.
(a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token'' a -> Pos -> Pos -> [Token Lexeme]
tok P a
p = do
  Pos
start <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
  -- We save the current state so we can backtrack the state if `p` fails.
  ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
  [Token Lexeme]
layoutToks <- case ParsingEnv -> Maybe String
opening ParsingEnv
env of
    -- If we're opening a block named b, we push (b, currentColumn) onto
    -- the layout stack. Example:
    --
    --   blah = cases
    --       {- A comment -}
    --          -- A one-line comment
    --     0 -> "hi"
    --     1 -> "bye"
    --
    -- After the `cases` token, the state will be opening = Just "cases",
    -- meaning the parser is searching for the next non-whitespace/comment
    -- character to determine the leftmost column of the `cases` block.
    -- That will be the column of the `0`.
    Just String
blockname ->
      -- special case - handling of empty blocks, as in:
      --   foo =
      --   bar = 42
      if String
blockname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"=" Bool -> Bool -> Bool
&& Pos -> Line
column Pos
start Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
<= Layout -> Line
top Layout
l Bool -> Bool -> Bool
&& Bool -> Bool
not (Layout -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Layout
l)
        then do
          ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {layout = (blockname, column start + 1) : l, opening = Nothing})
          Pos -> P [Token Lexeme]
pops Pos
start
        else [] [Token Lexeme]
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme]
forall a b.
a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {layout = layout', opening = Nothing})
      where
        layout' :: Layout
layout' = (String
blockname, Pos -> Line
column Pos
start) (String, Line) -> Layout -> Layout
forall a. a -> [a] -> [a]
: Layout
l
        l :: Layout
l = ParsingEnv -> Layout
layout ParsingEnv
env
    -- If we're not opening a block, we potentially pop from
    -- the layout stack and/or emit virtual semicolons.
    Maybe String
Nothing -> if ParsingEnv -> Bool
inLayout ParsingEnv
env then Pos -> P [Token Lexeme]
pops Pos
start else [Token Lexeme] -> P [Token Lexeme]
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  Pos
beforeTokenPos <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
  a
a <- P a
p P a -> P a -> P a
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put ParsingEnv
env ParsecT (Token Err) String (State ParsingEnv) () -> P a -> P a
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> P a
forall a. String -> ParsecT (Token Err) String (State ParsingEnv) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"resetting state")
  Pos
endPos <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
  pure $ [Token Lexeme]
layoutToks [Token Lexeme] -> [Token Lexeme] -> [Token Lexeme]
forall a. [a] -> [a] -> [a]
++ a -> Pos -> Pos -> [Token Lexeme]
tok a
a Pos
beforeTokenPos Pos
endPos
  where
    pops :: Pos -> P [Token Lexeme]
    pops :: Pos -> P [Token Lexeme]
pops Pos
p = do
      ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
      let l :: Layout
l = ParsingEnv -> Layout
layout ParsingEnv
env
      if Pos -> Line
column Pos
p Line -> Line -> Bool
forall a. Eq a => a -> a -> Bool
== Layout -> Line
top Layout
l Bool -> Bool -> Bool
&& Layout -> Bool
topContainsVirtualSemis Layout
l
        then [Token Lexeme] -> P [Token Lexeme]
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (Bool -> Lexeme
Semi Bool
True) Pos
p Pos
p]
        else
          if Pos -> Line
column Pos
p Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
> Layout -> Line
top Layout
l Bool -> Bool -> Bool
|| Layout -> Bool
topHasClosePair Layout
l
            then [Token Lexeme] -> P [Token Lexeme]
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            else
              if Pos -> Line
column Pos
p Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
< Layout -> Line
top Layout
l
                then ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {layout = pop l}) ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token Lexeme
Close Pos
p Pos
p Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
:) ([Token Lexeme] -> [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pos -> P [Token Lexeme]
pops Pos
p)
                else -- we hit this branch exactly when `token''` is given the state
                -- `{layout = [], opening = Nothing, inLayout = True}`
                  String -> P [Token Lexeme]
forall a. String -> ParsecT (Token Err) String (State ParsingEnv) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"internal error: token''"

    -- don't emit virtual semis in (, {, or [ blocks
    topContainsVirtualSemis :: Layout -> Bool
    topContainsVirtualSemis :: Layout -> Bool
topContainsVirtualSemis = \case
      [] -> Bool
False
      ((String
name, Line
_) : Layout
_) -> String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"(" Bool -> Bool -> Bool
&& String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"{" Bool -> Bool -> Bool
&& String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"["

    topHasClosePair :: Layout -> Bool
    topHasClosePair :: Layout -> Bool
topHasClosePair [] = Bool
False
    topHasClosePair ((String
name, Line
_) : Layout
_) =
      String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"DUMMY", String
"{", String
"(", String
"[", String
"handle", String
"match", String
"if", String
"then"]

showErrorFancy :: (P.ShowErrorComponent e) => P.ErrorFancy e -> String
showErrorFancy :: forall e. ShowErrorComponent e => ErrorFancy e -> String
showErrorFancy = \case
  P.ErrorFail String
msg -> String
msg
  P.ErrorIndentation Ordering
ord Pos
ref Pos
actual ->
    String
"incorrect indentation (got "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Line -> String
forall a. Show a => a -> String
show (Pos -> Line
P.unPos Pos
actual)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", should be "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
p
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Line -> String
forall a. Show a => a -> String
show (Pos -> Line
P.unPos Pos
ref)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
    where
      p :: String
p = case Ordering
ord of
        Ordering
LT -> String
"less than "
        Ordering
EQ -> String
"equal to "
        Ordering
GT -> String
"greater than "
  P.ErrorCustom e
a -> e -> String
forall a. ShowErrorComponent a => a -> String
P.showErrorComponent e
a

lexer :: String -> String -> [Token Lexeme]
lexer :: String -> String -> [Token Lexeme]
lexer String
scope String
rem =
  case (State
   ParsingEnv
   (Either (ParseErrorBundle String (Token Err)) [Token Lexeme])
 -> ParsingEnv
 -> Either (ParseErrorBundle String (Token Err)) [Token Lexeme])
-> ParsingEnv
-> State
     ParsingEnv
     (Either (ParseErrorBundle String (Token Err)) [Token Lexeme])
-> Either (ParseErrorBundle String (Token Err)) [Token Lexeme]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State
  ParsingEnv
  (Either (ParseErrorBundle String (Token Err)) [Token Lexeme])
-> ParsingEnv
-> Either (ParseErrorBundle String (Token Err)) [Token Lexeme]
forall s a. State s a -> s -> a
S.evalState ParsingEnv
env0 (State
   ParsingEnv
   (Either (ParseErrorBundle String (Token Err)) [Token Lexeme])
 -> Either (ParseErrorBundle String (Token Err)) [Token Lexeme])
-> State
     ParsingEnv
     (Either (ParseErrorBundle String (Token Err)) [Token Lexeme])
-> Either (ParseErrorBundle String (Token Err)) [Token Lexeme]
forall a b. (a -> b) -> a -> b
$ P [Token Lexeme]
-> String
-> String
-> State
     ParsingEnv
     (Either (ParseErrorBundle String (Token Err)) [Token Lexeme])
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> String -> s -> m (Either (ParseErrorBundle s e) a)
P.runParserT (P [Token Lexeme] -> P [Token Lexeme]
lexemes P [Token Lexeme]
eof) String
scope String
rem of
    Left ParseErrorBundle String (Token Err)
e ->
      let errsWithSourcePos :: [(ParseError String (Token Err), SourcePos)]
errsWithSourcePos =
            ([(ParseError String (Token Err), SourcePos)], PosState String)
-> [(ParseError String (Token Err), SourcePos)]
forall a b. (a, b) -> a
fst (([(ParseError String (Token Err), SourcePos)], PosState String)
 -> [(ParseError String (Token Err), SourcePos)])
-> ([(ParseError String (Token Err), SourcePos)], PosState String)
-> [(ParseError String (Token Err), SourcePos)]
forall a b. (a -> b) -> a -> b
$
              (ParseError String (Token Err) -> Line)
-> [ParseError String (Token Err)]
-> PosState String
-> ([(ParseError String (Token Err), SourcePos)], PosState String)
forall (t :: * -> *) s a.
(Traversable t, TraversableStream s) =>
(a -> Line) -> t a -> PosState s -> (t (a, SourcePos), PosState s)
P.attachSourcePos
                ParseError String (Token Err) -> Line
forall s e. ParseError s e -> Line
P.errorOffset
                (NonEmpty (ParseError String (Token Err))
-> [ParseError String (Token Err)]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (ParseErrorBundle String (Token Err)
-> NonEmpty (ParseError String (Token Err))
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
P.bundleErrors ParseErrorBundle String (Token Err)
e))
                (ParseErrorBundle String (Token Err) -> PosState String
forall s e. ParseErrorBundle s e -> PosState s
P.bundlePosState ParseErrorBundle String (Token Err)
e)
          errorToTokens :: (EP.ParseError String (Token Err), P.SourcePos) -> [Token Lexeme]
          errorToTokens :: (ParseError String (Token Err), SourcePos) -> [Token Lexeme]
errorToTokens (ParseError String (Token Err)
err, SourcePos
top) = case ParseError String (Token Err)
err of
            P.FancyError Line
_ (Set (ErrorFancy (Token Err)) -> [Token Lexeme]
forall {t :: * -> *} {f :: * -> *}.
(Foldable t, Functor f) =>
t (ErrorFancy (f Err)) -> [f Lexeme]
customErrs -> [Token Lexeme]
es) | Bool -> Bool
not ([Token Lexeme] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token Lexeme]
es) -> [Token Lexeme]
es
            P.FancyError Line
_errOffset Set (ErrorFancy (Token Err))
es ->
              let msg :: String
msg = String
-> (ErrorFancy (Token Err) -> String)
-> Set (ErrorFancy (Token Err))
-> String
forall (t :: * -> *) a b.
(Foldable t, Monoid a) =>
a -> (b -> a) -> t b -> a
intercalateMap String
"\n" ErrorFancy (Token Err) -> String
forall e. ShowErrorComponent e => ErrorFancy e -> String
showErrorFancy Set (ErrorFancy (Token Err))
es
               in [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (Err -> Lexeme
Err (String -> Err
UnexpectedTokens String
msg)) (SourcePos -> Pos
toPos SourcePos
top) (SourcePos -> Pos
toPos SourcePos
top)]
            P.TrivialError Line
_errOffset Maybe (ErrorItem (Token String))
mayUnexpectedTokens Set (ErrorItem (Token String))
expectedTokens ->
              let unexpectedStr :: Set String
                  unexpectedStr :: Set String
unexpectedStr =
                    Maybe (ErrorItem Char)
Maybe (ErrorItem (Token String))
mayUnexpectedTokens
                      Maybe (ErrorItem Char)
-> (Maybe (ErrorItem Char) -> Maybe String) -> Maybe String
forall a b. a -> (a -> b) -> b
& (ErrorItem Char -> String)
-> Maybe (ErrorItem Char) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ErrorItem Char -> String
errorItemToString
                      Maybe String -> (Maybe String -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList
                      [String] -> ([String] -> Set String) -> Set String
forall a b. a -> (a -> b) -> b
& [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
                  errorLength :: Int
                  errorLength :: Line
errorLength = case Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
unexpectedStr of
                    [] -> Line
0
                    (String
x : [String]
_) -> String -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length String
x
                  expectedStr :: Set String
                  expectedStr :: Set String
expectedStr =
                    Set (ErrorItem Char)
Set (ErrorItem (Token String))
expectedTokens
                      Set (ErrorItem Char)
-> (Set (ErrorItem Char) -> Set String) -> Set String
forall a b. a -> (a -> b) -> b
& (ErrorItem Char -> String) -> Set (ErrorItem Char) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ErrorItem Char -> String
errorItemToString
                  err :: Err
err = String -> Err
UnexpectedTokens (String -> Err) -> String -> Err
forall a b. (a -> b) -> a -> b
$ Set String -> Set String -> String
formatTrivialError Set String
unexpectedStr Set String
expectedStr
                  startPos :: Pos
startPos = SourcePos -> Pos
toPos SourcePos
top
                  -- This is just an attempt to highlight errors better in source excerpts.
                  -- It may not work in all cases, but should generally provide a better experience.
                  endPos :: Pos
endPos = Pos
startPos Pos -> (Pos -> Pos) -> Pos
forall a b. a -> (a -> b) -> b
& \(Pos Line
l Line
c) -> Line -> Line -> Pos
Pos Line
l (Line
c Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
errorLength)
               in [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (Err -> Lexeme
Err Err
err) Pos
startPos Pos
endPos]
       in [(ParseError String (Token Err), SourcePos)]
errsWithSourcePos [(ParseError String (Token Err), SourcePos)]
-> ((ParseError String (Token Err), SourcePos) -> [Token Lexeme])
-> [Token Lexeme]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ParseError String (Token Err), SourcePos) -> [Token Lexeme]
errorToTokens
    Right [Token Lexeme]
ts -> [Token Lexeme] -> [Token Lexeme]
postLex ([Token Lexeme] -> [Token Lexeme])
-> [Token Lexeme] -> [Token Lexeme]
forall a b. (a -> b) -> a -> b
$ Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Open String
scope) Pos
topLeftCorner Pos
topLeftCorner Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: [Token Lexeme]
ts
  where
    eof :: P [Token Lexeme]
    eof :: P [Token Lexeme]
eof = P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try do
      Pos
p <- ParsecT (Token Err) String (State ParsingEnv) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof ParsecT (Token Err) String (State ParsingEnv) ()
-> ParsecT (Token Err) String (State ParsingEnv) Pos
-> ParsecT (Token Err) String (State ParsingEnv) Pos
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
      Line
n <- Line -> (String -> Line) -> Maybe String -> Line
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Line
0 (Line -> String -> Line
forall a b. a -> b -> a
const Line
1) (Maybe String -> Line)
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) Line
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsingEnv -> Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ParsingEnv -> Maybe String
opening
      Layout
l <- (ParsingEnv -> Layout)
-> ParsecT (Token Err) String (State ParsingEnv) Layout
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ParsingEnv -> Layout
layout
      pure $ Line -> Token Lexeme -> [Token Lexeme]
forall a. Line -> a -> [a]
replicate (Layout -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length Layout
l Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
n) (Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token Lexeme
Close Pos
p Pos
p)
    errorItemToString :: EP.ErrorItem Char -> String
    errorItemToString :: ErrorItem Char -> String
errorItemToString = \case
      (P.Tokens NonEmpty Char
ts) -> NonEmpty Char -> String
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList NonEmpty Char
ts
      (P.Label NonEmpty Char
ts) -> NonEmpty Char -> String
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList NonEmpty Char
ts
      (ErrorItem Char
P.EndOfInput) -> String
"end of input"
    customErrs :: t (ErrorFancy (f Err)) -> [f Lexeme]
customErrs t (ErrorFancy (f Err))
es = [Err -> Lexeme
Err (Err -> Lexeme) -> f Err -> f Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Err
e | P.ErrorCustom f Err
e <- t (ErrorFancy (f Err)) -> [ErrorFancy (f Err)]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (ErrorFancy (f Err))
es]
    toPos :: SourcePos -> Pos
toPos (P.SourcePos String
_ Pos
line Pos
col) = Line -> Line -> Pos
Pos (Pos -> Line
P.unPos Pos
line) (Pos -> Line
P.unPos Pos
col)
    env0 :: ParsingEnv
env0 = String -> ParsingEnv
initialEnv String
scope

-- | hacky postprocessing pass to do some cleanup of stuff that's annoying to
-- fix without adding more state to the lexer:
--   - 1+1 lexes as [1, +1], convert this to [1, +, 1]
--   - when a semi followed by a virtual semi, drop the virtual, lets you
--     write
--       foo x = action1;
--               2
--   - semi immediately after first Open is ignored
tweak :: (Token Lexeme) -> [Token Lexeme] -> [Token Lexeme]
tweak :: Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
tweak h :: Token Lexeme
h@(Token (Semi Bool
False) Pos
_ Pos
_) (Token (Semi Bool
True) Pos
_ Pos
_ : [Token Lexeme]
t) = Token Lexeme
h Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: [Token Lexeme]
t
-- __NB__: This case only exists to guard against the following one
tweak h :: Token Lexeme
h@(Token (Reserved String
_) Pos
_ Pos
_) [Token Lexeme]
t = Token Lexeme
h Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: [Token Lexeme]
t
tweak Token Lexeme
t1 (t2 :: Token Lexeme
t2@(Token (Numeric String
num) Pos
_ Pos
_) : [Token Lexeme]
rem)
  | Token Lexeme -> Bool
notLayout Token Lexeme
t1 Bool -> Bool -> Bool
&& Token Lexeme -> Token Lexeme -> Bool
forall a b. Token a -> Token b -> Bool
touches Token Lexeme
t1 Token Lexeme
t2 Bool -> Bool -> Bool
&& String -> Bool
isSigned String
num =
      Token Lexeme
t1
        Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token
          (HashQualified Name -> Lexeme
SymbolyId (Name -> HashQualified Name
forall n. n -> HashQualified n
HQ'.fromName (HasCallStack => Text -> Name
Text -> Name
Name.unsafeParseText (String -> Text
Text.pack (Line -> ShowS
forall a. Line -> [a] -> [a]
take Line
1 String
num)))))
          (Token Lexeme -> Pos
forall a. Token a -> Pos
start Token Lexeme
t2)
          (Pos -> Pos
inc (Pos -> Pos) -> Pos -> Pos
forall a b. (a -> b) -> a -> b
$ Token Lexeme -> Pos
forall a. Token a -> Pos
start Token Lexeme
t2)
        Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Numeric (Line -> ShowS
forall a. Line -> [a] -> [a]
drop Line
1 String
num)) (Pos -> Pos
inc (Pos -> Pos) -> Pos -> Pos
forall a b. (a -> b) -> a -> b
$ Token Lexeme -> Pos
forall a. Token a -> Pos
start Token Lexeme
t2) (Token Lexeme -> Pos
forall a. Token a -> Pos
end Token Lexeme
t2)
        Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: [Token Lexeme]
rem
  where
    isSigned :: String -> Bool
isSigned String
num = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
ch -> Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+') (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Line -> ShowS
forall a. Line -> [a] -> [a]
take Line
1 String
num
tweak Token Lexeme
h [Token Lexeme]
t = Token Lexeme
h Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: [Token Lexeme]
t

formatTrivialError :: Set String -> Set String -> [Char]
formatTrivialError :: Set String -> Set String -> String
formatTrivialError Set String
unexpectedTokens Set String
expectedTokens =
  let unexpectedMsg :: String
unexpectedMsg = case Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
unexpectedTokens of
        [] -> String
"I found something I didn't expect."
        [String
x] ->
          let article :: String
article = case String
x of
                (Char
c : String
_) | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"aeiou" :: String) -> String
"an"
                String
_ -> String
"a"
           in String
"I was surprised to find " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
article String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" here."
        [String]
xs -> String
"I was surprised to find these:\n\n* " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n* " [String]
xs
      expectedMsg :: Maybe String
expectedMsg = case Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
expectedTokens of
        [] -> Maybe String
forall a. Maybe a
Nothing
        [String]
xs -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"\nI was expecting one of these instead:\n\n* " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n* " [String]
xs
   in [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [String -> Maybe String
forall a. a -> Maybe a
Just String
unexpectedMsg, Maybe String
expectedMsg]

displayLexeme :: Lexeme -> String
displayLexeme :: Lexeme -> String
displayLexeme = \case
  Open String
o -> String
o
  Semi Bool
True -> String
"end of stanza"
  Semi Bool
False -> String
"semicolon"
  Lexeme
Close -> String
"end of section"
  Reserved String
r -> String
"'" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
r String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'"
  Textual String
t -> String
"\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\""
  Character Char
c -> String
"?" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char
c]
  WordyId HashQualified Name
hq -> Text -> String
Text.unpack ((Name -> Text) -> HashQualified Name -> Text
forall n. (n -> Text) -> HashQualified n -> Text
HQ'.toTextWith Name -> Text
Name.toText HashQualified Name
hq)
  SymbolyId HashQualified Name
hq -> Text -> String
Text.unpack ((Name -> Text) -> HashQualified Name -> Text
forall n. (n -> Text) -> HashQualified n -> Text
HQ'.toTextWith Name -> Text
Name.toText HashQualified Name
hq)
  Numeric String
n -> String
n
  Bytes Bytes
_b -> String
"bytes literal"
  Hash ShortHash
h -> Text -> String
Text.unpack (ShortHash -> Text
SH.toText ShortHash
h)
  Err Err
e -> Err -> String
forall a. Show a => a -> String
show Err
e
  Doc UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
_ -> String
"doc structure"

-- | The `Doc` lexer as documented on unison-lang.org
doc2 :: P [Token Lexeme]
doc2 :: P [Token Lexeme]
doc2 = do
  -- Ensure we're at a doc before we start consuming tokens
  ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"{{")
  Pos
openStart <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
  -- Produce any layout tokens, such as closing the last open block or virtual semicolons
  -- We don't use 'token' on "{{" directly because we don't want to duplicate layout
  -- tokens if we do the rewrite hack for type-docs below.
  [Token Lexeme]
beforeStartToks <- (() -> Pos -> Pos -> [Token Lexeme])
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme]
forall a.
(a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token' () -> Pos -> Pos -> [Token Lexeme]
forall {p} {p} {p} {a}. p -> p -> p -> [a]
ignore (() -> ParsecT (Token Err) String (State ParsingEnv) ()
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT (Token Err) String (State ParsingEnv) String
 -> ParsecT (Token Err) String (State ParsingEnv) ())
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"{{"
  Pos
openEnd <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
  ParsecT (Token Err) String (State ParsingEnv) ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
CP.space
  ParsingEnv
env0 <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
  -- Disable layout while parsing the doc block and reset the section number
  (Token Lexeme
docTok, Token Lexeme
closeTok) <- (ParsingEnv -> ParsingEnv)
-> ParsecT
     (Token Err) String (State ParsingEnv) (Token Lexeme, Token Lexeme)
-> ParsecT
     (Token Err) String (State ParsingEnv) (Token Lexeme, Token Lexeme)
forall e s' (m :: * -> *) s a.
(MonadParsec e s' m, MonadState s m) =>
(s -> s) -> m a -> m a
local
    (\ParsingEnv
env -> ParsingEnv
env {inLayout = False})
    do
      UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
body <- ParsecT
  (Token Err)
  String
  (State ParsingEnv)
  (Token (ReferenceType, HashQualified Name))
-> (ParsecT (Token Err) String (State ParsingEnv) ()
    -> P [Token Lexeme])
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT
     (Token Err)
     String
     (State ParsingEnv)
     (UntitledSection
        (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme]))
forall e (m :: * -> *) ident code end.
(Ord e, MonadParsec e String m) =>
m ident
-> (m () -> m code)
-> m end
-> m (UntitledSection (Tree ident code))
Doc.doc (ParsecT
  (Token Err)
  String
  (State ParsingEnv)
  (ReferenceType, HashQualified Name)
-> ParsecT
     (Token Err)
     String
     (State ParsingEnv)
     (Token (ReferenceType, HashQualified Name))
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP ParsecT
  (Token Err)
  String
  (State ParsingEnv)
  (ReferenceType, HashQualified Name)
forall (m :: * -> *).
Monad m =>
ParsecT (Token Err) String m (ReferenceType, HashQualified Name)
typeOrTerm) ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme]
lexemes' (ParsecT (Token Err) String (State ParsingEnv) String
 -> ParsecT
      (Token Err)
      String
      (State ParsingEnv)
      (UntitledSection
         (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])))
-> (ParsecT (Token Err) String (State ParsingEnv) String
    -> ParsecT (Token Err) String (State ParsingEnv) String)
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT
     (Token Err)
     String
     (State ParsingEnv)
     (UntitledSection
        (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (ParsecT (Token Err) String (State ParsingEnv) String
 -> ParsecT
      (Token Err)
      String
      (State ParsingEnv)
      (UntitledSection
         (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])))
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT
     (Token Err)
     String
     (State ParsingEnv)
     (UntitledSection
        (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme]))
forall a b. (a -> b) -> a -> b
$ String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"}}"
      Pos
closeStart <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
      String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"}}"
      Pos
closeEnd <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
      pure (Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
-> Lexeme
Doc UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
body) Pos
openStart Pos
closeEnd, Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token Lexeme
Close Pos
closeStart Pos
closeEnd)
  -- Parse any layout tokens after the doc block, e.g. virtual semicolon
  [Token Lexeme]
endToks <- (() -> Pos -> Pos -> [Token Lexeme])
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme]
forall a.
(a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token' () -> Pos -> Pos -> [Token Lexeme]
forall {p} {p} {p} {a}. p -> p -> p -> [a]
ignore (() -> ParsecT (Token Err) String (State ParsingEnv) ()
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  -- Hack to allow anonymous doc blocks before type decls
  --   {{ Some docs }}             Foo.doc = {{ Some docs }}
  --   ability Foo where      =>   ability Foo where
  --
  -- __FIXME__: This should be done _after_ parsing, not in lexing.
  Maybe Lexeme
tn <- ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme)
subsequentTypeName
  pure $
    [Token Lexeme]
beforeStartToks [Token Lexeme] -> [Token Lexeme] -> [Token Lexeme]
forall a. Semigroup a => a -> a -> a
<> case (Maybe Lexeme
tn) of
      -- If we're followed by a type, we rewrite the doc block to be a named doc block.
      Just (WordyId HashQualified Name
tname)
        | Bool
isTopLevel ->
            Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (HashQualified Name -> Lexeme
WordyId (Name -> HashQualified Name
forall n. n -> HashQualified n
HQ'.fromName (Name -> NameSegment -> Name
Name.snoc (HashQualified Name -> Name
forall n. HashQualified n -> n
HQ'.toName HashQualified Name
tname) NameSegment
NameSegment.docSegment))) Pos
openStart Pos
openEnd
              Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Open String
"=") Pos
openStart Pos
openEnd
              Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: Token Lexeme
docTok
              -- We need an extra 'Close' here because we added an extra Open above.
              Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: Token Lexeme
closeTok
              Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: [Token Lexeme]
endToks
        where
          isTopLevel :: Bool
isTopLevel = Layout -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length (ParsingEnv -> Layout
layout ParsingEnv
env0) Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line -> (String -> Line) -> Maybe String -> Line
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Line
0 (Line -> String -> Line
forall a b. a -> b -> a
const Line
1) (ParsingEnv -> Maybe String
opening ParsingEnv
env0) Line -> Line -> Bool
forall a. Eq a => a -> a -> Bool
== Line
1
      Maybe Lexeme
_ -> Token Lexeme
docTok Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: [Token Lexeme]
endToks
  where
    subsequentTypeName :: ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme)
subsequentTypeName = ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme)
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme)
 -> ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme))
-> (P Lexeme
    -> ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme))
-> P Lexeme
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. P Lexeme
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (P Lexeme
 -> ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme))
-> P Lexeme
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe Lexeme)
forall a b. (a -> b) -> a -> b
$ do
      let lit' :: String -> ParsecT (Token Err) String (State ParsingEnv) String
lit' String
s = String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
s ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT (Token Err) String (State ParsingEnv) String
sp
      let modifier :: ParsecT (Token Err) String (State ParsingEnv) String
modifier = (Text -> ParsecT (Token Err) String (State ParsingEnv) String)
-> ParsecT (Token Err) String (State ParsingEnv) String
forall (f :: * -> *) a. Alternative f => (Text -> f a) -> f a
typeModifiersAlt (String -> ParsecT (Token Err) String (State ParsingEnv) String
lit' (String -> ParsecT (Token Err) String (State ParsingEnv) String)
-> (Text -> String)
-> Text
-> ParsecT (Token Err) String (State ParsingEnv) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)
      String
_ <- ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT (Token Err) String (State ParsingEnv) String
modifier ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT (Token Err) String (State ParsingEnv) String
forall (m :: * -> *).
Monad m =>
ParsecT (Token Err) String m String
typeOrAbility' ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT (Token Err) String (State ParsingEnv) String
sp
      Token HashQualified Name
name Pos
start Pos
stop <- ParsecT (Token Err) String (State ParsingEnv) (HashQualified Name)
-> ParsecT
     (Token Err) String (State ParsingEnv) (Token (HashQualified Name))
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP ParsecT (Token Err) String (State ParsingEnv) (HashQualified Name)
forall (m :: * -> *).
Monad m =>
ParsecT (Token Err) String m (HashQualified Name)
identifierP
      if Name -> Bool
Name.isSymboly (HashQualified Name -> Name
forall n. HashQualified n -> n
HQ'.toName HashQualified Name
name)
        then Token Err -> P Lexeme
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
P.customFailure (Err -> Pos -> Pos -> Token Err
forall a. a -> Pos -> Pos -> Token a
Token (String -> Err
InvalidSymbolyId (Text -> String
Text.unpack ((Name -> Text) -> HashQualified Name -> Text
forall n. (n -> Text) -> HashQualified n -> Text
HQ'.toTextWith Name -> Text
Name.toText HashQualified Name
name))) Pos
start Pos
stop)
        else Lexeme -> P Lexeme
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashQualified Name -> Lexeme
WordyId HashQualified Name
name)
    ignore :: p -> p -> p -> [a]
ignore p
_ p
_ p
_ = []
    -- DUPLICATED
    sp :: ParsecT (Token Err) String (State ParsingEnv) String
sp = ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (ParsecT (Token Err) String (State ParsingEnv) String
 -> ParsecT (Token Err) String (State ParsingEnv) String)
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a b. (a -> b) -> a -> b
$ do
      String
spaces <- Maybe String
-> (Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"space") Char -> Bool
Token String -> Bool
isSpace
      Maybe String
close <- ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"}}"))
      case Maybe String
close of
        Maybe String
Nothing -> Bool -> ParsecT (Token Err) String (State ParsingEnv) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT (Token Err) String (State ParsingEnv) ())
-> Bool -> ParsecT (Token Err) String (State ParsingEnv) ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
ok String
spaces
        Just String
_ -> () -> ParsecT (Token Err) String (State ParsingEnv) ()
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      pure String
spaces
      where
        ok :: String -> Bool
ok String
s = [()] -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length [() | Char
'\n' <- String
s] Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
< Line
2

typeOrTerm :: (Monad m) => P.ParsecT (Token Err) String m (ReferenceType, HQ'.HashQualified Name)
typeOrTerm :: forall (m :: * -> *).
Monad m =>
ParsecT (Token Err) String m (ReferenceType, HashQualified Name)
typeOrTerm = do
  Maybe String
mtype <- ParsecT (Token Err) String m String
-> ParsecT (Token Err) String m (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (ParsecT (Token Err) String m String
 -> ParsecT (Token Err) String m (Maybe String))
-> ParsecT (Token Err) String m String
-> ParsecT (Token Err) String m (Maybe String)
forall a b. (a -> b) -> a -> b
$ ParsecT (Token Err) String m String
forall (m :: * -> *).
Monad m =>
ParsecT (Token Err) String m String
typeOrAbility' ParsecT (Token Err) String m String
-> ParsecT (Token Err) String m ()
-> ParsecT (Token Err) String m String
forall a b.
ParsecT (Token Err) String m a
-> ParsecT (Token Err) String m b -> ParsecT (Token Err) String m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT (Token Err) String m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
CP.space
  HashQualified Name
ident <- ParsecT (Token Err) String m (HashQualified Name)
forall (m :: * -> *).
Monad m =>
ParsecT (Token Err) String m (HashQualified Name)
identifierP ParsecT (Token Err) String m (HashQualified Name)
-> ParsecT (Token Err) String m ()
-> ParsecT (Token Err) String m (HashQualified Name)
forall a b.
ParsecT (Token Err) String m a
-> ParsecT (Token Err) String m b -> ParsecT (Token Err) String m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT (Token Err) String m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
CP.space
  pure (ReferenceType
-> (String -> ReferenceType) -> Maybe String -> ReferenceType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReferenceType
RtTerm (ReferenceType -> String -> ReferenceType
forall a b. a -> b -> a
const ReferenceType
RtType) Maybe String
mtype, HashQualified Name
ident)

typeOrAbility' :: (Monad m) => P.ParsecT (Token Err) String m String
typeOrAbility' :: forall (m :: * -> *).
Monad m =>
ParsecT (Token Err) String m String
typeOrAbility' = (Text -> ParsecT (Token Err) String m String)
-> ParsecT (Token Err) String m String
forall (f :: * -> *) a. Alternative f => (Text -> f a) -> f a
typeOrAbilityAlt (String -> ParsecT (Token Err) String m String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
wordyKw (String -> ParsecT (Token Err) String m String)
-> (Text -> String) -> Text -> ParsecT (Token Err) String m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)
  where
    wordyKw :: String -> m String
wordyKw String
kw = (Token String -> Bool) -> m String -> m String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Bool) -> m a -> m a
separated Char -> Bool
Token String -> Bool
wordySep (String -> m String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
kw)

lexemes' :: P () -> P [Token Lexeme]
lexemes' :: ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme]
lexemes' ParsecT (Token Err) String (State ParsingEnv) ()
eof =
  -- NB: `postLex` requires the token stream to start with an `Open`, otherwise it can’t create a `BlockTree`, so this
  --     adds one, runs `postLex`, then removes it.
  ([Token Lexeme] -> [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b.
(a -> b)
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Token Lexeme] -> [Token Lexeme]
forall a. HasCallStack => [a] -> [a]
tail ([Token Lexeme] -> [Token Lexeme])
-> ([Token Lexeme] -> [Token Lexeme])
-> [Token Lexeme]
-> [Token Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token Lexeme] -> [Token Lexeme]
postLex ([Token Lexeme] -> [Token Lexeme])
-> ([Token Lexeme] -> [Token Lexeme])
-> [Token Lexeme]
-> [Token Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Open String
"fake") Pos
forall a. Monoid a => a
mempty Pos
forall a. Monoid a => a
mempty Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
:)) (P [Token Lexeme] -> P [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b. (a -> b) -> a -> b
$
    (ParsingEnv -> ParsingEnv) -> P [Token Lexeme] -> P [Token Lexeme]
forall e s' (m :: * -> *) s a.
(MonadParsec e s' m, MonadState s m) =>
(s -> s) -> m a -> m a
local (ParsingEnv -> ParsingEnv -> ParsingEnv
forall a b. a -> b -> a
const (ParsingEnv -> ParsingEnv -> ParsingEnv)
-> ParsingEnv -> ParsingEnv -> ParsingEnv
forall a b. (a -> b) -> a -> b
$ String -> ParsingEnv
initialEnv String
"DUMMY") do
      [Token Lexeme]
p <- P [Token Lexeme] -> P [Token Lexeme]
lexemes (P [Token Lexeme] -> P [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b. (a -> b) -> a -> b
$ [] [Token Lexeme]
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme]
forall a b.
a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT (Token Err) String (State ParsingEnv) ()
eof
      -- deals with a final "unclosed" block at the end of `p`)
      Layout
unclosed <- ((String, Line) -> Bool) -> Layout -> Layout
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((String
"DUMMY" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=) (String -> Bool)
-> ((String, Line) -> String) -> (String, Line) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Line) -> String
forall a b. (a, b) -> a
fst) (Layout -> Layout)
-> (ParsingEnv -> Layout) -> ParsingEnv -> Layout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsingEnv -> Layout
layout (ParsingEnv -> Layout)
-> ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
-> ParsecT (Token Err) String (State ParsingEnv) Layout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
      Pos
finalPos <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
      pure $ [Token Lexeme]
p [Token Lexeme] -> [Token Lexeme] -> [Token Lexeme]
forall a. Semigroup a => a -> a -> a
<> Line -> Token Lexeme -> [Token Lexeme]
forall a. Line -> a -> [a]
replicate (Layout -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length Layout
unclosed) (Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token Lexeme
Close Pos
finalPos Pos
finalPos)

-- | Consumes an entire Unison “module”.
lexemes :: P [Token Lexeme] -> P [Token Lexeme]
lexemes :: P [Token Lexeme] -> P [Token Lexeme]
lexemes P [Token Lexeme]
eof =
  ParsecT (Token Err) String (State ParsingEnv) ()
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional ParsecT (Token Err) String (State ParsingEnv) ()
forall e (m :: * -> *). MonadParsec e String m => m ()
space ParsecT (Token Err) String (State ParsingEnv) (Maybe ())
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> do
    [Token Lexeme]
hd <- [[Token Lexeme]] -> [Token Lexeme]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Token Lexeme]] -> [Token Lexeme])
-> ParsecT (Token Err) String (State ParsingEnv) [[Token Lexeme]]
-> P [Token Lexeme]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P [Token Lexeme]
-> P [Token Lexeme]
-> ParsecT (Token Err) String (State ParsingEnv) [[Token Lexeme]]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.manyTill P [Token Lexeme]
toks (P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead P [Token Lexeme]
eof)
    [Token Lexeme]
tl <- P [Token Lexeme]
eof
    pure $ [Token Lexeme]
hd [Token Lexeme] -> [Token Lexeme] -> [Token Lexeme]
forall a. Semigroup a => a -> a -> a
<> [Token Lexeme]
tl
  where
    toks :: P [Token Lexeme]
    toks :: P [Token Lexeme]
toks =
      P [Token Lexeme]
doc2
        P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
doc
        P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Lexeme -> P [Token Lexeme]
token P Lexeme
numeric
        P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Lexeme -> P [Token Lexeme]
token P Lexeme
character
        P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
reserved
        P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Lexeme -> P [Token Lexeme]
token P Lexeme
identifierLexemeP
        P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([P [Token Lexeme]] -> P [Token Lexeme]
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([P [Token Lexeme]] -> P [Token Lexeme])
-> ([P Lexeme] -> [P [Token Lexeme]])
-> [P Lexeme]
-> P [Token Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (P Lexeme -> P [Token Lexeme]) -> [P Lexeme] -> [P [Token Lexeme]]
forall a b. (a -> b) -> [a] -> [b]
map P Lexeme -> P [Token Lexeme]
token) [P Lexeme
semi, P Lexeme
textual, P Lexeme
forall {m :: * -> *}. ParsecT (Token Err) String m Lexeme
hash]

    doc :: P [Token Lexeme]
    doc :: P [Token Lexeme]
doc = P [Token Lexeme]
open P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall (f :: * -> *) a.
(Applicative f, Monoid a) =>
f a -> f a -> f a
<+> (ParsecT (Token Err) String (State ParsingEnv) ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
CP.space ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Token Lexeme] -> [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b.
(a -> b)
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Token Lexeme] -> [Token Lexeme]
fixup P [Token Lexeme]
body) P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall (f :: * -> *) a.
(Applicative f, Monoid a) =>
f a -> f a -> f a
<+> (P [Token Lexeme]
close P [Token Lexeme]
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme]
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT (Token Err) String (State ParsingEnv) ()
forall e (m :: * -> *). MonadParsec e String m => m ()
space)
      where
        open :: P [Token Lexeme]
open = ([Token Lexeme] -> Pos -> Pos -> [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a.
(a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token'' (\[Token Lexeme]
t Pos
_ Pos
_ -> [Token Lexeme]
t) (P [Token Lexeme] -> P [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b. (a -> b) -> a -> b
$ P Lexeme -> P [Token Lexeme]
forall a. P a -> P [Token a]
tok (String -> Lexeme
Open (String -> Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) String -> P Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"[:")
        close :: P [Token Lexeme]
close = P Lexeme -> P [Token Lexeme]
forall a. P a -> P [Token a]
tok (Lexeme
Close Lexeme
-> ParsecT (Token Err) String (State ParsingEnv) String -> P Lexeme
forall a b.
a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
":]")
        at :: ParsecT (Token Err) String (State ParsingEnv) String
at = String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"@"
        -- this removes some trailing whitespace from final textual segment
        fixup :: [Token Lexeme] -> [Token Lexeme]
fixup [] = []
        fixup (Token (Textual (ShowS
forall a. [a] -> [a]
reverse -> String
txt)) Pos
start Pos
stop : []) =
          [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Textual String
txt') Pos
start Pos
stop]
          where
            txt' :: String
txt' = ShowS
forall a. [a] -> [a]
reverse ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')) String
txt)
        fixup (Token Lexeme
h : [Token Lexeme]
t) = Token Lexeme
h Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
forall a. a -> [a] -> [a]
: [Token Lexeme] -> [Token Lexeme]
fixup [Token Lexeme]
t

        body :: P [Token Lexeme]
        body :: P [Token Lexeme]
body = P [Token Lexeme]
txt P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall (f :: * -> *) a.
(Applicative f, Monoid a) =>
f a -> f a -> f a
<+> (P [Token Lexeme]
atk P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Token Lexeme] -> P [Token Lexeme]
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
          where
            ch :: ParsecT (Token Err) String (State ParsingEnv) [Token String]
ch = ([Token String]
":]" [Token String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) [Token String]
forall a b.
a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"\\:]") ParsecT (Token Err) String (State ParsingEnv) [Token String]
-> ParsecT (Token Err) String (State ParsingEnv) [Token String]
-> ParsecT (Token Err) String (State ParsingEnv) [Token String]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Token String]
"@" [Token String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) [Token String]
forall a b.
a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"\\@") ParsecT (Token Err) String (State ParsingEnv) [Token String]
-> ParsecT (Token Err) String (State ParsingEnv) [Token String]
-> ParsecT (Token Err) String (State ParsingEnv) [Token String]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Token String -> [Token String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token String -> [Token String])
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
-> ParsecT (Token Err) String (State ParsingEnv) [Token String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
P.anySingle)
            txt :: P [Token Lexeme]
txt = P Lexeme -> P [Token Lexeme]
forall a. P a -> P [Token a]
tok (String -> Lexeme
Textual (String -> Lexeme) -> ([String] -> String) -> [String] -> Lexeme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([String] -> Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) [String]
-> P Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> ParsecT (Token Err) String (State ParsingEnv) [String]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.manyTill ParsecT (Token Err) String (State ParsingEnv) String
ch (ParsecT (Token Err) String (State ParsingEnv) ()
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead ParsecT (Token Err) String (State ParsingEnv) ()
sep))
            sep :: ParsecT (Token Err) String (State ParsingEnv) ()
sep = ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT (Token Err) String (State ParsingEnv) String
at ParsecT (Token Err) String (State ParsingEnv) ()
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void P [Token Lexeme]
close
            ref :: P [Token Lexeme]
ref = ParsecT (Token Err) String (State ParsingEnv) String
at ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (P Lexeme -> P [Token Lexeme]
forall a. P a -> P [Token a]
tok P Lexeme
identifierLexemeP P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
docTyp)
            atk :: P [Token Lexeme]
atk = (P [Token Lexeme]
ref P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
docTyp) P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall (f :: * -> *) a.
(Applicative f, Monoid a) =>
f a -> f a -> f a
<+> P [Token Lexeme]
body
            docTyp :: P [Token Lexeme]
docTyp = do
              String
_ <- String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"["
              [Token String]
typ <- ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token String]
forall a. P a -> P [Token a]
tok (ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.manyTill ParsecT (Token Err) String (State ParsingEnv) Char
ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
P.anySingle (ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"]")))
              ()
_ <- String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"]" ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT (Token Err) String (State ParsingEnv) ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
CP.space
              [Token Lexeme]
t <- P Lexeme -> P [Token Lexeme]
forall a. P a -> P [Token a]
tok P Lexeme
identifierLexemeP
              pure $ ((String -> Lexeme) -> Token String -> Token Lexeme
forall a b. (a -> b) -> Token a -> Token b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Lexeme
Reserved (Token String -> Token Lexeme) -> [Token String] -> [Token Lexeme]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token String]
typ) [Token Lexeme] -> [Token Lexeme] -> [Token Lexeme]
forall a. Semigroup a => a -> a -> a
<> [Token Lexeme]
t

    semi :: P Lexeme
semi = Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
';' ParsecT (Token Err) String (State ParsingEnv) Char
-> Lexeme -> P Lexeme
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool -> Lexeme
Semi Bool
False
    textual :: P Lexeme
textual = String -> Lexeme
Textual (String -> Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) String -> P Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String (State ParsingEnv) String
quoted
    quoted :: ParsecT (Token Err) String (State ParsingEnv) String
quoted = ParsecT (Token Err) String (State ParsingEnv) String
quotedRaw ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT (Token Err) String (State ParsingEnv) String
quotedSingleLine
    quotedRaw :: ParsecT (Token Err) String (State ParsingEnv) String
quotedRaw = do
      String
_ <- String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"\"\"\""
      String
n <- ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"')
      Maybe Char
_ <- ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'\n') -- initial newline is skipped
      String
s <- ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.manyTill ParsecT (Token Err) String (State ParsingEnv) Char
ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
P.anySingle (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit (Line -> Char -> String
forall a. Line -> a -> [a]
replicate (String -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length String
n Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
3) Char
'"'))
      Line
col0 <- Pos -> Line
column (Pos -> Line)
-> ParsecT (Token Err) String (State ParsingEnv) Pos
-> ParsecT (Token Err) String (State ParsingEnv) Line
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
      let col :: Line
col = Line
col0 Line -> Line -> Line
forall a. Num a => a -> a -> a
- (String -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length String
n) Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
3 -- this gets us first col of closing quotes
      let leading :: String
leading = Line -> Char -> String
forall a. Line -> a -> [a]
replicate (Line -> Line -> Line
forall a. Ord a => a -> a -> a
max Line
0 (Line
col Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
1)) Char
' '
      -- a last line that's equal to `leading` is ignored, since leading
      -- spaces up to `col` are not considered part of the string
      let tweak :: [String] -> [String]
tweak [String]
l = case [String] -> [String]
forall a. [a] -> [a]
reverse [String]
l of
            String
last : [String]
rest
              | Line
col Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
> Line
1 Bool -> Bool -> Bool
&& String
last String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
leading -> [String] -> [String]
forall a. [a] -> [a]
reverse [String]
rest
              | Bool
otherwise -> [String]
l
            [] -> []
      pure $ case [String] -> [String]
tweak (String -> [String]
lines String
s) of
        [] -> String
s
        [String]
ls
          | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\String
l -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
leading String
l Bool -> Bool -> Bool
|| (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
l) [String]
ls -> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" (Line -> ShowS
forall a. Line -> [a] -> [a]
drop (String -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length String
leading) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
ls)
          | Bool
otherwise -> String
s
    quotedSingleLine :: ParsecT (Token Err) String (State ParsingEnv) String
quotedSingleLine = Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"' ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.manyTill (ParsecT (Token Err) String (State ParsingEnv) Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
LP.charLiteral ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT (Token Err) String (State ParsingEnv) Char
sp) (Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"')
      where
        sp :: ParsecT (Token Err) String (State ParsingEnv) Char
sp = String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"\\s" ParsecT (Token Err) String (State ParsingEnv) String
-> Char -> ParsecT (Token Err) String (State ParsingEnv) Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
' '
    character :: P Lexeme
character = Char -> Lexeme
Character (Char -> Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) Char -> P Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'?' ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT (Token Err) String (State ParsingEnv) Char
spEsc ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT (Token Err) String (State ParsingEnv) Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
LP.charLiteral))
      where
        spEsc :: ParsecT (Token Err) String (State ParsingEnv) Char
spEsc = ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'\\' ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
's' ParsecT (Token Err) String (State ParsingEnv) Char
-> Char -> ParsecT (Token Err) String (State ParsingEnv) Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
' ')

    numeric :: P Lexeme
numeric = P Lexeme
bytes P Lexeme -> P Lexeme -> P Lexeme
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Lexeme
otherbase P Lexeme -> P Lexeme -> P Lexeme
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Lexeme
float P Lexeme -> P Lexeme -> P Lexeme
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Lexeme
intOrNat
      where
        intOrNat :: P Lexeme
intOrNat = P Lexeme -> P Lexeme
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (P Lexeme -> P Lexeme) -> P Lexeme -> P Lexeme
forall a b. (a -> b) -> a -> b
$ Maybe String -> Integer -> Lexeme
num (Maybe String -> Integer -> Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
-> ParsecT
     (Token Err) String (State ParsingEnv) (Integer -> Lexeme)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
sign ParsecT (Token Err) String (State ParsingEnv) (Integer -> Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) Integer
-> P Lexeme
forall a b.
ParsecT (Token Err) String (State ParsingEnv) (a -> b)
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT (Token Err) String (State ParsingEnv) Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
LP.decimal
        float :: P Lexeme
float = do
          Char
_ <- ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
sign ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) Line
-> ParsecT (Token Err) String (State ParsingEnv) Line
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ParsecT (Token Err) String (State ParsingEnv) Line
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
LP.decimal :: P Int) ParsecT (Token Err) String (State ParsingEnv) Line
-> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'.' ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'e' ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) Char
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'E'))) -- commit after this
          Pos
start <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
          String
sign <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
sign
          String
base <- Maybe String
-> (Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"base") Char -> Bool
Token String -> Bool
isDigit
          Maybe String
decimals <-
            ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (ParsecT (Token Err) String (State ParsingEnv) String
 -> ParsecT (Token Err) String (State ParsingEnv) (Maybe String))
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall a b. (a -> b) -> a -> b
$
              let missingFractional :: ParsecT (Token Err) String (State ParsingEnv) String
missingFractional = Pos -> Err -> ParsecT (Token Err) String (State ParsingEnv) String
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
start (String -> Err
MissingFractional (String -> Err) -> String -> Err
forall a b. (a -> b) -> a -> b
$ String
base String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".")
               in (String -> ShowS)
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a b c.
(a -> b -> c)
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 String -> ShowS
forall a. Semigroup a => a -> a -> a
(<>) (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
".") (Maybe String
-> (Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"decimals") Char -> Bool
Token String -> Bool
isDigit ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT (Token Err) String (State ParsingEnv) String
missingFractional)
          Maybe String
exp <- ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (ParsecT (Token Err) String (State ParsingEnv) String
 -> ParsecT (Token Err) String (State ParsingEnv) (Maybe String))
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
            String
e <- (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"e" ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"E")
            String
sign <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"+" ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"-")
            let missingExp :: ParsecT (Token Err) String (State ParsingEnv) String
missingExp = Pos -> Err -> ParsecT (Token Err) String (State ParsingEnv) String
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
start (String -> Err
MissingExponent (String -> Err) -> String -> Err
forall a b. (a -> b) -> a -> b
$ String
base String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
decimals String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
sign)
            String
exp <- Maybe String
-> (Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"exponent") Char -> Bool
Token String -> Bool
isDigit ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT (Token Err) String (State ParsingEnv) String
missingExp
            pure $ String
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
sign String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
exp
          pure $ String -> Lexeme
Numeric (String
sign String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
base String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
decimals String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
exp)

        bytes :: P Lexeme
bytes = do
          Pos
start <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
          String
_ <- String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"0xs"
          String
s <- (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"hexidecimal character") Char -> Bool
Token String -> Bool
isAlphaNum
          case Bytes -> Either Text Bytes
Bytes.fromBase16 (Bytes -> Either Text Bytes) -> Bytes -> Either Text Bytes
forall a b. (a -> b) -> a -> b
$ [Word8] -> Bytes
Bytes.fromWord8s (Line -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Line -> Word8) -> (Char -> Line) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Line
ord (Char -> Word8) -> String -> [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
s) of
            Left Text
_ -> Pos -> Err -> P Lexeme
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
start (String -> Err
InvalidBytesLiteral (String -> Err) -> String -> Err
forall a b. (a -> b) -> a -> b
$ String
"0xs" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s)
            Right Bytes
bs -> Lexeme -> P Lexeme
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Lexeme
Bytes Bytes
bs)
        otherbase :: P Lexeme
otherbase = P Lexeme
octal P Lexeme -> P Lexeme -> P Lexeme
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Lexeme
hex P Lexeme -> P Lexeme -> P Lexeme
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P Lexeme
binary
        octal :: P Lexeme
octal = do
          Pos
start <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
          ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) String
-> (Maybe String -> String -> P Lexeme)
-> P Lexeme
forall e s (m :: * -> *) a b c.
MonadParsec e s m =>
m a -> m b -> (a -> b -> m c) -> m c
commitAfter2 ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
sign (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"0o") ((Maybe String -> String -> P Lexeme) -> P Lexeme)
-> (Maybe String -> String -> P Lexeme) -> P Lexeme
forall a b. (a -> b) -> a -> b
$ \Maybe String
sign String
_ ->
            (Integer -> Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) Integer
-> P Lexeme
forall a b.
(a -> b)
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe String -> Integer -> Lexeme
num Maybe String
sign) ParsecT (Token Err) String (State ParsingEnv) Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
LP.octal P Lexeme -> P Lexeme -> P Lexeme
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Pos -> Err -> P Lexeme
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
start Err
InvalidOctalLiteral
        hex :: P Lexeme
hex = do
          Pos
start <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
          ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) String
-> (Maybe String -> String -> P Lexeme)
-> P Lexeme
forall e s (m :: * -> *) a b c.
MonadParsec e s m =>
m a -> m b -> (a -> b -> m c) -> m c
commitAfter2 ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
sign (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"0x") ((Maybe String -> String -> P Lexeme) -> P Lexeme)
-> (Maybe String -> String -> P Lexeme) -> P Lexeme
forall a b. (a -> b) -> a -> b
$ \Maybe String
sign String
_ ->
            (Integer -> Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) Integer
-> P Lexeme
forall a b.
(a -> b)
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe String -> Integer -> Lexeme
num Maybe String
sign) ParsecT (Token Err) String (State ParsingEnv) Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
LP.hexadecimal P Lexeme -> P Lexeme -> P Lexeme
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Pos -> Err -> P Lexeme
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
start Err
InvalidHexLiteral
        binary :: P Lexeme
binary = do
          Pos
start <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
          ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) String
-> (Maybe String -> String -> P Lexeme)
-> P Lexeme
forall e s (m :: * -> *) a b c.
MonadParsec e s m =>
m a -> m b -> (a -> b -> m c) -> m c
commitAfter2 ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
sign (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"0b") ((Maybe String -> String -> P Lexeme) -> P Lexeme)
-> (Maybe String -> String -> P Lexeme) -> P Lexeme
forall a b. (a -> b) -> a -> b
$ \Maybe String
sign String
_ ->
            (Integer -> Lexeme)
-> ParsecT (Token Err) String (State ParsingEnv) Integer
-> P Lexeme
forall a b.
(a -> b)
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe String -> Integer -> Lexeme
num Maybe String
sign) ParsecT (Token Err) String (State ParsingEnv) Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
LP.binary P Lexeme -> P Lexeme -> P Lexeme
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Pos -> Err -> P Lexeme
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
start Err
InvalidBinaryLiteral

        num :: Maybe String -> Integer -> Lexeme
        num :: Maybe String -> Integer -> Lexeme
num Maybe String
sign Integer
n = String -> Lexeme
Numeric (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
sign String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
n)
        sign :: ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
sign = ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"+" ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"-")

    hash :: ParsecT (Token Err) String m Lexeme
hash = ShortHash -> Lexeme
Hash (ShortHash -> Lexeme)
-> ParsecT (Token Err) String m ShortHash
-> ParsecT (Token Err) String m Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String m ShortHash
-> ParsecT (Token Err) String m ShortHash
forall a.
ParsecT (Token Err) String m a -> ParsecT (Token Err) String m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try ParsecT (Token Err) String m ShortHash
forall (m :: * -> *). ParsecT (Token Err) String m ShortHash
shortHashP

    reserved :: P [Token Lexeme]
    reserved :: P [Token Lexeme]
reserved =
      ([Token Lexeme] -> Pos -> Pos -> [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a.
(a -> Pos -> Pos -> [Token Lexeme]) -> P a -> P [Token Lexeme]
token' (\[Token Lexeme]
ts Pos
_ Pos
_ -> [Token Lexeme]
ts) (P [Token Lexeme] -> P [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b. (a -> b) -> a -> b
$
        P [Token Lexeme]
braces
          P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
parens
          P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
brackets
          P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
commaSeparator
          P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
delim
          P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
delayOrForce
          P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
keywords
          P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
layoutKeywords
      where
        keywords :: P [Token Lexeme]
keywords =
          -- yes "wordy" - just like a wordy keyword like "true", the literal "." (as in the dot in
          -- "forall a. a -> a") is considered the keyword "." so long as it is either followed by EOF, a space, or some
          -- non-wordy character (because ".foo" is a single identifier lexeme)
          String -> P [Token Lexeme]
wordyKw String
"."
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
symbolyKw String
":"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
openKw String
"@rewrite"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
symbolyKw String
"@"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
symbolyKw String
"||"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
symbolyKw String
"|"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
symbolyKw String
"&&"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
wordyKw String
"true"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
wordyKw String
"false"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
wordyKw String
"namespace"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
wordyKw String
"use"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
wordyKw String
"forall"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
wordyKw String
"∀"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
wordyKw String
"termLink"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
wordyKw String
"typeLink"

        wordyKw :: String -> P [Token Lexeme]
wordyKw String
s = (Token String -> Bool) -> P [Token Lexeme] -> P [Token Lexeme]
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Bool) -> m a -> m a
separated Char -> Bool
Token String -> Bool
wordySep (String -> P [Token Lexeme]
kw String
s)
        symbolyKw :: String -> P [Token Lexeme]
symbolyKw String
s = (Token String -> Bool) -> P [Token Lexeme] -> P [Token Lexeme]
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Bool) -> m a -> m a
separated (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
symbolyIdChar) (String -> P [Token Lexeme]
kw String
s)

        kw :: String -> P [Token Lexeme]
        kw :: String -> P [Token Lexeme]
kw String
s = ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
s) ParsecT (Token Err) String (State ParsingEnv) (Token String)
-> (Token String -> [Token Lexeme]) -> P [Token Lexeme]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Token String
token -> [String -> Lexeme
Reserved (String -> Lexeme) -> Token String -> Token Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String
token]

        layoutKeywords :: P [Token Lexeme]
        layoutKeywords :: P [Token Lexeme]
layoutKeywords =
          P [Token Lexeme]
ifElse
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
withKw
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
openKw String
"match"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
openKw String
"handle"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
typ
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
arr
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
rewriteArr
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
eq
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
openKw String
"cases"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
openKw String
"where"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
openKw String
"let"
            P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> P [Token Lexeme]
openKw String
"do"
          where
            ifElse :: P [Token Lexeme]
ifElse =
              String -> P [Token Lexeme]
openKw String
"if"
                P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
-> [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
closeKw' (String -> Maybe String
forall a. a -> Maybe a
Just String
"then") [String
"if"] (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"then")
                P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
-> [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
closeKw' (String -> Maybe String
forall a. a -> Maybe a
Just String
"else") [String
"then"] (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"else")
            modKw :: P [Token Lexeme]
modKw = (Text -> P [Token Lexeme]) -> P [Token Lexeme]
forall (f :: * -> *) a. Alternative f => (Text -> f a) -> f a
typeModifiersAlt ((Char -> Bool) -> String -> P [Token Lexeme]
openKw1 Char -> Bool
wordySep (String -> P [Token Lexeme])
-> (Text -> String) -> Text -> P [Token Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)
            typeOrAbilityKw :: P [Token Lexeme]
typeOrAbilityKw = (Text -> P [Token Lexeme]) -> P [Token Lexeme]
forall (f :: * -> *) a. Alternative f => (Text -> f a) -> f a
typeOrAbilityAlt (String -> P [Token Lexeme]
openTypeKw1 (String -> P [Token Lexeme])
-> (Text -> String) -> Text -> P [Token Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)
            typ :: P [Token Lexeme]
typ = P [Token Lexeme]
modKw P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P [Token Lexeme]
typeOrAbilityKw

            withKw :: P [Token Lexeme]
withKw = do
              [Token Lexeme
_ Pos
pos1 Pos
pos2] <- String -> P [Token Lexeme]
wordyKw String
"with"
              ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
              let l :: Layout
l = ParsingEnv -> Layout
layout ParsingEnv
env
              case [String] -> Layout -> Maybe (String, Line)
findClose [String
"handle", String
"match"] Layout
l of
                Maybe (String, Line)
Nothing -> Pos -> Err -> P [Token Lexeme]
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
pos1 (String -> String -> Err
CloseWithoutMatchingOpen String
msgOpen String
"'with'")
                  where
                    msgOpen :: String
msgOpen = String
"'handle' or 'match'"
                Just (String
withBlock, Line
n) -> do
                  let b :: String
b = String
withBlock String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-with"
                  ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {layout = drop n l, opening = Just b})
                  let opens :: [Token Lexeme]
opens = [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Open String
"with") Pos
pos1 Pos
pos2]
                  pure $ Line -> Token Lexeme -> [Token Lexeme]
forall a. Line -> a -> [a]
replicate Line
n (Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token Lexeme
Close Pos
pos1 Pos
pos2) [Token Lexeme] -> [Token Lexeme] -> [Token Lexeme]
forall a. [a] -> [a] -> [a]
++ [Token Lexeme]
opens

            -- In `structural/unique type` and `structural/unique ability`,
            -- only the `structural` or `unique` opens a layout block,
            -- and `ability` and `type` are just keywords.
            openTypeKw1 :: String -> P [Token Lexeme]
openTypeKw1 String
t = do
              Maybe String
b <- (ParsingEnv -> Maybe String)
-> ParsecT (Token Err) String (State ParsingEnv) (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets (Layout -> Maybe String
topBlockName (Layout -> Maybe String)
-> (ParsingEnv -> Layout) -> ParsingEnv -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsingEnv -> Layout
layout)
              case Maybe String
b of
                Just String
mod | Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (String -> Text
Text.pack String
mod) Set Text
typeModifiers -> String -> P [Token Lexeme]
wordyKw String
t
                Maybe String
_ -> (Char -> Bool) -> String -> P [Token Lexeme]
openKw1 Char -> Bool
wordySep String
t

            -- layout keyword which bumps the layout column by 1, rather than looking ahead
            -- to the next token to determine the layout column
            openKw1 :: (Char -> Bool) -> String -> P [Token Lexeme]
            openKw1 :: (Char -> Bool) -> String -> P [Token Lexeme]
openKw1 Char -> Bool
sep String
kw = do
              Token String
kw Pos
pos0 Pos
pos1 <- ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP (ParsecT (Token Err) String (State ParsingEnv) String
 -> ParsecT (Token Err) String (State ParsingEnv) (Token String))
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall a b. (a -> b) -> a -> b
$ (Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Bool) -> m a -> m a
separated Char -> Bool
Token String -> Bool
sep (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
kw)
              (ParsingEnv -> ParsingEnv)
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify (\ParsingEnv
env -> ParsingEnv
env {layout = (kw, column $ inc pos0) : layout env})
              pure [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Open String
kw) Pos
pos0 Pos
pos1]

            eq :: P [Token Lexeme]
eq = do
              [Token Lexeme
_ Pos
start Pos
end] <- String -> P [Token Lexeme]
symbolyKw String
"="
              ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
              case Layout -> Maybe String
topBlockName (ParsingEnv -> Layout
layout ParsingEnv
env) of
                -- '=' does not open a layout block if within a type declaration
                Just String
t | String
t String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"type" Bool -> Bool -> Bool
|| Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (String -> Text
Text.pack String
t) Set Text
typeModifiers -> [Token Lexeme] -> P [Token Lexeme]
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Reserved String
"=") Pos
start Pos
end]
                Just String
_ -> ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {opening = Just "="}) ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Token Lexeme] -> P [Token Lexeme]
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Open String
"=") Pos
start Pos
end]
                Maybe String
_ -> Pos -> Err -> P [Token Lexeme]
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
start Err
LayoutError

            rewriteArr :: P [Token Lexeme]
rewriteArr = do
              [Token Lexeme
_ Pos
start Pos
end] <- String -> P [Token Lexeme]
symbolyKw String
"==>"
              ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
              ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {opening = Just "==>"}) ParsecT (Token Err) String (State ParsingEnv) ()
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) b
-> ParsecT (Token Err) String (State ParsingEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Token Lexeme] -> P [Token Lexeme]
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Open String
"==>") Pos
start Pos
end]

            arr :: P [Token Lexeme]
arr = do
              [Token Lexeme
_ Pos
start Pos
end] <- String -> P [Token Lexeme]
symbolyKw String
"->"
              ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
              -- -> introduces a layout block if we're inside a `match with` or `cases`
              case Layout -> Maybe String
topBlockName (ParsingEnv -> Layout
layout ParsingEnv
env) of
                Just String
match | String
match String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
matchWithBlocks -> do
                  ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {opening = Just "->"})
                  pure [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Open String
"->") Pos
start Pos
end]
                Maybe String
_ -> [Token Lexeme] -> P [Token Lexeme]
forall a. a -> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Reserved String
"->") Pos
start Pos
end]

        -- a bit of lookahead here to reserve }} for closing a documentation block
        braces :: P [Token Lexeme]
braces = String -> P [Token Lexeme]
open String
"{" P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
close [String
"{"] ParsecT (Token Err) String (State ParsingEnv) String
p
          where
            p :: ParsecT (Token Err) String (State ParsingEnv) String
p = do
              String
l <- String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"}"
              -- if we're within an existing {{ }} block, inLayout will be false
              -- so we can actually allow }} to appear in normal code
              Bool
inLayout <- (ParsingEnv -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ParsingEnv -> Bool
inLayout
              Bool
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
inLayout) (ParsecT (Token Err) String (State ParsingEnv) ()
 -> ParsecT (Token Err) String (State ParsingEnv) ())
-> ParsecT (Token Err) String (State ParsingEnv) ()
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall a b. (a -> b) -> a -> b
$ ParsecT (Token Err) String (State ParsingEnv) (Token String)
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT (Token Err) String (State ParsingEnv) (Token String)
 -> ParsecT (Token Err) String (State ParsingEnv) ())
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
-> ParsecT (Token Err) String (State ParsingEnv) ()
forall a b. (a -> b) -> a -> b
$ ParsecT (Token Err) String (State ParsingEnv) (Token String)
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead ((Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy (Token String -> Token String -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token String
'}'))
              pure String
l
        matchWithBlocks :: [String]
matchWithBlocks = [String
"match-with", String
"cases"]
        parens :: P [Token Lexeme]
parens = String -> P [Token Lexeme]
open String
"(" P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
close [String
"("] (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
")")
        brackets :: P [Token Lexeme]
brackets = String -> P [Token Lexeme]
open String
"[" P [Token Lexeme] -> P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
close [String
"["] (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
"]")
        -- `allowCommaToClose` determines if a comma should close inner blocks.
        -- Currently there is a set of blocks where `,` is not treated specially
        -- and it just emits a Reserved ",". There are currently only three:
        -- `cases`, `match-with`, and `{`
        allowCommaToClose :: String -> Bool
allowCommaToClose String
match = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
match String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"{" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
matchWithBlocks)
        commaSeparator :: P [Token Lexeme]
commaSeparator = do
          ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
          case Layout -> Maybe String
topBlockName (ParsingEnv -> Layout
layout ParsingEnv
env) of
            Just String
match
              | String -> Bool
allowCommaToClose String
match ->
                  [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
blockDelimiter [String
"[", String
"("] (String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
",")
            Maybe String
_ -> String -> P [Token Lexeme]
forall a. String -> ParsecT (Token Err) String (State ParsingEnv) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"this comma is a pattern separator"

        delim :: P [Token Lexeme]
delim = P [Token Lexeme] -> P [Token Lexeme]
forall a.
ParsecT (Token Err) String (State ParsingEnv) a
-> ParsecT (Token Err) String (State ParsingEnv) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.try (P [Token Lexeme] -> P [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b. (a -> b) -> a -> b
$ do
          Char
ch <- (Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy (\Token String
ch -> Char
Token String
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';' Bool -> Bool -> Bool
&& Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Char
Token String
ch Set Char
delimiters)
          Pos
pos <- ParsecT (Token Err) String (State ParsingEnv) Pos
forall e s (m :: * -> *).
(Ord e, TraversableStream s, MonadParsec e s m) =>
m Pos
posP
          pure [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Reserved [Char
ch]) Pos
pos (Pos -> Pos
inc Pos
pos)]

        delayOrForce :: P [Token Lexeme]
delayOrForce = (Token String -> Bool) -> P [Token Lexeme] -> P [Token Lexeme]
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Bool) -> m a -> m a
separated Char -> Bool
Token String -> Bool
ok (P [Token Lexeme] -> P [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b. (a -> b) -> a -> b
$ do
          Token Char
token <- ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) (Token Char)
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP (ParsecT (Token Err) String (State ParsingEnv) Char
 -> ParsecT (Token Err) String (State ParsingEnv) (Token Char))
-> ParsecT (Token Err) String (State ParsingEnv) Char
-> ParsecT (Token Err) String (State ParsingEnv) (Token Char)
forall a b. (a -> b) -> a -> b
$ (Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
P.satisfy Char -> Bool
Token String -> Bool
isDelayOrForce
          pure [Token Char
token Token Char -> (Char -> Lexeme) -> Token Lexeme
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Char
op -> String -> Lexeme
Reserved [Char
op]]
          where
            ok :: Char -> Bool
ok Char
c = Char -> Bool
isDelayOrForce Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Char
c Set Char
delimiters Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"'

open :: String -> P [Token Lexeme]
open :: String -> P [Token Lexeme]
open String
b = do
  Token String
token <- ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP (ParsecT (Token Err) String (State ParsingEnv) String
 -> ParsecT (Token Err) String (State ParsingEnv) (Token String))
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall a b. (a -> b) -> a -> b
$ String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
b
  ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
  ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {opening = Just b})
  pure [String -> Lexeme
Open String
b Lexeme -> Token String -> Token Lexeme
forall a b. a -> Token b -> Token a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token String
token]

openKw :: String -> P [Token Lexeme]
openKw :: String -> P [Token Lexeme]
openKw String
s = (Token String -> Bool) -> P [Token Lexeme] -> P [Token Lexeme]
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Bool) -> m a -> m a
separated Char -> Bool
Token String -> Bool
wordySep (P [Token Lexeme] -> P [Token Lexeme])
-> P [Token Lexeme] -> P [Token Lexeme]
forall a b. (a -> b) -> a -> b
$ do
  Token String
token <- ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP (ParsecT (Token Err) String (State ParsingEnv) String
 -> ParsecT (Token Err) String (State ParsingEnv) (Token String))
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall a b. (a -> b) -> a -> b
$ String -> ParsecT (Token Err) String (State ParsingEnv) String
forall e (m :: * -> *).
MonadParsec e String m =>
String -> m String
lit String
s
  ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
  ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {opening = Just s})
  pure [String -> Lexeme
Open (String -> Lexeme) -> Token String -> Token Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String
token]

tok :: P a -> P [Token a]
tok :: forall a. P a -> P [Token a]
tok P a
p = do
  Token a
token <- P a -> ParsecT (Token Err) String (State ParsingEnv) (Token a)
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP P a
p
  pure [Token a
token]

-- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is
-- symboly (comprised of only symbols) or wordy (comprised of only alphanums).
--
-- Examples:
--
--   foo
--   .foo.++.doc
--   `.`.`..`     (This is a two-segment identifier without a leading dot: "." then "..")
identifierP :: (Monad m) => P.ParsecT (Token Err) String m (HQ'.HashQualified Name)
identifierP :: forall (m :: * -> *).
Monad m =>
ParsecT (Token Err) String m (HashQualified Name)
identifierP = do
  String
-> ParsecT (Token Err) String m (HashQualified Name)
-> ParsecT (Token Err) String m (HashQualified Name)
forall a.
String
-> ParsecT (Token Err) String m a -> ParsecT (Token Err) String m a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
P.label String
"identifier (ex: abba1, snake_case, .foo.bar#xyz, .foo.++#xyz, or 🌻)" do
    Name
name <- (Token ParseErr -> Token Err)
-> ParsecT (Token ParseErr) String m Name
-> ParsecT (Token Err) String m Name
forall e e' s (m :: * -> *) a.
Ord e' =>
(e -> e') -> ParsecT e s m a -> ParsecT e' s m a
PI.withParsecT ((ParseErr -> Err) -> Token ParseErr -> Token Err
forall a b. (a -> b) -> Token a -> Token b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParseErr -> Err
nameSegmentParseErrToErr) ParsecT (Token ParseErr) String m Name
forall (m :: * -> *).
Monad m =>
ParsecT (Token ParseErr) String m Name
Name.nameP
    ParsecT (Token Err) String m ShortHash
-> ParsecT (Token Err) String m (Maybe ShortHash)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional ParsecT (Token Err) String m ShortHash
forall (m :: * -> *). ParsecT (Token Err) String m ShortHash
shortHashP ParsecT (Token Err) String m (Maybe ShortHash)
-> (Maybe ShortHash -> HashQualified Name)
-> ParsecT (Token Err) String m (HashQualified Name)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Maybe ShortHash
Nothing -> Name -> HashQualified Name
forall n. n -> HashQualified n
HQ'.fromName Name
name
      Just ShortHash
shorthash -> Name -> ShortHash -> HashQualified Name
forall n. n -> ShortHash -> HashQualified n
HQ'.HashQualified Name
name ShortHash
shorthash
  where
    nameSegmentParseErrToErr :: NameSegment.ParseErr -> Err
    nameSegmentParseErrToErr :: ParseErr -> Err
nameSegmentParseErrToErr = \case
      NameSegment.ReservedOperator Text
s -> String -> Err
ReservedSymbolyId (Text -> String
Text.unpack Text
s)
      NameSegment.ReservedWord Text
s -> String -> Err
ReservedWordyId (Text -> String
Text.unpack Text
s)

-- An identifier is a non-empty dot-delimited list of segments, with an optional leading dot, where each segment is
-- symboly (comprised of only symbols) or wordy (comprised of only alphanums).
--
-- Examples:
--
--   foo
--   .foo.++.doc
--   `.`.`..`     (This is a two-segment identifier without a leading dot: "." then "..")
identifierLexemeP :: P Lexeme
identifierLexemeP :: P Lexeme
identifierLexemeP = HashQualified Name -> Lexeme
identifierLexeme (HashQualified Name -> Lexeme)
-> ParsecT
     (Token Err) String (State ParsingEnv) (HashQualified Name)
-> P Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT (Token Err) String (State ParsingEnv) (HashQualified Name)
forall (m :: * -> *).
Monad m =>
ParsecT (Token Err) String m (HashQualified Name)
identifierP

identifierLexeme :: HQ'.HashQualified Name -> Lexeme
identifierLexeme :: HashQualified Name -> Lexeme
identifierLexeme HashQualified Name
name =
  if Name -> Bool
Name.isSymboly (HashQualified Name -> Name
forall n. HashQualified n -> n
HQ'.toName HashQualified Name
name)
    then HashQualified Name -> Lexeme
SymbolyId HashQualified Name
name
    else HashQualified Name -> Lexeme
WordyId HashQualified Name
name

shortHashP :: P.ParsecT (Token Err) String m ShortHash
shortHashP :: forall (m :: * -> *). ParsecT (Token Err) String m ShortHash
shortHashP =
  (Token Text -> Token Err)
-> ParsecT (Token Text) String m ShortHash
-> ParsecT (Token Err) String m ShortHash
forall e e' s (m :: * -> *) a.
Ord e' =>
(e -> e') -> ParsecT e s m a -> ParsecT e' s m a
PI.withParsecT ((Text -> Err) -> Token Text -> Token Err
forall a b. (a -> b) -> Token a -> Token b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Err
InvalidShortHash (String -> Err) -> (Text -> String) -> Text -> Err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)) ParsecT (Token Text) String m ShortHash
forall (m :: * -> *). ParsecT (Token Text) String m ShortHash
ShortHash.shortHashP

blockDelimiter :: [String] -> P String -> P [Token Lexeme]
blockDelimiter :: [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
blockDelimiter [String]
open ParsecT (Token Err) String (State ParsingEnv) String
closeP = do
  Token String
close Pos
pos1 Pos
pos2 <- ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP ParsecT (Token Err) String (State ParsingEnv) String
closeP
  ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
  case [String] -> Layout -> Maybe (String, Line)
findClose [String]
open (ParsingEnv -> Layout
layout ParsingEnv
env) of
    Maybe (String, Line)
Nothing -> Pos -> Err -> P [Token Lexeme]
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
pos1 (String -> Err
UnexpectedDelimiter (ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
quote String
close))
      where
        quote :: a -> a
quote a
s = a
"'" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"'"
    Just (String
_, Line
n) -> do
      ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {layout = drop (n - 1) (layout env)})
      let delims :: [Token Lexeme]
delims = [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Reserved String
close) Pos
pos1 Pos
pos2]
      pure $ Line -> Token Lexeme -> [Token Lexeme]
forall a. Line -> a -> [a]
replicate (Line
n Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
1) (Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token Lexeme
Close Pos
pos1 Pos
pos2) [Token Lexeme] -> [Token Lexeme] -> [Token Lexeme]
forall a. [a] -> [a] -> [a]
++ [Token Lexeme]
delims

close :: [String] -> P String -> P [Token Lexeme]
close :: [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
close = Maybe String
-> [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
close' Maybe String
forall a. Maybe a
Nothing

closeKw' :: Maybe String -> [String] -> P String -> P [Token Lexeme]
closeKw' :: Maybe String
-> [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
closeKw' Maybe String
reopenBlockname [String]
open ParsecT (Token Err) String (State ParsingEnv) String
closeP = Maybe String
-> [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
close' Maybe String
reopenBlockname [String]
open ((Token String -> Bool)
-> ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Bool) -> m a -> m a
separated Char -> Bool
Token String -> Bool
wordySep ParsecT (Token Err) String (State ParsingEnv) String
closeP)

close' :: Maybe String -> [String] -> P String -> P [Token Lexeme]
close' :: Maybe String
-> [String]
-> ParsecT (Token Err) String (State ParsingEnv) String
-> P [Token Lexeme]
close' Maybe String
reopenBlockname [String]
open ParsecT (Token Err) String (State ParsingEnv) String
closeP = do
  Token String
close Pos
pos1 Pos
pos2 <- ParsecT (Token Err) String (State ParsingEnv) String
-> ParsecT (Token Err) String (State ParsingEnv) (Token String)
forall e s (m :: * -> *) a.
(Ord e, TraversableStream s, MonadParsec e s m) =>
m a -> m (Token a)
tokenP ParsecT (Token Err) String (State ParsingEnv) String
closeP
  ParsingEnv
env <- ParsecT (Token Err) String (State ParsingEnv) ParsingEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
  case [String] -> Layout -> Maybe (String, Line)
findClose [String]
open (ParsingEnv -> Layout
layout ParsingEnv
env) of
    Maybe (String, Line)
Nothing -> Pos -> Err -> P [Token Lexeme]
forall s (m :: * -> *) x.
(TraversableStream s, MonadParsec (Token Err) s m) =>
Pos -> Err -> m x
err Pos
pos1 (String -> String -> Err
CloseWithoutMatchingOpen String
msgOpen (ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
quote String
close))
      where
        msgOpen :: String
msgOpen = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
" or " (ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
quote ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
open)
        quote :: a -> a
quote a
s = a
"'" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"'"
    Just (String
_, Line
n) -> do
      ParsingEnv -> ParsecT (Token Err) String (State ParsingEnv) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (ParsingEnv
env {layout = drop n (layout env), opening = reopenBlockname})
      let opens :: [Token Lexeme]
opens = [Token Lexeme]
-> (String -> [Token Lexeme]) -> Maybe String -> [Token Lexeme]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([Token Lexeme] -> String -> [Token Lexeme]
forall a b. a -> b -> a
const ([Token Lexeme] -> String -> [Token Lexeme])
-> [Token Lexeme] -> String -> [Token Lexeme]
forall a b. (a -> b) -> a -> b
$ [Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (String -> Lexeme
Open String
close) Pos
pos1 Pos
pos2]) Maybe String
reopenBlockname
      pure $ Line -> Token Lexeme -> [Token Lexeme]
forall a. Line -> a -> [a]
replicate Line
n (Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token Lexeme
Close Pos
pos1 Pos
pos2) [Token Lexeme] -> [Token Lexeme] -> [Token Lexeme]
forall a. [a] -> [a] -> [a]
++ [Token Lexeme]
opens

findClose :: [String] -> Layout -> Maybe (String, Int)
findClose :: [String] -> Layout -> Maybe (String, Line)
findClose [String]
_ [] = Maybe (String, Line)
forall a. Maybe a
Nothing
findClose [String]
s ((String
h, Line
_) : Layout
tl) = if String
h String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
s then (String, Line) -> Maybe (String, Line)
forall a. a -> Maybe a
Just (String
h, Line
1) else (Line -> Line) -> (String, Line) -> (String, Line)
forall a b. (a -> b) -> (String, a) -> (String, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Line
1 Line -> Line -> Line
forall a. Num a => a -> a -> a
+) ((String, Line) -> (String, Line))
-> Maybe (String, Line) -> Maybe (String, Line)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Layout -> Maybe (String, Line)
findClose [String]
s Layout
tl

notLayout :: Token Lexeme -> Bool
notLayout :: Token Lexeme -> Bool
notLayout Token Lexeme
t = case Token Lexeme -> Lexeme
forall a. Token a -> a
payload Token Lexeme
t of
  Lexeme
Close -> Bool
False
  Semi Bool
_ -> Bool
False
  Open String
_ -> Bool
False
  Lexeme
_ -> Bool
True

top :: Layout -> Column
top :: Layout -> Line
top [] = Line
1
top ((String
_, Line
h) : Layout
_) = Line
h

-- todo: make Layout a NonEmpty
topBlockName :: Layout -> Maybe BlockName
topBlockName :: Layout -> Maybe String
topBlockName [] = Maybe String
forall a. Maybe a
Nothing
topBlockName ((String
name, Line
_) : Layout
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
name

topLeftCorner :: Pos
topLeftCorner :: Pos
topLeftCorner = Line -> Line -> Pos
Pos Line
1 Line
1

data BlockTree a
  = Block
      -- | The token that opens the block
      a
      -- | “Stanzas” of nested tokens
      [[BlockTree a]]
      -- | The closing token, if any
      (Maybe a)
  | Leaf a
  deriving ((forall a b. (a -> b) -> BlockTree a -> BlockTree b)
-> (forall a b. a -> BlockTree b -> BlockTree a)
-> Functor BlockTree
forall a b. a -> BlockTree b -> BlockTree a
forall a b. (a -> b) -> BlockTree a -> BlockTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> BlockTree a -> BlockTree b
fmap :: forall a b. (a -> b) -> BlockTree a -> BlockTree b
$c<$ :: forall a b. a -> BlockTree b -> BlockTree a
<$ :: forall a b. a -> BlockTree b -> BlockTree a
Functor, (forall m. Monoid m => BlockTree m -> m)
-> (forall m a. Monoid m => (a -> m) -> BlockTree a -> m)
-> (forall m a. Monoid m => (a -> m) -> BlockTree a -> m)
-> (forall a b. (a -> b -> b) -> b -> BlockTree a -> b)
-> (forall a b. (a -> b -> b) -> b -> BlockTree a -> b)
-> (forall b a. (b -> a -> b) -> b -> BlockTree a -> b)
-> (forall b a. (b -> a -> b) -> b -> BlockTree a -> b)
-> (forall a. (a -> a -> a) -> BlockTree a -> a)
-> (forall a. (a -> a -> a) -> BlockTree a -> a)
-> (forall a. BlockTree a -> [a])
-> (forall a. BlockTree a -> Bool)
-> (forall a. BlockTree a -> Line)
-> (forall a. Eq a => a -> BlockTree a -> Bool)
-> (forall a. Ord a => BlockTree a -> a)
-> (forall a. Ord a => BlockTree a -> a)
-> (forall a. Num a => BlockTree a -> a)
-> (forall a. Num a => BlockTree a -> a)
-> Foldable BlockTree
forall a. Eq a => a -> BlockTree a -> Bool
forall a. Num a => BlockTree a -> a
forall a. Ord a => BlockTree a -> a
forall m. Monoid m => BlockTree m -> m
forall a. BlockTree a -> Bool
forall a. BlockTree a -> Line
forall a. BlockTree a -> [a]
forall a. (a -> a -> a) -> BlockTree a -> a
forall m a. Monoid m => (a -> m) -> BlockTree a -> m
forall b a. (b -> a -> b) -> b -> BlockTree a -> b
forall a b. (a -> b -> b) -> b -> BlockTree a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Line)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => BlockTree m -> m
fold :: forall m. Monoid m => BlockTree m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> BlockTree a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> BlockTree a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> BlockTree a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> BlockTree a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> BlockTree a -> b
foldr :: forall a b. (a -> b -> b) -> b -> BlockTree a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> BlockTree a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> BlockTree a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> BlockTree a -> b
foldl :: forall b a. (b -> a -> b) -> b -> BlockTree a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> BlockTree a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> BlockTree a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> BlockTree a -> a
foldr1 :: forall a. (a -> a -> a) -> BlockTree a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> BlockTree a -> a
foldl1 :: forall a. (a -> a -> a) -> BlockTree a -> a
$ctoList :: forall a. BlockTree a -> [a]
toList :: forall a. BlockTree a -> [a]
$cnull :: forall a. BlockTree a -> Bool
null :: forall a. BlockTree a -> Bool
$clength :: forall a. BlockTree a -> Line
length :: forall a. BlockTree a -> Line
$celem :: forall a. Eq a => a -> BlockTree a -> Bool
elem :: forall a. Eq a => a -> BlockTree a -> Bool
$cmaximum :: forall a. Ord a => BlockTree a -> a
maximum :: forall a. Ord a => BlockTree a -> a
$cminimum :: forall a. Ord a => BlockTree a -> a
minimum :: forall a. Ord a => BlockTree a -> a
$csum :: forall a. Num a => BlockTree a -> a
sum :: forall a. Num a => BlockTree a -> a
$cproduct :: forall a. Num a => BlockTree a -> a
product :: forall a. Num a => BlockTree a -> a
Foldable, Functor BlockTree
Foldable BlockTree
(Functor BlockTree, Foldable BlockTree) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> BlockTree a -> f (BlockTree b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    BlockTree (f a) -> f (BlockTree a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> BlockTree a -> m (BlockTree b))
-> (forall (m :: * -> *) a.
    Monad m =>
    BlockTree (m a) -> m (BlockTree a))
-> Traversable BlockTree
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
BlockTree (m a) -> m (BlockTree a)
forall (f :: * -> *) a.
Applicative f =>
BlockTree (f a) -> f (BlockTree a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BlockTree a -> m (BlockTree b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BlockTree a -> f (BlockTree b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BlockTree a -> f (BlockTree b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BlockTree a -> f (BlockTree b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
BlockTree (f a) -> f (BlockTree a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
BlockTree (f a) -> f (BlockTree a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BlockTree a -> m (BlockTree b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BlockTree a -> m (BlockTree b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
BlockTree (m a) -> m (BlockTree a)
sequence :: forall (m :: * -> *) a.
Monad m =>
BlockTree (m a) -> m (BlockTree a)
Traversable)

headToken :: BlockTree a -> a
headToken :: forall a. BlockTree a -> a
headToken (Block a
a [[BlockTree a]]
_ Maybe a
_) = a
a
headToken (Leaf a
a) = a
a

instance (Show a) => Show (BlockTree a) where
  showsPrec :: Line -> BlockTree a -> ShowS
showsPrec = Line -> BlockTree a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Line -> f a -> ShowS
showsPrec1

-- | This instance should be compatible with `Read`, but inserts newlines and indentation to make it more
--  /human/-readable.
instance Show1 BlockTree where
  liftShowsPrec :: forall a.
(Line -> a -> ShowS)
-> ([a] -> ShowS) -> Line -> BlockTree a -> ShowS
liftShowsPrec Line -> a -> ShowS
spa [a] -> ShowS
sla = String -> Line -> BlockTree a -> ShowS
shows String
""
    where
      shows :: String -> Line -> BlockTree a -> ShowS
shows String
by Line
prec =
        Bool -> ShowS -> ShowS
showParen (Line
prec Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
> Line
appPrec) (ShowS -> ShowS) -> (BlockTree a -> ShowS) -> BlockTree a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
          Leaf a
a -> String -> ShowS
showString String
"Leaf " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> a -> ShowS) -> String -> a -> ShowS
forall x. (Line -> x -> ShowS) -> String -> x -> ShowS
showsNext Line -> a -> ShowS
spa String
"" a
a
          Block a
open [[BlockTree a]]
mid Maybe a
close ->
            String -> ShowS
showString String
"Block "
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> a -> ShowS) -> String -> a -> ShowS
forall x. (Line -> x -> ShowS) -> String -> x -> ShowS
showsNext Line -> a -> ShowS
spa String
"" a
open
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n"
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [BlockTree a] -> ShowS)
-> String -> [[BlockTree a]] -> ShowS
forall x. (String -> x -> ShowS) -> String -> [x] -> ShowS
showIndentedList ((String -> BlockTree a -> ShowS)
-> String -> [BlockTree a] -> ShowS
forall x. (String -> x -> ShowS) -> String -> [x] -> ShowS
showIndentedList (\String
b -> (BlockTree a -> ShowS) -> String -> BlockTree a -> ShowS
forall x. (x -> ShowS) -> String -> x -> ShowS
showsIndented (String -> Line -> BlockTree a -> ShowS
shows String
b Line
0) String
b)) (String
"  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
by) [[BlockTree a]]
mid
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n"
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> Maybe a -> ShowS) -> String -> Maybe a -> ShowS
forall x. (Line -> x -> ShowS) -> String -> x -> ShowS
showsNext ((Line -> a -> ShowS) -> ([a] -> ShowS) -> Line -> Maybe a -> ShowS
forall a.
(Line -> a -> ShowS) -> ([a] -> ShowS) -> Line -> Maybe a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Line -> a -> ShowS) -> ([a] -> ShowS) -> Line -> f a -> ShowS
liftShowsPrec Line -> a -> ShowS
spa [a] -> ShowS
sla) (String
"  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
by) Maybe a
close
      appPrec :: Line
appPrec = Line
10
      showsNext :: (Int -> x -> ShowS) -> String -> x -> ShowS
      showsNext :: forall x. (Line -> x -> ShowS) -> String -> x -> ShowS
showsNext Line -> x -> ShowS
fn = (x -> ShowS) -> String -> x -> ShowS
forall x. (x -> ShowS) -> String -> x -> ShowS
showsIndented (Line -> x -> ShowS
fn (Line -> x -> ShowS) -> Line -> x -> ShowS
forall a b. (a -> b) -> a -> b
$ Line
appPrec Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
1)
      showsIndented :: (x -> ShowS) -> String -> x -> ShowS
      showsIndented :: forall x. (x -> ShowS) -> String -> x -> ShowS
showsIndented x -> ShowS
fn String
by x
x = String -> ShowS
showString String
by ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> ShowS
fn x
x
      showIndentedList :: (String -> x -> ShowS) -> String -> [x] -> ShowS
      showIndentedList :: forall x. (String -> x -> ShowS) -> String -> [x] -> ShowS
showIndentedList String -> x -> ShowS
fn String
by [x]
xs =
        String -> ShowS
showString String
by
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"["
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> ShowS -> ShowS) -> ShowS -> [x] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\x
x ShowS
acc -> String -> ShowS
showString String
"\n" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> x -> ShowS
fn (String
"  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
by) x
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"," ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
acc) ShowS
forall a. a -> a
id [x]
xs
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n"
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
by
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"]"

reorderTree :: ([[BlockTree a]] -> [[BlockTree a]]) -> BlockTree a -> BlockTree a
reorderTree :: forall a.
([[BlockTree a]] -> [[BlockTree a]]) -> BlockTree a -> BlockTree a
reorderTree [[BlockTree a]] -> [[BlockTree a]]
f (Block a
open [[BlockTree a]]
mid Maybe a
close) = a -> [[BlockTree a]] -> Maybe a -> BlockTree a
forall a. a -> [[BlockTree a]] -> Maybe a -> BlockTree a
Block a
open ([[BlockTree a]] -> [[BlockTree a]]
f ((BlockTree a -> BlockTree a) -> [BlockTree a] -> [BlockTree a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[BlockTree a]] -> [[BlockTree a]]) -> BlockTree a -> BlockTree a
forall a.
([[BlockTree a]] -> [[BlockTree a]]) -> BlockTree a -> BlockTree a
reorderTree [[BlockTree a]] -> [[BlockTree a]]
f) ([BlockTree a] -> [BlockTree a])
-> [[BlockTree a]] -> [[BlockTree a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[BlockTree a]]
mid)) Maybe a
close
reorderTree [[BlockTree a]] -> [[BlockTree a]]
_ BlockTree a
l = BlockTree a
l

tree :: [Token Lexeme] -> BlockTree (Token Lexeme)
tree :: [Token Lexeme] -> BlockTree (Token Lexeme)
tree [Token Lexeme]
toks = [Token Lexeme]
-> (BlockTree (Token Lexeme)
    -> [Token Lexeme] -> BlockTree (Token Lexeme))
-> BlockTree (Token Lexeme)
one [Token Lexeme]
toks BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
forall a b. a -> b -> a
const
  where
    one :: [Token Lexeme]
-> (BlockTree (Token Lexeme)
    -> [Token Lexeme] -> BlockTree (Token Lexeme))
-> BlockTree (Token Lexeme)
one (open :: Token Lexeme
open@(Token Lexeme -> Lexeme
forall a. Token a -> a
payload -> Open String
_) : [Token Lexeme]
ts) BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k = ([BlockTree (Token Lexeme)]
 -> Maybe (Token Lexeme) -> BlockTree (Token Lexeme))
-> [BlockTree (Token Lexeme)]
-> [Token Lexeme]
-> (BlockTree (Token Lexeme)
    -> [Token Lexeme] -> BlockTree (Token Lexeme))
-> BlockTree (Token Lexeme)
many (Token Lexeme
-> [[BlockTree (Token Lexeme)]]
-> Maybe (Token Lexeme)
-> BlockTree (Token Lexeme)
forall a. a -> [[BlockTree a]] -> Maybe a -> BlockTree a
Block Token Lexeme
open ([[BlockTree (Token Lexeme)]]
 -> Maybe (Token Lexeme) -> BlockTree (Token Lexeme))
-> ([BlockTree (Token Lexeme)] -> [[BlockTree (Token Lexeme)]])
-> [BlockTree (Token Lexeme)]
-> Maybe (Token Lexeme)
-> BlockTree (Token Lexeme)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BlockTree (Token Lexeme)] -> [[BlockTree (Token Lexeme)]]
stanzas) [] [Token Lexeme]
ts BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k
    one (Token Lexeme
t : [Token Lexeme]
ts) BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k = BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k (Token Lexeme -> BlockTree (Token Lexeme)
forall a. a -> BlockTree a
Leaf Token Lexeme
t) [Token Lexeme]
ts
    one [] BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k = BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k BlockTree (Token Lexeme)
lastErr []
      where
        lastErr :: BlockTree (Token Lexeme)
lastErr = Token Lexeme -> BlockTree (Token Lexeme)
forall a. a -> BlockTree a
Leaf case Line -> [Token Lexeme] -> [Token Lexeme]
forall a. Line -> [a] -> [a]
drop ([Token Lexeme] -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length [Token Lexeme]
toks Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
1) [Token Lexeme]
toks of
          [] -> Lexeme -> Pos -> Pos -> Token Lexeme
forall a. a -> Pos -> Pos -> Token a
Token (Err -> Lexeme
Err Err
LayoutError) Pos
topLeftCorner Pos
topLeftCorner
          (Token Lexeme
t : [Token Lexeme]
_) -> Token Lexeme
t {payload = Err LayoutError}

    many :: ([BlockTree (Token Lexeme)]
 -> Maybe (Token Lexeme) -> BlockTree (Token Lexeme))
-> [BlockTree (Token Lexeme)]
-> [Token Lexeme]
-> (BlockTree (Token Lexeme)
    -> [Token Lexeme] -> BlockTree (Token Lexeme))
-> BlockTree (Token Lexeme)
many [BlockTree (Token Lexeme)]
-> Maybe (Token Lexeme) -> BlockTree (Token Lexeme)
open [BlockTree (Token Lexeme)]
acc [] BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k = BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k ([BlockTree (Token Lexeme)]
-> Maybe (Token Lexeme) -> BlockTree (Token Lexeme)
open ([BlockTree (Token Lexeme)] -> [BlockTree (Token Lexeme)]
forall a. [a] -> [a]
reverse [BlockTree (Token Lexeme)]
acc) Maybe (Token Lexeme)
forall a. Maybe a
Nothing) []
    many [BlockTree (Token Lexeme)]
-> Maybe (Token Lexeme) -> BlockTree (Token Lexeme)
open [BlockTree (Token Lexeme)]
acc (t :: Token Lexeme
t@(Token Lexeme -> Lexeme
forall a. Token a -> a
payload -> Lexeme
Close) : [Token Lexeme]
ts) BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k = BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k ([BlockTree (Token Lexeme)]
-> Maybe (Token Lexeme) -> BlockTree (Token Lexeme)
open ([BlockTree (Token Lexeme)] -> [BlockTree (Token Lexeme)]
forall a. [a] -> [a]
reverse [BlockTree (Token Lexeme)]
acc) (Maybe (Token Lexeme) -> BlockTree (Token Lexeme))
-> Maybe (Token Lexeme) -> BlockTree (Token Lexeme)
forall a b. (a -> b) -> a -> b
$ Token Lexeme -> Maybe (Token Lexeme)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Token Lexeme
t) [Token Lexeme]
ts
    many [BlockTree (Token Lexeme)]
-> Maybe (Token Lexeme) -> BlockTree (Token Lexeme)
open [BlockTree (Token Lexeme)]
acc [Token Lexeme]
ts BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k = [Token Lexeme]
-> (BlockTree (Token Lexeme)
    -> [Token Lexeme] -> BlockTree (Token Lexeme))
-> BlockTree (Token Lexeme)
one [Token Lexeme]
ts ((BlockTree (Token Lexeme)
  -> [Token Lexeme] -> BlockTree (Token Lexeme))
 -> BlockTree (Token Lexeme))
-> (BlockTree (Token Lexeme)
    -> [Token Lexeme] -> BlockTree (Token Lexeme))
-> BlockTree (Token Lexeme)
forall a b. (a -> b) -> a -> b
$ \BlockTree (Token Lexeme)
t [Token Lexeme]
ts -> ([BlockTree (Token Lexeme)]
 -> Maybe (Token Lexeme) -> BlockTree (Token Lexeme))
-> [BlockTree (Token Lexeme)]
-> [Token Lexeme]
-> (BlockTree (Token Lexeme)
    -> [Token Lexeme] -> BlockTree (Token Lexeme))
-> BlockTree (Token Lexeme)
many [BlockTree (Token Lexeme)]
-> Maybe (Token Lexeme) -> BlockTree (Token Lexeme)
open (BlockTree (Token Lexeme)
t BlockTree (Token Lexeme)
-> [BlockTree (Token Lexeme)] -> [BlockTree (Token Lexeme)]
forall a. a -> [a] -> [a]
: [BlockTree (Token Lexeme)]
acc) [Token Lexeme]
ts BlockTree (Token Lexeme)
-> [Token Lexeme] -> BlockTree (Token Lexeme)
k

stanzas :: [BlockTree (Token Lexeme)] -> [[BlockTree (Token Lexeme)]]
stanzas :: [BlockTree (Token Lexeme)] -> [[BlockTree (Token Lexeme)]]
stanzas =
  NonEmpty [BlockTree (Token Lexeme)] -> [[BlockTree (Token Lexeme)]]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
    (NonEmpty [BlockTree (Token Lexeme)]
 -> [[BlockTree (Token Lexeme)]])
-> ([BlockTree (Token Lexeme)]
    -> NonEmpty [BlockTree (Token Lexeme)])
-> [BlockTree (Token Lexeme)]
-> [[BlockTree (Token Lexeme)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockTree (Token Lexeme)
 -> NonEmpty [BlockTree (Token Lexeme)]
 -> NonEmpty [BlockTree (Token Lexeme)])
-> NonEmpty [BlockTree (Token Lexeme)]
-> [BlockTree (Token Lexeme)]
-> NonEmpty [BlockTree (Token Lexeme)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      ( \BlockTree (Token Lexeme)
tok ([BlockTree (Token Lexeme)]
curr :| [[BlockTree (Token Lexeme)]]
stanzas) -> case BlockTree (Token Lexeme)
tok of
          Leaf (Token (Semi Bool
_) Pos
_ Pos
_) -> [BlockTree (Token Lexeme)
tok] [BlockTree (Token Lexeme)]
-> [[BlockTree (Token Lexeme)]]
-> NonEmpty [BlockTree (Token Lexeme)]
forall a. a -> [a] -> NonEmpty a
:| [BlockTree (Token Lexeme)]
curr [BlockTree (Token Lexeme)]
-> [[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]]
forall a. a -> [a] -> [a]
: [[BlockTree (Token Lexeme)]]
stanzas
          BlockTree (Token Lexeme)
_ -> (BlockTree (Token Lexeme)
tok BlockTree (Token Lexeme)
-> [BlockTree (Token Lexeme)] -> [BlockTree (Token Lexeme)]
forall a. a -> [a] -> [a]
: [BlockTree (Token Lexeme)]
curr) [BlockTree (Token Lexeme)]
-> [[BlockTree (Token Lexeme)]]
-> NonEmpty [BlockTree (Token Lexeme)]
forall a. a -> [a] -> NonEmpty a
:| [[BlockTree (Token Lexeme)]]
stanzas
      )
      ([] [BlockTree (Token Lexeme)]
-> [[BlockTree (Token Lexeme)]]
-> NonEmpty [BlockTree (Token Lexeme)]
forall a. a -> [a] -> NonEmpty a
:| [])

-- Moves type and ability declarations to the front of the token stream (but not before the leading optional namespace
-- directive) and move `use` statements to the front of each block
reorder :: [[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]]
reorder :: [[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]]
reorder = ([BlockTree (Token Lexeme)]
 -> [[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]])
-> [[BlockTree (Token Lexeme)]]
-> [[BlockTree (Token Lexeme)]]
-> [[BlockTree (Token Lexeme)]]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [BlockTree (Token Lexeme)]
-> [[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]]
forall {a}.
Snoc a a (BlockTree (Token Lexeme)) (BlockTree (Token Lexeme)) =>
a -> [a] -> [a]
fixup [] ([[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]])
-> ([[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]])
-> [[BlockTree (Token Lexeme)]]
-> [[BlockTree (Token Lexeme)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([BlockTree (Token Lexeme)] -> Line)
-> [[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith [BlockTree (Token Lexeme)] -> Line
f
  where
    f :: [BlockTree (Token Lexeme)] -> Line
f [] = Line
4 :: Int
    f (BlockTree (Token Lexeme)
t0 : [BlockTree (Token Lexeme)]
_) = case Token Lexeme -> Lexeme
forall a. Token a -> a
payload (Token Lexeme -> Lexeme) -> Token Lexeme -> Lexeme
forall a b. (a -> b) -> a -> b
$ BlockTree (Token Lexeme) -> Token Lexeme
forall a. BlockTree a -> a
headToken BlockTree (Token Lexeme)
t0 of
      Open String
mod | Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (String -> Text
Text.pack String
mod) Set Text
typeModifiers -> Line
3
      Open String
typOrA | Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (String -> Text
Text.pack String
typOrA) Set Text
typeOrAbility -> Line
3
      -- put `namespace` before `use` because the file parser only accepts a namespace directive at the top of the file
      Reserved String
"namespace" -> Line
1
      Reserved String
"use" -> Line
2
      Lexeme
_ -> Line
4 :: Int
    -- after reordering can end up with trailing semicolon at the end of
    -- a block, which we remove with this pass
    fixup :: a -> [a] -> [a]
fixup a
stanza [] = case a -> Maybe (a, BlockTree (Token Lexeme))
forall s a. Snoc s s a a => s -> Maybe (s, a)
Lens.unsnoc a
stanza of
      Maybe (a, BlockTree (Token Lexeme))
Nothing -> []
      -- remove any trailing `Semi` from the last non-empty stanza
      Just (a
init, Leaf (Token (Semi Bool
_) Pos
_ Pos
_)) -> [a
init]
      -- don’t touch other stanzas
      Just (a
_, BlockTree (Token Lexeme)
_) -> [a
stanza]
    fixup a
stanza [a]
tail = a
stanza a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
tail

-- | This turns the lexeme stream into a tree, reordering some lexeme subsequences.
preParse :: [Token Lexeme] -> BlockTree (Token Lexeme)
preParse :: [Token Lexeme] -> BlockTree (Token Lexeme)
preParse = ([[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]])
-> BlockTree (Token Lexeme) -> BlockTree (Token Lexeme)
forall a.
([[BlockTree a]] -> [[BlockTree a]]) -> BlockTree a -> BlockTree a
reorderTree [[BlockTree (Token Lexeme)]] -> [[BlockTree (Token Lexeme)]]
reorder (BlockTree (Token Lexeme) -> BlockTree (Token Lexeme))
-> ([Token Lexeme] -> BlockTree (Token Lexeme))
-> [Token Lexeme]
-> BlockTree (Token Lexeme)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token Lexeme] -> BlockTree (Token Lexeme)
tree

-- | A few transformations that happen between lexing and parsing.
--
--   All of these things should move out of the lexer, and be applied in the parse.
postLex :: [Token Lexeme] -> [Token Lexeme]
postLex :: [Token Lexeme] -> [Token Lexeme]
postLex = BlockTree (Token Lexeme) -> [Token Lexeme]
forall a. BlockTree a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (BlockTree (Token Lexeme) -> [Token Lexeme])
-> ([Token Lexeme] -> BlockTree (Token Lexeme))
-> [Token Lexeme]
-> [Token Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token Lexeme] -> BlockTree (Token Lexeme)
preParse ([Token Lexeme] -> BlockTree (Token Lexeme))
-> ([Token Lexeme] -> [Token Lexeme])
-> [Token Lexeme]
-> BlockTree (Token Lexeme)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token Lexeme -> [Token Lexeme] -> [Token Lexeme])
-> [Token Lexeme] -> [Token Lexeme] -> [Token Lexeme]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Token Lexeme -> [Token Lexeme] -> [Token Lexeme]
tweak []

isDelayOrForce :: Char -> Bool
isDelayOrForce :: Char -> Bool
isDelayOrForce Char
op = Char
op Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
op Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!'

-- Mapping between characters and their escape codes. Use parse/showEscapeChar to convert.
escapeChars :: [(Char, Char)]
escapeChars :: [(Char, Char)]
escapeChars =
  [ (Char
'0', Char
'\0'),
    (Char
'a', Char
'\a'),
    (Char
'b', Char
'\b'),
    (Char
'f', Char
'\f'),
    (Char
'n', Char
'\n'),
    (Char
'r', Char
'\r'),
    (Char
't', Char
'\t'),
    (Char
'v', Char
'\v'),
    (Char
's', Char
' '),
    (Char
'\'', Char
'\''),
    (Char
'"', Char
'"'),
    (Char
'\\', Char
'\\')
  ]

-- Inverse of parseEscapeChar; map a character to its escaped version:
showEscapeChar :: Char -> Maybe Char
showEscapeChar :: Char -> Maybe Char
showEscapeChar Char
c =
  Char -> Map Char Char -> Maybe Char
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c ([(Char, Char)] -> Map Char Char
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char
x, Char
y) | (Char
y, Char
x) <- [(Char, Char)]
escapeChars])

typeModifiersAlt :: (Alternative f) => (Text -> f a) -> f a
typeModifiersAlt :: forall (f :: * -> *) a. Alternative f => (Text -> f a) -> f a
typeModifiersAlt Text -> f a
f =
  [f a] -> f a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([f a] -> f a) -> [f a] -> f a
forall a b. (a -> b) -> a -> b
$ (Text -> f a) -> [Text] -> [f a]
forall a b. (a -> b) -> [a] -> [b]
map Text -> f a
f (Set Text -> [Text]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Text
typeModifiers)

debugFilePreParse :: FilePath -> IO ()
debugFilePreParse :: String -> IO ()
debugFilePreParse String
file = String -> IO ()
putStrLn (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree (Token Lexeme) -> String
debugPreParse (BlockTree (Token Lexeme) -> String)
-> (Text -> BlockTree (Token Lexeme)) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token Lexeme] -> BlockTree (Token Lexeme)
preParse ([Token Lexeme] -> BlockTree (Token Lexeme))
-> (Text -> [Token Lexeme]) -> Text -> BlockTree (Token Lexeme)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [Token Lexeme]
lexer String
file (String -> [Token Lexeme])
-> (Text -> String) -> Text -> [Token Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> IO ()) -> IO Text -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Text
readUtf8 String
file

debugPreParse :: BlockTree (Token Lexeme) -> String
debugPreParse :: BlockTree (Token Lexeme) -> String
debugPreParse (Leaf (Token (Err (UnexpectedTokens String
msg)) Pos
start Pos
end)) =
  (if Pos
start Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
end then String
msg1 else String
msg2) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg
  where
    msg1 :: String
msg1 = String
"Error on line " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Line -> String
forall a. Show a => a -> String
show (Pos -> Line
line Pos
start) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", column " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Line -> String
forall a. Show a => a -> String
show (Pos -> Line
column Pos
start)
    msg2 :: String
msg2 =
      String
"Error on line "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Line -> String
forall a. Show a => a -> String
show (Pos -> Line
line Pos
start)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", column "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Line -> String
forall a. Show a => a -> String
show (Pos -> Line
column Pos
start)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" - line "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Line -> String
forall a. Show a => a -> String
show (Pos -> Line
line Pos
end)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", column "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Line -> String
forall a. Show a => a -> String
show (Pos -> Line
column Pos
end)
debugPreParse BlockTree (Token Lexeme)
ts = BlockTree Lexeme -> String
forall a. Show a => a -> String
show (BlockTree Lexeme -> String) -> BlockTree Lexeme -> String
forall a b. (a -> b) -> a -> b
$ Token Lexeme -> Lexeme
forall a. Token a -> a
payload (Token Lexeme -> Lexeme)
-> BlockTree (Token Lexeme) -> BlockTree Lexeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockTree (Token Lexeme)
ts

debugPreParse' :: String -> String
debugPreParse' :: ShowS
debugPreParse' = BlockTree (Token Lexeme) -> String
debugPreParse (BlockTree (Token Lexeme) -> String)
-> (String -> BlockTree (Token Lexeme)) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token Lexeme] -> BlockTree (Token Lexeme)
preParse ([Token Lexeme] -> BlockTree (Token Lexeme))
-> (String -> [Token Lexeme]) -> String -> BlockTree (Token Lexeme)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [Token Lexeme]
lexer String
"debugPreParse"

instance EP.ShowErrorComponent (Token Err) where
  showErrorComponent :: Token Err -> String
showErrorComponent (Token Err
err Pos
_ Pos
_) = Err -> String
go Err
err
    where
      go :: Err -> String
go = \case
        UnexpectedTokens String
msg -> String
msg
        CloseWithoutMatchingOpen String
open String
close -> String
"I found a closing " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
close String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but no matching " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
open String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."
        Both Err
e1 Err
e2 -> Err -> String
go Err
e1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Err -> String
go Err
e2
        Err
LayoutError -> String
"Indentation error"
        TextLiteralMissingClosingQuote String
s -> String
"This text literal missing a closing quote: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
excerpt String
s
        Err
e -> Err -> String
forall a. Show a => a -> String
show Err
e
      excerpt :: ShowS
excerpt String
s = if String -> Line
forall a. [a] -> Line
forall (t :: * -> *) a. Foldable t => t a -> Line
length String
s Line -> Line -> Bool
forall a. Ord a => a -> a -> Bool
< Line
15 then String
s else Line -> ShowS
forall a. Line -> [a] -> [a]
take Line
15 String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"..."

instance P.VisualStream [Token Lexeme] where
  showTokens :: Proxy [Token Lexeme] -> NonEmpty (Token [Token Lexeme]) -> String
showTokens Proxy [Token Lexeme]
_ NonEmpty (Token [Token Lexeme])
xs =
    [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([String] -> String)
-> (Token Lexeme -> [String]) -> Token Lexeme -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
Nel.toList (NonEmpty String -> [String])
-> (Token Lexeme -> NonEmpty String) -> Token Lexeme -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State Pos (NonEmpty String) -> Pos -> NonEmpty String
forall s a. State s a -> s -> a
S.evalState ((Token Lexeme -> StateT Pos Identity String)
-> NonEmpty (Token Lexeme) -> State Pos (NonEmpty String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse Token Lexeme -> StateT Pos Identity String
go NonEmpty (Token [Token Lexeme])
NonEmpty (Token Lexeme)
xs) (Pos -> NonEmpty String)
-> (Token Lexeme -> Pos) -> Token Lexeme -> NonEmpty String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token Lexeme -> Pos
forall a. Token a -> Pos
end (Token Lexeme -> String) -> Token Lexeme -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty (Token Lexeme) -> Token Lexeme
forall a. NonEmpty a -> a
Nel.head NonEmpty (Token [Token Lexeme])
NonEmpty (Token Lexeme)
xs
    where
      go :: Token Lexeme -> S.State Pos String
      go :: Token Lexeme -> StateT Pos Identity String
go Token Lexeme
tok = do
        Pos
prev <- StateT Pos Identity Pos
forall s (m :: * -> *). MonadState s m => m s
S.get
        Pos -> StateT Pos Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Pos -> StateT Pos Identity ()) -> Pos -> StateT Pos Identity ()
forall a b. (a -> b) -> a -> b
$ Token Lexeme -> Pos
forall a. Token a -> Pos
end Token Lexeme
tok
        pure $ Pos -> Pos -> String
pad Pos
prev (Token Lexeme -> Pos
forall a. Token a -> Pos
start Token Lexeme
tok) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Lexeme -> String
pretty (Token Lexeme -> Lexeme
forall a. Token a -> a
payload Token Lexeme
tok)
      pretty :: Lexeme -> String
pretty (Open String
s) = String
s
      pretty (Reserved String
w) = String
w
      pretty (Textual String
t) = Char
'"' Char -> ShowS
forall a. a -> [a] -> [a]
: String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'"']
      pretty (Character Char
c) =
        case Char -> Maybe Char
showEscapeChar Char
c of
          Just Char
c -> String
"?\\" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c]
          Maybe Char
Nothing -> Char
'?' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char
c]
      pretty (WordyId HashQualified Name
n) = Text -> String
Text.unpack (HashQualified Name -> Text
HQ'.toText HashQualified Name
n)
      pretty (SymbolyId HashQualified Name
n) = Text -> String
Text.unpack (HashQualified Name -> Text
HQ'.toText HashQualified Name
n)
      pretty (Numeric String
n) = String
n
      pretty (Hash ShortHash
sh) = ShortHash -> String
forall a. Show a => a -> String
show ShortHash
sh
      pretty (Err Err
e) = Err -> String
forall a. Show a => a -> String
show Err
e
      pretty (Bytes Bytes
bs) = String
"0xs" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bytes -> String
forall a. Show a => a -> String
show Bytes
bs
      pretty Lexeme
Close = String
"<outdent>"
      pretty (Semi Bool
True) = String
"<virtual semicolon>"
      pretty (Semi Bool
False) = String
";"
      pretty (Doc UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
d) = UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
-> String
forall a. Show a => a -> String
show UntitledSection
  (Tree (Token (ReferenceType, HashQualified Name)) [Token Lexeme])
d
      pad :: Pos -> Pos -> String
pad (Pos Line
line1 Line
col1) (Pos Line
line2 Line
col2) =
        if Line
line1 Line -> Line -> Bool
forall a. Eq a => a -> a -> Bool
== Line
line2
          then Line -> Char -> String
forall a. Line -> a -> [a]
replicate (Line
col2 Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
col1) Char
' '
          else Line -> Char -> String
forall a. Line -> a -> [a]
replicate (Line
line2 Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
line1) Char
'\n' String -> ShowS
forall a. [a] -> [a] -> [a]
++ Line -> Char -> String
forall a. Line -> a -> [a]
replicate Line
col2 Char
' '