amelia
/
ahc
1
0
Fork 0
Code Issues 0 Pull Requests 0 Projects 0 Releases 0 Wiki Activity
Browse Source

Implement parsing for foreign import declarations

master
Amélia Liao 2 years ago
parent
2bd96f2137
commit
238511c99d
7 changed files with 278 additions and 28 deletions
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +1
    -0
      ahc.cabal
  2. +27
    -20
      src/Frontend/Autogen/Lexer.x
  3. +37
    -3
      src/Frontend/Autogen/Parser.y
  4. +36
    -3
      src/Frontend/Lexer/Tokens.hs
  5. +135
    -0
      src/Frontend/Parser/Foreign.hs
  6. +41
    -1
      src/Frontend/Syntax.hs
  7. +1
    -1
      src/Main.hs

+ 1
- 0
ahc.cabal View File

@ -30,6 +30,7 @@ executable ahc
Frontend.Lexer.Tokens, Frontend.Lexer.Tokens,
Frontend.Lexer.Wrapper, Frontend.Lexer.Wrapper,
Frontend.Parser.Posn, Frontend.Parser.Posn,
Frontend.Parser.Foreign,
Frontend.Syntax Frontend.Syntax
build-tool-depends: alex:alex >= 3.2.4 && < 4.0 build-tool-depends: alex:alex >= 3.2.4 && < 4.0


+ 27
- 20
src/Frontend/Autogen/Lexer.x View File

