diff options
Diffstat (limited to 'source/Felix/Syntax/Pragma.hs')
| -rw-r--r-- | source/Felix/Syntax/Pragma.hs | 250 |
1 files changed, 250 insertions, 0 deletions
diff --git a/source/Felix/Syntax/Pragma.hs b/source/Felix/Syntax/Pragma.hs new file mode 100644 index 0000000..97d1482 --- /dev/null +++ b/source/Felix/Syntax/Pragma.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Felix.Syntax.Pragma + ( SourceMixfixLevel + , sourceMixfixLevelValue + , SyntaxPragma(..) + , SyntaxPragmaProblem(..) + , SyntaxPragmaError(..) + , renderSyntaxPragmaError + , extractSyntaxPragmas + ) where + +import Base + +import Felix.Report.Location +import Felix.Syntax.Abstract (Associativity(..)) + +import Control.DeepSeq (NFData) +import Control.Monad (unless, when) +import Data.Bifunctor (first) +import Data.Char (ord) +import Data.Text qualified as Text +import Data.Word (Word8) + + +newtype SourceMixfixLevel = SourceMixfixLevel Word8 + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +sourceMixfixLevelValue :: SourceMixfixLevel -> Word8 +sourceMixfixLevelValue (SourceMixfixLevel level) = + level + +data SyntaxPragma = LocatedFixityPragma + { syntaxPragmaLocation :: !Location + , syntaxPragmaAssociativity :: !Associativity + , syntaxPragmaLevel :: !SourceMixfixLevel + } deriving stock (Show, Eq) + +instance Locatable SyntaxPragma where + locate = syntaxPragmaLocation + +data SyntaxPragmaProblem + = SyntaxPragmaMissingSpaceAfterPrefix + | SyntaxPragmaMissingKeyword + | SyntaxPragmaUnknownKeyword !Text + | SyntaxPragmaMissingLevel + | SyntaxPragmaInvalidLevel + | SyntaxPragmaLevelOutOfRange + | SyntaxPragmaTrailingContent + | SyntaxPragmaLoneCarriageReturn + deriving stock (Show, Eq) + +data SyntaxPragmaError + = InvalidSyntaxPragma !Location !SyntaxPragmaProblem + | SyntaxPragmaLocationOutOfRange !FilePath !Int !Int + deriving stock (Show, Eq) + +renderSyntaxPragmaError :: SyntaxPragmaError -> Text +renderSyntaxPragmaError = \case + InvalidSyntaxPragma location problem -> + locationToText location + <> ": " + <> renderSyntaxPragmaProblem problem + SyntaxPragmaLocationOutOfRange file line column -> + Text.pack file + <> ": syntax pragma location is out of range at " + <> Text.pack (show line) + <> ":" + <> Text.pack (show column) + +renderSyntaxPragmaProblem :: SyntaxPragmaProblem -> Text +renderSyntaxPragmaProblem = \case + SyntaxPragmaMissingSpaceAfterPrefix -> + "expected horizontal space after %!" + SyntaxPragmaMissingKeyword -> + "missing syntax pragma keyword" + SyntaxPragmaUnknownKeyword keyword -> + "unknown syntax pragma keyword " <> Text.pack (show keyword) + SyntaxPragmaMissingLevel -> + "missing syntax pragma level" + SyntaxPragmaInvalidLevel -> + "syntax pragma level must use ASCII decimal digits" + SyntaxPragmaLevelOutOfRange -> + "syntax pragma level must be between 0 and 7" + SyntaxPragmaTrailingContent -> + "unexpected trailing syntax pragma content" + SyntaxPragmaLoneCarriageReturn -> + "a syntax pragma line must end with LF, CRLF, or end of file" + +extractSyntaxPragmas + :: FileId + -> FilePath + -> Text + -> Either SyntaxPragmaError [SyntaxPragma] +extractSyntaxPragmas fileId file = + go 1 + where + go lineNumber source + | Text.null source = + Right [] + | otherwise = do + let (rawLine, suffix) = + Text.break (== '\n') source + hasLineFeed = + not (Text.null suffix) + (line, lineEnding) = + if hasLineFeed && Text.isSuffixOf "\r" rawLine + then + (Text.dropEnd 1 rawLine, CrLf) + else if hasLineFeed + then + (rawLine, LineFeed) + else + (rawLine, EndOfFile) + remaining = + if hasLineFeed + then Text.drop 1 suffix + else "" + reserved = + Text.isPrefixOf "%!" + (Text.dropWhile isHorizontalSpace line) + pragma <- + if reserved + then Just <$> parsePragmaLine + fileId + file + lineNumber + lineEnding + line + else + Right Nothing + rest <- go (lineNumber + 1) remaining + pure (maybe rest (: rest) pragma) + +data LineEnding + = LineFeed + | CrLf + | EndOfFile + deriving stock (Show, Eq) + +parsePragmaLine + :: FileId + -> FilePath + -> Int + -> LineEnding + -> Text + -> Either SyntaxPragmaError SyntaxPragma +parsePragmaLine fileId file lineNumber lineEnding rawLine = do + let horizontalPrefix = + Text.takeWhile isHorizontalSpace rawLine + column = + Text.length horizontalPrefix + 1 + location <- + first + (const + (SyntaxPragmaLocationOutOfRange + file + lineNumber + column)) + (mkLocationChecked fileId lineNumber column) + let invalid + :: SyntaxPragmaProblem + -> Either SyntaxPragmaError a + invalid = + Left . InvalidSyntaxPragma location + afterPrefix = + Text.drop 2 + (Text.dropWhile isHorizontalSpace rawLine) + when + (lineEnding == EndOfFile + && Text.isSuffixOf "\r" rawLine) + (invalid SyntaxPragmaLoneCarriageReturn) + afterPrefixSpace <- + case Text.uncons afterPrefix of + Nothing -> + invalid SyntaxPragmaMissingKeyword + Just (char, _) + | not (isHorizontalSpace char) -> + invalid SyntaxPragmaMissingSpaceAfterPrefix + Just{} -> + Right (Text.dropWhile isHorizontalSpace afterPrefix) + when + (Text.null afterPrefixSpace) + (invalid SyntaxPragmaMissingKeyword) + let (keyword, afterKeyword) = + Text.break isHorizontalSpace afterPrefixSpace + associativity <- + case keyword of + "infixl" -> + Right LeftAssoc + "infixr" -> + Right RightAssoc + "infix" -> + Right NonAssoc + _ -> + invalid (SyntaxPragmaUnknownKeyword keyword) + afterKeywordSpace <- + case Text.uncons afterKeyword of + Nothing -> + invalid SyntaxPragmaMissingLevel + Just{} -> + Right (Text.dropWhile isHorizontalSpace afterKeyword) + when + (Text.null afterKeywordSpace) + (invalid SyntaxPragmaMissingLevel) + let (digits, trailing) = + Text.span isAsciiDigit afterKeywordSpace + when + (Text.null digits) + (invalid SyntaxPragmaInvalidLevel) + level <- + maybe + (invalid SyntaxPragmaLevelOutOfRange) + (Right . SourceMixfixLevel) + (sourceLevel digits) + unless + (Text.null (Text.dropWhile isHorizontalSpace trailing)) + (invalid SyntaxPragmaTrailingContent) + pure + LocatedFixityPragma + { syntaxPragmaLocation = location + , syntaxPragmaAssociativity = associativity + , syntaxPragmaLevel = level + } + +isHorizontalSpace :: Char -> Bool +isHorizontalSpace char = + char == ' ' || char == '\t' + +isAsciiDigit :: Char -> Bool +isAsciiDigit char = + '0' <= char && char <= '9' + +sourceLevel :: Text -> Maybe Word8 +sourceLevel = + Text.foldl' step (Just 0) + where + step Nothing _ = + Nothing + step (Just current) char = + let next = + current * 10 + + fromIntegral (ord char - ord '0') + in + if next <= 7 + then Just next + else Nothing |