You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
136 lines
4.2 KiB
136 lines
4.2 KiB
{-# 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
|
|
}
|