@ -35,12 +35,13 @@ tokens :-
$white_nol+ ; $white_nol+ ;
\t { \_ _ -> alexError "tab character in source code" } \t { \_ _ -> alexError "tab character in source code" }
<0,import_> "--" .* \n
<0,import_,foreign_> "--" .* \n
{ just $ pushStartCode newline } { just $ pushStartCode newline }
<0> \= { always TokEqual } <0> \= { always TokEqual }
<0> \` { always TokTick } <0> \` { always TokTick }
<0> \: \: { always TokDoubleColon } <0> \: \: { always TokDoubleColon }
<foreign_> \: \: { \i l -> popStartCode *> always TokDoubleColon i l }
<0> \\ { \i l -> setPendingLC *> yield' (const TokLambda) i l } <0> \\ { \i l -> setPendingLC *> yield' (const TokLambda) i l }
<0> "->" { always TokArrow } <0> "->" { always TokArrow }
@ -49,7 +50,7 @@ tokens :-
<0> \{ { always TokOBrace } <0> \{ { always TokOBrace }
<0> \[ { always TokOSquare } <0> \[ { always TokOSquare }
<0,import_> {
<0,import_,foreign_> {
\, { always TokComma } \, { always TokComma }
\( { always TokOParen } \( { always TokOParen }
\) { always TokCParen } \) { always TokCParen }
@ -60,9 +61,9 @@ tokens :-
<0> \;+ { always TokSemi } <0> \;+ { always TokSemi }
<0,import_> \n { just $ pushStartCode newline }
<0,import_,foreign_> \n { just $ pushStartCode newline }
<0> \" { startString }
<0,foreign_> \" { startString }
<string> { <string> {
\\ \" { stringAppend (T.singleton '"') } \\ \" { stringAppend (T.singleton '"') }
@ -107,17 +108,12 @@ tokens :-
() { startLayout } () { startLayout }
} }
<import_> {
\n { just $ pushStartCode newline }
"--" .* \n { just $ pushStartCode newline }
}
<empty_layout> () { emptyLayout } <empty_layout> () { emptyLayout }
<pending> () { emitPendingToken } <pending> () { emitPendingToken }
-- identifiers and keywords -- identifiers and keywords
<0,import_> {
<0,import_,foreign_> {
$lower [$alpha $digit \_ \']* { variableOrKeyword } $lower [$alpha $digit \_ \']* { variableOrKeyword }
$upper [$alpha $digit \_ \']* { yield (TokUnqual ConId) } $upper [$alpha $digit \_ \']* { yield (TokUnqual ConId) }
@ -300,7 +296,7 @@ offsideRule (Posn line col, _, _, _) _ = do
maybePopImportSC :: Alex () maybePopImportSC :: Alex ()
maybePopImportSC = do maybePopImportSC = do
startcode <- alexGetStartCode startcode <- alexGetStartCode
when (startcode == import_) popStartCode
when (startcode == import_ || startcode == foreign_) popStartCode
emptyLayout :: AlexInput -> Int64 -> Alex Token emptyLayout :: AlexInput -> Int64 -> Alex Token
emptyLayout (Posn line col, _, _, _) _ = do emptyLayout (Posn line col, _, _, _) _ = do
@ -402,18 +398,20 @@ finishVarKw l c text = do
-- set the "keyword" (now changed to an identifier) as pending, so -- set the "keyword" (now changed to an identifier) as pending, so
-- that it will be emitted by the next alexMonadScan. -- that it will be emitted by the next alexMonadScan.
"import" -> do "import" -> do
pushStartCode import_
when ((sc /= import_) && (sc /= foreign_)) $ pushStartCode import_
pure (Token TokImport l c) pure (Token TokImport l c)
"as"
| sc == import_, c > col -> pure (Token TokAs l c)
| sc == import_ -> offsideKeyword (TokUnqual VarId text) l c
| otherwise -> pure (Token (TokUnqual VarId text) l c)
"as" -> conditionalKeyword l c import_ (c > col) TokAs
"qualified" -> conditionalKeyword l c import_ (c > col) TokQualified
"qualified"
| sc == import_, c > col -> pure (Token TokQualified l c)
| sc == import_ -> offsideKeyword (TokUnqual VarId text) l c
| otherwise -> pure (Token (TokUnqual VarId text) l c)
"foreign" -> do
when (sc /= foreign_) $ pushStartCode foreign_
pure (Token TokForeign l c)
"export" -> conditionalKeyword l c foreign_ (c > col) TokForeign
"safe" -> conditionalKeyword l c foreign_ (c > col) TokSafe
"unsafe" -> conditionalKeyword l c foreign_ (c > col) TokUnsafe
"ccall" -> conditionalKeyword l c foreign_ (c > col) TokCCall
-- when starting a layout context for let expressions we make sure -- when starting a layout context for let expressions we make sure
-- that it is distinguishable from layout contexts started by -- that it is distinguishable from layout contexts started by
@ -456,6 +454,15 @@ finishVarKw l c text = do
[] -> error "empty keyword/identifier" [] -> error "empty keyword/identifier"
conditionalKeyword l c import_ cond kw = do
sc <- alexGetStartCode
case () of
() | sc == import_, cond -> pure (Token kw l c)
| sc == import_ -> offsideKeyword (TokUnqual VarId text) l c
| otherwise -> pure (Token (TokUnqual VarId text) l c)
where text = T.pack (show kw)
finishVar :: (IdClass -> T.Text -> TokenClass) -> (IdClass -> T.Text -> T.Text -> TokenClass) -> Int -> Int -> T.Text -> Alex Token finishVar :: (IdClass -> T.Text -> TokenClass) -> (IdClass -> T.Text -> T.Text -> TokenClass) -> Int -> Int -> T.Text -> Alex Token
finishVar tokunqual tokqual l c text finishVar tokunqual tokqual l c text
| T.null text = undefined | T.null text = undefined


+ 37
- 3
src/Frontend/Autogen/Parser.y View File

@ -5,11 +5,12 @@ module Frontend.Autogen.Parser where
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe import Data.Maybe
import Frontend.Parser.Foreign
import Frontend.Lexer.Wrapper import Frontend.Lexer.Wrapper
import Frontend.Autogen.Lexer
import Frontend.Lexer.Tokens import Frontend.Lexer.Tokens
import Frontend.Parser.Posn import Frontend.Parser.Posn
import Frontend.Syntax import Frontend.Syntax
import Frontend.Autogen.Lexer
import qualified Prelude import qualified Prelude
import Prelude hiding (span) import Prelude hiding (span)
@ -83,6 +84,12 @@ import Control.Monad
'import' { Token TokImport _ _ } 'import' { Token TokImport _ _ }
'as' { Token TokAs _ _ } 'as' { Token TokAs _ _ }
'qualified' { Token TokQualified _ _ } 'qualified' { Token TokQualified _ _ }
'foreign' { Token TokForeign _ _ }
'export' { Token TokExport _ _ }
'safe' { Token TokSafe _ _ }
'unsafe' { Token TokUnsafe _ _ }
'ccall' { Token TokCCall _ _ }
%% %%
@ -175,8 +182,9 @@ NSItem :: { NamespacedItem ParsedVar }
| 'module' CON { IEModule (getVar $2) } | 'module' CON { IEModule (getVar $2) }
ModItem :: { Item } ModItem :: { Item }
: Decl { ModDecl $1 (startPosn $1) (endPosn $1) }
| Import { ModImport $1 (startPosn $1) (endPosn $1) }
: Decl { ModDecl $1 (startPosn $1) (endPosn $1) }
| Import { ModImport $1 (startPosn $1) (endPosn $1) }
| 'foreign' FfiItem { ModFfi $2 (startPosn $1) (endPosn $2) }
Import :: { ModuleImport ParsedVar } Import :: { ModuleImport ParsedVar }
: 'import' modid ImportExportList : 'import' modid ImportExportList
@ -191,6 +199,32 @@ Import :: { ModuleImport ParsedVar }
| 'import' 'qualified' modid ImportExportList 'as' CON | 'import' 'qualified' modid ImportExportList 'as' CON
{ Import $3 (fst $4) True (Just (getVar $6)) (startPosn $1) (endPosn $6) } { Import $3 (fst $4) True (Just (getVar $6)) (startPosn $1) (endPosn $6) }
FfiItem :: { FfiItem ParsedVar }
: 'import' CallConv Safety Entity VAR '::' Type
-- 1 2 3 4 5 6 7
{% do { ffiDesc <- traverse parseForeignItem $4
; pure $ FfiImport
{ fiVarName = getVar $5
, fiType = $7
, fiCallConv = $2
, fiSafety = $3
, fiItem = ffiDesc
, fiBegin = startPosn $1
, fiEnd = endPosn $7 }
} }
Safety :: { Maybe FfiSafety }
: {-empty-} { Nothing }
| 'safe' { Just Safe }
| 'unsafe' { Just Unsafe }
CallConv :: { FfiCallConv }
: 'ccall' { CC_CCall }
Entity :: { Maybe Token }
: {-empty-} { Nothing }
| STRING { Just $1 }
Opt(p) Opt(p)
: { () } : { () }
| p { () } | p { () }


+ 36
- 3
src/Frontend/Lexer/Tokens.hs View File

@ -47,17 +47,23 @@ data TokenClass
| TokCase | TokCase
| TokOf | TokOf
| TokForeign
| TokExport
| TokSafe
| TokUnsafe
| TokCCall
| TokData | TokData
| TokSemi | TokSemi
deriving (Eq, Ord) deriving (Eq, Ord)
instance Show TokenClass where instance Show TokenClass where
show (TokUnqual _ id) = T.unpack id
show (TokUnqual _ id) = T.unpack id
show (TokQual _ ns id) = T.unpack ns ++ '.':T.unpack id show (TokQual _ ns id) = T.unpack ns ++ '.':T.unpack id
show (TokUnqualOp _ id) = T.unpack id
show (TokUnqualOp _ id) = T.unpack id
show (TokQualOp _ ns id) = T.unpack ns ++ '.':T.unpack id show (TokQualOp _ ns id) = T.unpack ns ++ '.':T.unpack id
show (TokString text) = show text
show (TokString text) = show text
show TokEof = "<EOF>" show TokEof = "<EOF>"
show TokLambda = "\\" show TokLambda = "\\"
@ -95,6 +101,33 @@ instance Show TokenClass where
show TokOf = "of" show TokOf = "of"
show TokData = "data" show TokData = "data"
show TokForeign = "foreign"
show TokExport = "export"
show TokSafe = "export"
show TokUnsafe = "export"
show TokCCall = "export"
isKeywordToken :: TokenClass -> Bool
isKeywordToken TokLet = True
isKeywordToken TokIn = True
isKeywordToken TokModule = True
isKeywordToken TokImport = True
isKeywordToken TokQualified = True
isKeywordToken TokAs = True
isKeywordToken TokWhere = True
isKeywordToken TokCase = True
isKeywordToken TokOf = True
isKeywordToken TokForeign = True
isKeywordToken TokExport = True
isKeywordToken TokSafe = True
isKeywordToken TokUnsafe = True
isKeywordToken TokCCall = True
isKeywordToken TokData = True
isKeywordToken _ = False
tokSize :: TokenClass -> Int tokSize :: TokenClass -> Int
tokSize = length . show tokSize = length . show


+ 135
- 0
src/Frontend/Parser/Foreign.hs View File

@ -0,0 +1,135 @@
{-# 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)
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 ->
ParseError
{ parseErrorMessage = "this foreign entity has too many header names; only one is allowed."
, parseErrorFilename = fname
, parseErrorInlineDesc = Just "repeated header name"
, parseErrorBegin = Posn l (c + off)
, parseErrorEnd = Posn l (c + off + len)
}
tooManyItemNames :: Posn -> Int -> Int -> Alex a
tooManyItemNames (Posn l c) off len =
alexThrow $ \fname ->
ParseError
{ parseErrorMessage = "this foreign entity has too many names; only one is allowed."
, parseErrorFilename = fname
, parseErrorInlineDesc = Just "repeated name"
, parseErrorBegin = Posn l (c + off)
, parseErrorEnd = Posn l (c + off + len)
}
tooManyReferences :: Posn -> Int -> Alex a
tooManyReferences (Posn l c) off =
alexThrow $ \fname ->
ParseError
{ parseErrorMessage = "this foreign entity has too many '&'s; only one is allowed."
, parseErrorFilename = fname
, parseErrorInlineDesc = Just "repeated '&'"
, parseErrorBegin = Posn l (c + off)
, parseErrorEnd = Posn l (c + off + 1)
}
tooManyStatics :: Posn -> Int -> Alex a
tooManyStatics (Posn l c) off =
alexThrow $ \fname ->
ParseError
{ parseErrorMessage = "this foreign entity has too many 'static's; only one is allowed."
, parseErrorFilename = fname
, parseErrorInlineDesc = Just "repeated 'static'"
, parseErrorBegin = Posn l (c + off)
, parseErrorEnd = 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 ->
ParseError
{ parseErrorMessage = "names for foreign entities must be valid C identifiers."
, parseErrorFilename = fname
, parseErrorInlineDesc = Just "this is not a C identifier"
, parseErrorBegin = Posn l (c + off)
, parseErrorEnd = 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
}

+ 41
- 1
src/Frontend/Syntax.hs View File

@ -135,6 +135,40 @@ data NamespacedItem var
data ModuleItem var data ModuleItem var
= ModDecl { itemDecl :: FeDecl var, itemBegin :: Posn, itemEnd :: Posn } = ModDecl { itemDecl :: FeDecl var, itemBegin :: Posn, itemEnd :: Posn }
| ModImport { itemImport :: ModuleImport var, itemBegin :: Posn, itemEnd :: Posn } | ModImport { itemImport :: ModuleImport var, itemBegin :: Posn, itemEnd :: Posn }
| ModFfi { itemForeign :: FfiItem var, itemBegin :: Posn, itemEnd :: Posn }
deriving (Eq, Show, Ord)
data FfiItem var
= FfiImport
{ fiVarName :: var
, fiType :: FeType var
, fiCallConv :: FfiCallConv
, fiSafety :: Maybe FfiSafety
, fiItem :: Maybe FfiImpEnt
, fiBegin :: Posn
, fiEnd :: Posn
}
| FfiExport
{ fiVarName :: var
, fiType :: FeType var
, fiCallConv :: FfiCallConv
, fiExpCid :: Maybe Text
, fiBegin :: Posn
, fiEnd :: Posn
}
deriving (Eq, Show, Ord)
data FfiCallConv = CC_CCall deriving (Eq, Show, Ord)
data FfiSafety = Safe | Unsafe deriving (Eq, Show, Ord)
data FfiImpEnt
= ForeignItem
{ fiItemName :: Maybe Text
, fiHeader :: Maybe Text
, fiStatic :: Bool
, fiIsRef :: Bool
}
| Dynamic
| Wrapper
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
data ParsedVar data ParsedVar
@ -185,4 +219,10 @@ instance HasPosn (ModuleItem var) where
startPosn = itemBegin startPosn = itemBegin
endPosn = itemEnd endPosn = itemEnd
span sp ep s = s { itemBegin = startPosn sp, itemEnd = endPosn ep }
span sp ep s = s { itemBegin = startPosn sp, itemEnd = endPosn ep }
instance HasPosn (FfiItem var) where
startPosn = fiBegin
endPosn = fiEnd
span sp ep s = s { fiBegin = startPosn sp, fiEnd = endPosn ep }

+ 1
- 1
src/Main.hs View File

@ -28,7 +28,7 @@ main :: IO ()
main = do main = do
args <- getArgs args <- getArgs
for_ args $ \str -> do for_ args $ \str -> do
Main.lex str pPrint parseMod =<< Lbs.readFile str
Main.lex str (\_ -> putStrLn $ str ++ " parsed!") parseMod =<< Lbs.readFile str
testParse :: String -> IO () testParse :: String -> IO ()
testParse s = Main.lex "<interactive>" pPrint parseMod (Lbs.fromStrict (T.encodeUtf8 (T.pack s))) testParse s = Main.lex "<interactive>" pPrint parseMod (Lbs.fromStrict (T.encodeUtf8 (T.pack s)))


Write Preview
Loading…
Cancel
Save