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