|
|
- {-# LANGUAGE ViewPatterns #-}
- module Frontend.Parser.Foreign where
-
- import Control.Monad
-
- import qualified Data.Text as T
- import Data.List
-
-
- import Frontend.Lexer.Wrapper
- import Frontend.Lexer.Tokens
- import Frontend.Syntax
-
- import Text.Show.Pretty
- import Frontend.Parser.Posn
- import Data.Char (isAlpha)
- import Errors
-
- parseForeignItem :: Token -> Alex FfiImpEnt
- parseForeignItem token@(Token (TokString impent) line col) = go 0 impent emptyItem
- where
- pn = Posn line (col + 1)
-
- go off xs item
- | T.pack " " `T.isPrefixOf` xs =
- let (run, rest) = T.span (== ' ') xs
- in go (off + T.length run) rest item
-
- go off (T.span (/= ' ') -> (x, xs)) item
- | x == xs, T.null xs = pure item
- | x == T.pack "static" =
- if fiStatic item
- then tooManyStatics pn off
- else go (off + T.length x) xs item{fiStatic = True}
- | T.pack ".h" `T.isSuffixOf` x =
- case fiHeader item of
- Nothing -> go (off + T.length x) xs item{fiHeader = Just x}
- Just _ -> tooManyHeaders pn off (T.length x)
- | T.singleton '&' `T.isPrefixOf` x, T.length x == 1 =
- if fiIsRef item
- then tooManyReferences pn off
- else go (off + 1) xs item{fiIsRef = True}
- | T.singleton '&' `T.isPrefixOf` x, T.length x >= 2 =
- if fiIsRef item
- then tooManyReferences pn off
- else go (off + 1) (T.tail x <> xs) item{fiIsRef = True}
- | otherwise =
- case fiItemName item of
- Nothing -> do
- id <- parseCid pn off x
- go (off + T.length x) xs item{fiItemName = id}
- _ -> tooManyItemNames pn off (T.length x)
- parseForeignItem _ = undefined
-
- tooManyHeaders :: Posn -> Int -> Int -> Alex a
- tooManyHeaders (Posn l c) off len =
- alexThrow $ \fname ->
- emptyError
- { errorMessage = "this foreign entity has too many header names; only one is allowed."
- , errorFilename = fname
- , errorInlineDesc = Just "repeated header name"
- , errorBegin = Posn l (c + off)
- , errorEnd = Posn l (c + off + len)
- }
-
- tooManyItemNames :: Posn -> Int -> Int -> Alex a
- tooManyItemNames (Posn l c) off len =
- alexThrow $ \fname ->
- emptyError
- { errorMessage = "this foreign entity has too many names; only one is allowed."
- , errorFilename = fname
- , errorInlineDesc = Just "repeated name"
- , errorBegin = Posn l (c + off)
- , errorEnd = Posn l (c + off + len)
- }
-
- tooManyReferences :: Posn -> Int -> Alex a
- tooManyReferences (Posn l c) off =
- alexThrow $ \fname ->
- emptyError
- { errorMessage = "this foreign entity has too many '&'s; only one is allowed."
- , errorFilename = fname
- , errorInlineDesc = Just "repeated '&'"
- , errorBegin = Posn l (c + off)
- , errorEnd = Posn l (c + off + 1)
- }
-
- tooManyStatics :: Posn -> Int -> Alex a
- tooManyStatics (Posn l c) off =
- alexThrow $ \fname ->
- emptyError
- { errorMessage = "this foreign entity has too many 'static's; only one is allowed."
- , errorFilename = fname
- , errorInlineDesc = Just "repeated 'static'"
- , errorBegin = Posn l (c + off)
- , errorEnd = Posn l (c + off + length "static")
- }
-
- parseCid :: Posn -> Int -> T.Text -> Alex (Maybe T.Text)
- parseCid (Posn l c) off id
- | T.null id = pure $ Nothing
- | isValidCIdent id = pure $ Just id
- | otherwise =
- alexThrow $ \fname ->
- emptyError
- { errorMessage = "names for foreign entities must be valid C identifiers."
- , errorFilename = fname
- , errorInlineDesc = Just "this is not a C identifier"
- , errorBegin = Posn l (c + off)
- , errorEnd = Posn l (c + off + T.length id)
- }
-
- isValidCIdent :: T.Text -> Bool
- isValidCIdent = go . T.unpack where
- go :: String -> Bool
- go [] = False
- go (x:xs)
- | isAlpha x = go' xs
- | otherwise = False
-
- go' :: String -> Bool
- go' [] = True
- go' (x:xs)
- | 'a' <= x && x <= 'z' = go' xs
- | 'A' <= x && x <= 'Z' = go' xs
- | '0' <= x && x <= '9' = go' xs
- | x == '_' = go' xs
- | otherwise = False
-
- emptyItem :: FfiImpEnt
- emptyItem =
- ForeignItem { fiItemName = Nothing
- , fiHeader = Nothing
- , fiStatic = False
- , fiIsRef = False
- }
|