From ec5f85f428bb4243d31bc131a8321ae0a4b79608 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 7 Feb 2024 19:11:04 -0700 Subject: [PATCH] remove old files --- src/Core/Lex.x.old | 315 ------------------------------------------- src/Core/Parse.y.old | 159 ---------------------- 2 files changed, 474 deletions(-) delete mode 100644 src/Core/Lex.x.old delete mode 100644 src/Core/Parse.y.old diff --git a/src/Core/Lex.x.old b/src/Core/Lex.x.old deleted file mode 100644 index 0aebd64..0000000 --- a/src/Core/Lex.x.old +++ /dev/null @@ -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 } - - -{ - $white { skip } - \n { skip } - () { topLevelOff `andBegin` 0 } -} - - -{ - \n { skip } - () { doBol `andBegin` 0 } -} - - -{ - $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) - -} diff --git a/src/Core/Parse.y.old b/src/Core/Parse.y.old deleted file mode 100644 index bacd40e..0000000 --- a/src/Core/Parse.y.old +++ /dev/null @@ -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) - -} -