remove old files
This commit is contained in:
crumbtoo
@@ -1,315 +0,0 @@
|
|||||||
{
|
|
||||||
-- TODO: layout semicolons are not inserted at EOf.
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
module Core.Lex
|
|
||||||
( lexCore
|
|
||||||
, lexCore'
|
|
||||||
, CoreToken(..)
|
|
||||||
, ParseError(..)
|
|
||||||
, Located(..)
|
|
||||||
, AlexPosn(..)
|
|
||||||
)
|
|
||||||
where
|
|
||||||
import Data.Char (chr)
|
|
||||||
import Debug.Trace
|
|
||||||
import Core.Syntax
|
|
||||||
import Compiler.RLPC
|
|
||||||
import Lens.Micro
|
|
||||||
import Lens.Micro.TH
|
|
||||||
}
|
|
||||||
|
|
||||||
%wrapper "monadUserState"
|
|
||||||
|
|
||||||
$whitechar = [ \t\n\r\f\v]
|
|
||||||
$special = [\(\)\,\;\[\]\{\}]
|
|
||||||
|
|
||||||
$digit = 0-9
|
|
||||||
|
|
||||||
$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
|
|
||||||
$unisymbol = [] -- TODO
|
|
||||||
$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
|
|
||||||
|
|
||||||
$large = [A-Z \xc0-\xd6 \xd8-\xde]
|
|
||||||
$small = [a-z \xdf-\xf6 \xf8-\xff \_]
|
|
||||||
$alpha = [$small $large]
|
|
||||||
|
|
||||||
$graphic = [$small $large $symbol $digit $special \:\"\']
|
|
||||||
|
|
||||||
$octit = 0-7
|
|
||||||
$hexit = [0-9 A-F a-f]
|
|
||||||
$namechar = [$alpha $digit \' \#]
|
|
||||||
$symchar = [$symbol \:]
|
|
||||||
$nl = [\n\r]
|
|
||||||
$white_no_nl = $white # $nl
|
|
||||||
|
|
||||||
@reservedid =
|
|
||||||
case|data|do|import|in|let|letrec|module|of|where
|
|
||||||
|
|
||||||
@reservedop =
|
|
||||||
"=" | \\ | "->"
|
|
||||||
|
|
||||||
@varname = $small $namechar*
|
|
||||||
@conname = $large $namechar*
|
|
||||||
@varsym = $symbol $symchar*
|
|
||||||
@consym = \: $symchar*
|
|
||||||
|
|
||||||
@decimal = $digit+
|
|
||||||
|
|
||||||
rlp :-
|
|
||||||
|
|
||||||
-- everywhere: skip whitespace
|
|
||||||
$white_no_nl+ { skip }
|
|
||||||
|
|
||||||
-- TODO: `--` could begin an operator
|
|
||||||
"--"[^$nl]* { skip }
|
|
||||||
"--"\-*[^$symbol].* { skip }
|
|
||||||
|
|
||||||
"{-" { nestedComment }
|
|
||||||
|
|
||||||
-- syntactic symbols
|
|
||||||
<0>
|
|
||||||
{
|
|
||||||
"(" { constTok TokenLParen }
|
|
||||||
")" { constTok TokenRParen }
|
|
||||||
"{" { lbrace }
|
|
||||||
"}" { rbrace }
|
|
||||||
";" { constTok TokenSemicolon }
|
|
||||||
"," { constTok TokenComma }
|
|
||||||
}
|
|
||||||
|
|
||||||
-- keywords
|
|
||||||
-- see commentary on the layout system
|
|
||||||
<0>
|
|
||||||
{
|
|
||||||
"let" { constTok TokenLet `andBegin` layout }
|
|
||||||
"letrec" { constTok TokenLetrec `andBegin` layout }
|
|
||||||
"of" { constTok TokenOf `andBegin` layout }
|
|
||||||
"case" { constTok TokenCase }
|
|
||||||
"module" { constTok TokenModule }
|
|
||||||
"in" { letin }
|
|
||||||
"where" { constTok TokenWhere `andBegin` layout }
|
|
||||||
}
|
|
||||||
|
|
||||||
-- reserved symbols
|
|
||||||
<0>
|
|
||||||
{
|
|
||||||
"=" { constTok TokenEquals }
|
|
||||||
"->" { constTok TokenArrow }
|
|
||||||
}
|
|
||||||
|
|
||||||
-- identifiers
|
|
||||||
<0>
|
|
||||||
{
|
|
||||||
-- TODO: qualified names
|
|
||||||
@varname { lexWith TokenVarName }
|
|
||||||
@conname { lexWith TokenConName }
|
|
||||||
@varsym { lexWith TokenVarSym }
|
|
||||||
}
|
|
||||||
|
|
||||||
-- literals
|
|
||||||
<0>
|
|
||||||
{
|
|
||||||
@decimal { lexWith (TokenLitInt . read @Int) }
|
|
||||||
}
|
|
||||||
|
|
||||||
<0> \n { begin bol }
|
|
||||||
|
|
||||||
<initial>
|
|
||||||
{
|
|
||||||
$white { skip }
|
|
||||||
\n { skip }
|
|
||||||
() { topLevelOff `andBegin` 0 }
|
|
||||||
}
|
|
||||||
|
|
||||||
<bol>
|
|
||||||
{
|
|
||||||
\n { skip }
|
|
||||||
() { doBol `andBegin` 0 }
|
|
||||||
}
|
|
||||||
|
|
||||||
<layout>
|
|
||||||
{
|
|
||||||
$white { skip }
|
|
||||||
\{ { lbrace `andBegin` 0 }
|
|
||||||
() { noBrace `andBegin` 0 }
|
|
||||||
}
|
|
||||||
|
|
||||||
{
|
|
||||||
data Located a = Located Int Int Int a
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
constTok :: t -> AlexInput -> Int -> Alex (Located t)
|
|
||||||
constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t
|
|
||||||
|
|
||||||
data CoreToken = TokenLet
|
|
||||||
| TokenLetrec
|
|
||||||
| TokenIn
|
|
||||||
| TokenModule
|
|
||||||
| TokenWhere
|
|
||||||
| TokenComma
|
|
||||||
| TokenCase
|
|
||||||
| TokenOf
|
|
||||||
| TokenLambda
|
|
||||||
| TokenArrow
|
|
||||||
| TokenLitInt Int
|
|
||||||
| TokenVarName Name
|
|
||||||
| TokenConName Name
|
|
||||||
| TokenVarSym Name
|
|
||||||
| TokenConSym Name
|
|
||||||
| TokenEquals
|
|
||||||
| TokenLParen
|
|
||||||
| TokenRParen
|
|
||||||
| TokenLBrace
|
|
||||||
| TokenRBrace
|
|
||||||
| TokenLBraceV -- virtual brace inserted by layout
|
|
||||||
| TokenRBraceV -- virtual brace inserted by layout
|
|
||||||
| TokenIndent Int
|
|
||||||
| TokenDedent Int
|
|
||||||
| TokenSemicolon
|
|
||||||
| TokenEOF
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
data LayoutContext = Layout Int
|
|
||||||
| NoLayout
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
data AlexUserState = AlexUserState
|
|
||||||
{ _ausContext :: [LayoutContext]
|
|
||||||
}
|
|
||||||
|
|
||||||
ausContext :: Lens' AlexUserState [LayoutContext]
|
|
||||||
ausContext f (AlexUserState ctx)
|
|
||||||
= fmap
|
|
||||||
(\a -> AlexUserState a) (f ctx)
|
|
||||||
{-# INLINE ausContext #-}
|
|
||||||
|
|
||||||
pushContext :: LayoutContext -> Alex ()
|
|
||||||
pushContext c = do
|
|
||||||
st <- alexGetUserState
|
|
||||||
alexSetUserState $ st { _ausContext = c : _ausContext st }
|
|
||||||
|
|
||||||
popContext :: Alex ()
|
|
||||||
popContext = do
|
|
||||||
st <- alexGetUserState
|
|
||||||
alexSetUserState $ st { _ausContext = drop 1 (_ausContext st) }
|
|
||||||
|
|
||||||
getContext :: Alex [LayoutContext]
|
|
||||||
getContext = do
|
|
||||||
st <- alexGetUserState
|
|
||||||
pure $ _ausContext st
|
|
||||||
|
|
||||||
type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
|
|
||||||
|
|
||||||
alexInitUserState :: AlexUserState
|
|
||||||
alexInitUserState = AlexUserState []
|
|
||||||
|
|
||||||
nestedComment :: Lexer
|
|
||||||
nestedComment _ _ = undefined
|
|
||||||
|
|
||||||
lexStream :: Alex [Located CoreToken]
|
|
||||||
lexStream = do
|
|
||||||
l <- alexMonadScan
|
|
||||||
case l of
|
|
||||||
Located _ _ _ TokenEOF -> pure [l]
|
|
||||||
_ -> (l:) <$> lexStream
|
|
||||||
|
|
||||||
-- | The main lexer driver.
|
|
||||||
lexCore :: String -> RLPC ParseError [Located CoreToken]
|
|
||||||
lexCore s = case m of
|
|
||||||
Left e -> addFatal err
|
|
||||||
where err = SrcError
|
|
||||||
{ _errSpan = (0,0,0) -- TODO: location
|
|
||||||
, _errSeverity = Error
|
|
||||||
, _errDiagnostic = ParErrLexical e
|
|
||||||
}
|
|
||||||
Right ts -> pure ts
|
|
||||||
where
|
|
||||||
m = runAlex s (alexSetStartCode initial *> lexStream)
|
|
||||||
|
|
||||||
-- | @lexCore@, but the tokens are stripped of location info. Useful for
|
|
||||||
-- debugging
|
|
||||||
lexCore' :: String -> RLPC ParseError [CoreToken]
|
|
||||||
lexCore' s = fmap f <$> lexCore s
|
|
||||||
where f (Located _ _ _ t) = t
|
|
||||||
|
|
||||||
data ParseError = ParErrLexical String
|
|
||||||
| ParErrParse
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
lexWith :: (String -> CoreToken) -> Lexer
|
|
||||||
lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ take l s)
|
|
||||||
|
|
||||||
lexToken :: Alex (Located CoreToken)
|
|
||||||
lexToken = alexMonadScan
|
|
||||||
|
|
||||||
getSrcCol :: Alex Int
|
|
||||||
getSrcCol = Alex $ \ st ->
|
|
||||||
let AlexPn _ _ col = alex_pos st
|
|
||||||
in Right (st, col)
|
|
||||||
|
|
||||||
lbrace :: Lexer
|
|
||||||
lbrace (AlexPn _ y x,_,_,_) l = do
|
|
||||||
pushContext NoLayout
|
|
||||||
pure $ Located y x l TokenLBrace
|
|
||||||
|
|
||||||
rbrace :: Lexer
|
|
||||||
rbrace (AlexPn _ y x,_,_,_) l = do
|
|
||||||
popContext
|
|
||||||
pure $ Located y x l TokenRBrace
|
|
||||||
|
|
||||||
insRBraceV :: AlexPosn -> Alex (Located CoreToken)
|
|
||||||
insRBraceV (AlexPn _ y x) = do
|
|
||||||
popContext
|
|
||||||
pure $ Located y x 0 TokenRBraceV
|
|
||||||
|
|
||||||
insSemi :: AlexPosn -> Alex (Located CoreToken)
|
|
||||||
insSemi (AlexPn _ y x) = do
|
|
||||||
pure $ Located y x 0 TokenSemicolon
|
|
||||||
|
|
||||||
modifyUst :: (AlexUserState -> AlexUserState) -> Alex ()
|
|
||||||
modifyUst f = do
|
|
||||||
st <- alexGetUserState
|
|
||||||
alexSetUserState $ f st
|
|
||||||
|
|
||||||
getUst :: Alex AlexUserState
|
|
||||||
getUst = alexGetUserState
|
|
||||||
|
|
||||||
newLayoutContext :: Lexer
|
|
||||||
newLayoutContext (p,_,_,_) _ = do
|
|
||||||
undefined
|
|
||||||
|
|
||||||
noBrace :: Lexer
|
|
||||||
noBrace (AlexPn _ y x,_,_,_) l = do
|
|
||||||
col <- getSrcCol
|
|
||||||
pushContext (Layout col)
|
|
||||||
pure $ Located y x l TokenLBraceV
|
|
||||||
|
|
||||||
getOffside :: Alex Ordering
|
|
||||||
getOffside = do
|
|
||||||
ctx <- getContext
|
|
||||||
m <- getSrcCol
|
|
||||||
case ctx of
|
|
||||||
Layout n : _ -> pure $ m `compare` n
|
|
||||||
_ -> pure GT
|
|
||||||
|
|
||||||
doBol :: Lexer
|
|
||||||
doBol (p,c,_,s) _ = do
|
|
||||||
off <- getOffside
|
|
||||||
case off of
|
|
||||||
LT -> insRBraceV p
|
|
||||||
EQ -> insSemi p
|
|
||||||
_ -> lexToken
|
|
||||||
|
|
||||||
letin :: Lexer
|
|
||||||
letin (AlexPn _ y x,_,_,_) l = do
|
|
||||||
popContext
|
|
||||||
pure $ Located y x l TokenIn
|
|
||||||
|
|
||||||
topLevelOff :: Lexer
|
|
||||||
topLevelOff = noBrace
|
|
||||||
|
|
||||||
alexEOF :: Alex (Located CoreToken)
|
|
||||||
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
|
|
||||||
Right (st, Located y x 0 TokenEOF)
|
|
||||||
|
|
||||||
}
|
|
||||||
@@ -1,159 +0,0 @@
|
|||||||
{
|
|
||||||
module Core.Parse
|
|
||||||
( parseCore
|
|
||||||
, parseCoreExpr
|
|
||||||
, parseCoreProg
|
|
||||||
, module Core.Lex -- temp convenience
|
|
||||||
, parseTmp
|
|
||||||
, SrcError
|
|
||||||
, ParseError
|
|
||||||
, Module
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Control.Monad ((>=>))
|
|
||||||
import Data.Foldable (foldl')
|
|
||||||
import Core.Syntax
|
|
||||||
import Core.Lex
|
|
||||||
import Compiler.RLPC
|
|
||||||
import Data.Default.Class (def)
|
|
||||||
}
|
|
||||||
|
|
||||||
%name parseCore Module
|
|
||||||
%name parseCoreExpr StandaloneExpr
|
|
||||||
%name parseCoreProg StandaloneProgram
|
|
||||||
%tokentype { Located CoreToken }
|
|
||||||
%error { parseError }
|
|
||||||
%monad { RLPC ParseError }
|
|
||||||
|
|
||||||
%token
|
|
||||||
let { Located _ _ _ TokenLet }
|
|
||||||
letrec { Located _ _ _ TokenLetrec }
|
|
||||||
module { Located _ _ _ TokenModule }
|
|
||||||
where { Located _ _ _ TokenWhere }
|
|
||||||
',' { Located _ _ _ TokenComma }
|
|
||||||
in { Located _ _ _ TokenIn }
|
|
||||||
litint { Located _ _ _ (TokenLitInt $$) }
|
|
||||||
varname { Located _ _ _ (TokenVarName $$) }
|
|
||||||
varsym { Located _ _ _ (TokenVarSym $$) }
|
|
||||||
conname { Located _ _ _ (TokenConName $$) }
|
|
||||||
consym { Located _ _ _ (TokenConSym $$) }
|
|
||||||
'λ' { Located _ _ _ TokenLambda }
|
|
||||||
'->' { Located _ _ _ TokenArrow }
|
|
||||||
'=' { Located _ _ _ TokenEquals }
|
|
||||||
'(' { Located _ _ _ TokenLParen }
|
|
||||||
')' { Located _ _ _ TokenRParen }
|
|
||||||
'{' { Located _ _ _ TokenLBrace }
|
|
||||||
'}' { Located _ _ _ TokenRBrace }
|
|
||||||
vl { Located _ _ _ TokenLBraceV }
|
|
||||||
vr { Located _ _ _ TokenRBraceV }
|
|
||||||
';' { Located _ _ _ TokenSemicolon }
|
|
||||||
eof { Located _ _ _ TokenEOF }
|
|
||||||
|
|
||||||
%%
|
|
||||||
|
|
||||||
Module :: { Module }
|
|
||||||
Module : module conname where Program Eof { Module (Just ($2, [])) $4 }
|
|
||||||
| Program Eof { Module Nothing $1 }
|
|
||||||
|
|
||||||
Eof :: { () }
|
|
||||||
Eof : eof { () }
|
|
||||||
| error { () }
|
|
||||||
|
|
||||||
StandaloneProgram :: { Program }
|
|
||||||
StandaloneProgram : Program eof { $1 }
|
|
||||||
|
|
||||||
Program :: { Program }
|
|
||||||
Program : VOpen ScDefs VClose { Program $2 }
|
|
||||||
| '{' ScDefs '}' { Program $2 }
|
|
||||||
|
|
||||||
VOpen :: { () }
|
|
||||||
VOpen : vl { () }
|
|
||||||
|
|
||||||
VClose :: { () }
|
|
||||||
VClose : vr { () }
|
|
||||||
| error { () }
|
|
||||||
|
|
||||||
ScDefs :: { [ScDef] }
|
|
||||||
ScDefs : ScDef ';' ScDefs { $1 : $3 }
|
|
||||||
| {- epsilon -} { [] }
|
|
||||||
|
|
||||||
ScDef :: { ScDef }
|
|
||||||
ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 }
|
|
||||||
|
|
||||||
ParList :: { [Name] }
|
|
||||||
ParList : Var ParList { $1 : $2 }
|
|
||||||
| {- epsilon -} { [] }
|
|
||||||
|
|
||||||
StandaloneExpr :: { Expr }
|
|
||||||
StandaloneExpr : Expr eof { $1 }
|
|
||||||
|
|
||||||
Expr :: { Expr }
|
|
||||||
Expr : LetExpr { $1 }
|
|
||||||
| 'λ' Binders '->' Expr { Lam $2 $4 }
|
|
||||||
| Application { $1 }
|
|
||||||
| Expr1 { $1 }
|
|
||||||
|
|
||||||
LetExpr :: { Expr }
|
|
||||||
LetExpr : let VOpen Bindings VClose in Expr { Let NonRec $3 $6 }
|
|
||||||
| letrec VOpen Bindings VClose in Expr { Let Rec $3 $6 }
|
|
||||||
| let '{' Bindings '}' in Expr { Let NonRec $3 $6 }
|
|
||||||
| letrec '{' Bindings '}' in Expr { Let Rec $3 $6 }
|
|
||||||
|
|
||||||
Binders :: { [Name] }
|
|
||||||
Binders : Var Binders { $1 : $2 }
|
|
||||||
| Var { [$1] }
|
|
||||||
|
|
||||||
Application :: { Expr }
|
|
||||||
Application : Expr1 AppArgs { foldl' App $1 $2 }
|
|
||||||
|
|
||||||
-- TODO: Application can probably be written as a single rule, without AppArgs
|
|
||||||
AppArgs :: { [Expr] }
|
|
||||||
AppArgs : Expr1 AppArgs { $1 : $2 }
|
|
||||||
| Expr1 { [$1] }
|
|
||||||
|
|
||||||
Expr1 :: { Expr }
|
|
||||||
Expr1 : litint { IntE $1 }
|
|
||||||
| Id { Var $1 }
|
|
||||||
| '(' Expr ')' { $2 }
|
|
||||||
|
|
||||||
Bindings :: { [Binding] }
|
|
||||||
Bindings : Binding ';' Bindings { $1 : $3 }
|
|
||||||
| Binding ';' { [$1] }
|
|
||||||
| Binding { [$1] }
|
|
||||||
|
|
||||||
Binding :: { Binding }
|
|
||||||
Binding : Var '=' Expr { $1 := $3 }
|
|
||||||
|
|
||||||
Id :: { Name }
|
|
||||||
Id : Var { $1 }
|
|
||||||
| Con { $1 }
|
|
||||||
|
|
||||||
Var :: { Name }
|
|
||||||
Var : '(' varsym ')' { $2 }
|
|
||||||
| varname { $1 }
|
|
||||||
|
|
||||||
Con :: { Name }
|
|
||||||
Con : '(' consym ')' { $2 }
|
|
||||||
| conname { $1 }
|
|
||||||
|
|
||||||
{
|
|
||||||
parseError :: [Located CoreToken] -> RLPC ParseError a
|
|
||||||
parseError (Located y x l _ : _) = addFatal err
|
|
||||||
where err = SrcError
|
|
||||||
{ _errSpan = (y,x,l)
|
|
||||||
, _errSeverity = Error
|
|
||||||
, _errDiagnostic = ParErrParse
|
|
||||||
}
|
|
||||||
|
|
||||||
parseTmp :: IO Module
|
|
||||||
parseTmp = do
|
|
||||||
s <- readFile "/tmp/t.hs"
|
|
||||||
case parse s of
|
|
||||||
Left e -> error (show e)
|
|
||||||
Right (ts,_) -> pure ts
|
|
||||||
where
|
|
||||||
parse = evalRLPC def . (lexCore >=> parseCore)
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
Reference in New Issue
Block a user