Migrate to `Felix` namespaceHEADhotg

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