Browse Source

created basic lexer

master
depsterr 6 months ago
parent
commit
622e696002
  1. 2
      .gitignore
  2. 1
      TODO
  3. 7
      app/Main.hs
  4. 4
      lib/MyLib.hs
  5. 2
      readme.txt
  6. 13
      sexprml.cabal
  7. 72
      src/Error.hs
  8. 128
      src/Lexer/Lexer.x
  9. 6
      src/Lexer/Misc.hs
  10. 90
      src/Types.hs

2
.gitignore vendored

@ -0,0 +1,2 @@
dist-newstyle
.*.swp

1
TODO

@ -0,0 +1 @@
floats?

7
app/Main.hs

@ -1,8 +1,7 @@
module Main where
import qualified MyLib (someFunc)
import System.Environment
import System.Exit
main :: IO ()
main = do
putStrLn "Hello, Haskell!"
MyLib.someFunc
main = exitSuccess

4
lib/MyLib.hs

@ -1,4 +0,0 @@
module MyLib (someFunc) where
someFunc :: IO ()
someFunc = putStrLn "someFunc"

2
readme.md → readme.txt

@ -1,4 +1,3 @@
```hs
{-
Haskell style comments with {- -} and --
-}
@ -162,4 +161,3 @@ ident
-- (λ b d (f a b c d e))
-- monad stuff? IO?
```

13
sexprml.cabal

@ -17,11 +17,16 @@ category: Programming Language
extra-source-files: CHANGELOG.md, readme.md
library
exposed-modules: MyLib
-- other-modules:
-- other-extensions:
ghc-options: -Werror=incomplete-patterns -Wall
exposed-modules: Lexer.Lexer, Lexer.Misc, Error, Types
build-tool-depends: alex:alex >= 3.0, happy:happy >= 1.19.5
build-depends: base ^>=4.14.1.0
hs-source-dirs: lib
, array
, containers
, transformers
, microlens
, microlens-th
hs-source-dirs: src
default-language: Haskell2010
executable sexprml

72
src/Error.hs

@ -0,0 +1,72 @@
module Error (errorMessage, warnMessage) where
import Types
-- todo ranges, refers
data Color = Red | Gray | Yellow | Default
deriving Show
decodeColor :: Color -> String
decodeColor Default = "\ESC[0m"
decodeColor Red = "\ESC[31m"
decodeColor Yellow = "\ESC[33m"
decodeColor Gray = "\ESC[90m"
color :: Color -> String -> String
color c s = decodeColor c <> s
colorR :: Color -> String -> String
colorR c s = color c s <> decodeColor Default
colorAt :: Int -> String -> String
colorAt _ [] = []
colorAt 1 (c:s) = colorR Red [c] <> s
colorAt n (c:s) = c : colorAt (n-1) s
colorRange :: (Int, Int) -> String -> String
colorRange _ [] = []
colorRange (_, 0) (c:s) = [c] <> color Default s
colorRange (n, m) (c:s) | n < 1 = color Red [c] <> colorRange (0, m-1) s
| otherwise = c : colorRange (n-1, m-1) s
placeMarker :: Int -> String -> String
placeMarker c s = colorRange (c-2, c) $ go 0 (padTo (c+1) s)
where
go _ [] = []
go n (t:ts) | abs (c - n - 1) < 2 = '^' : go (n+1) ts
| otherwise = t : go (n+1) ts
padTo :: Int -> String -> String
padTo i s = s <> replicate (i - length s) ' '
message :: String -> PN -> FilePath -> String -> String -> String
message m (PN _ l c) fileName fileText msg =
m <> fileName <> ":" <> show l <> ":" <> show c <> ": "
<> msg <> ".\n" <> eline
where
li = lines fileText
pl = l-1
nl = l+1
pls = show pl
ls = show l
nls = show nl
w = max (length pls) (max (length ls) (length nls))
eline = (if l >= 2
then padTo w pls <> " | " <> li !! (pl-1) <> "\n"
else "\n")
<> padTo w ls <> " | " <> colorAt c (li !! (l-1)) <> "\n"
<> padTo w nls <> " | " <>
(if l < length li
then placeMarker c (li !! (nl-1))
else placeMarker c "<EOF>")
errorMessage :: PN -> FilePath -> String -> String -> String
errorMessage = message (colorR Red "ERROR: ")
warnMessage :: PN -> FilePath -> String -> String -> String
warnMessage = message (colorR Yellow "WARN: ")

128
src/Lexer/Lexer.x

@ -0,0 +1,128 @@
{
{-# LANGUAGE LambdaCase #-}
module Lexer.Lexer
( runAlex'
, alexError'
, alexMonadScan'
, Alex(..)
, liftGetter
, liftSetter
) where
import Lens.Micro
import Lexer.Misc
import Types
import Error
import Prelude hiding (lex)
import Text.Read (readMaybe)
}
%wrapper "monadUserState"
$digit = [0-9]
$special = [\[\]\(\)\{\}:_∀λ⇒→]
$ident = $printable # $special # $white
@lambda = λ | "lambda"
@forall = ∀ | "forall"
@imparr = ⇒ | "=>"
@exparr = → | "->"
@escape = \\ $printable
@rawchar = $printable | @escape
@char = ' @rawchar '
@string = \" (@rawchar) * \"
@lambdacase = λcase | "lambdacase"
tokens :-
$white+ ;
"--".* ;
"{-" { lex LComment }
"-}" { lex RComment }
\( { lex LParen }
\) { lex RParen }
\[ { lex LBracket }
\] { lex RBracket }
\{ { lex LBrace }
\} { lex RBrace }
@lambda { lex Lambda }
@forall { lex Forall }
@imparr { lex ImpArr }
@exparr { lex ExpArr }
: { lex Colon }
_ { lex WildCard }
def { lex Def }
case { lex Case }
@lambdacase { lex LambdaCase }
record { lex Record }
instance { lex Instance }
def { lex Def }
$digit+ { lexInt }
@char { lexChar }
@string { lexString }
$ident+ { lexIdent }
{
liftGetter :: (AlexUserState -> a) -> Alex a
liftGetter f = f <$> alexGetUserState
liftSetter :: (AlexUserState -> AlexUserState) -> Alex ()
liftSetter f = alexSetUserState =<< f <$> alexGetUserState
toPN :: AlexPosn -> PN
toPN (AlexPn o l c) = PN o l c
alexEOF :: Alex Tk
alexEOF = alexGetInput >>= \(p,_,_,_) -> pure (Tk (toPN p) EOF)
lex' :: (String -> TkTp) -> AlexAction Tk
lex' f (p,_,_,s) i = pure $ Tk (toPN p) (f (take i s))
lex :: TkTp -> AlexAction Tk
lex = lex' . const
-- | Lex a number
lexInt :: AlexAction Tk
lexInt = lex' (Int . read)
-- | Extract Char from quotes, convert escape code to char.
lexChar :: AlexAction Tk
lexChar (p,_,_,s) i = let chr = take i s in case readMaybe chr of
Nothing -> alexError' p ("Unable to lex literal character " <> chr)
Just c -> pure $ Tk (toPN p) (Char c)
-- | Extract String from quotes.
lexString :: AlexAction Tk
lexString (p,_,_,s) i = let str = take i s in case readMaybe str of
Nothing -> alexError' p ("Unable to lex literal string " <> str)
Just s -> pure $ Tk (toPN p) (String s)
-- | Lex an identifier
lexIdent :: AlexAction Tk
lexIdent = lex' (Identifier . Id)
alexMonadScan' :: Alex Tk
alexMonadScan' = do
inp <- alexGetInput
sc <- alexGetStartCode
case alexScan inp sc of
AlexEOF -> alexEOF
AlexError (p,_,_,s) -> alexError' p ("lexing error at character '" <> (show (head s)) <> "'")
AlexSkip inp' _ -> alexSetInput inp' >> alexMonadScan'
AlexToken inp' len action -> alexSetInput inp' >> action (ignorePendingBytes inp) len
alexError' :: AlexPosn -> String -> Alex a
alexError' p msg = do
fp <- liftGetter (^. filePath)
tx <- liftGetter (^. fileText)
alexError $ errorMessage (toPN p) fp tx msg
runAlex' :: Alex a -> FilePath -> String -> Either String a
runAlex' a fp input = runAlex input (liftSetter ((filePath .~ fp) . (fileText .~ input)) >> a)
}

6
src/Lexer/Misc.hs

@ -0,0 +1,6 @@
module Lexer.Misc where
import Types
alexInitUserState :: AlexUserState
alexInitUserState = AlexUserState "" ""

90
src/Types.hs

@ -0,0 +1,90 @@
{-# LANGUAGE TemplateHaskell #-}
module Types where
import Lens.Micro.TH
-- | Represents text in an identifier
newtype Identifier = Id { unId :: String }
deriving Show
-- | An abslute offset in a file
type Offset = Int
-- | A line number
type LineNo = Int
-- | A char index into the specified line
type CharNo = Int
-- | A position in a file
data PN = PN Offset LineNo CharNo
deriving Show
-- | A range in a file, represented by a starting and ending position
type PNR = (PN, PN)
-- | A token, represented by the position where it was lexed as well as the type of token
data Tk = Tk PN TkTp
deriving Show
-- | A type of token, used to construct a Tk
data TkTp
= Lambda
| Forall
| Colon
| WildCard
| ImpArr
| ExpArr
| Char Char
| Int Int
| String String
| Identifier Identifier
| LComment -- ^ {-
| RComment
| LParen -- ^ (
| RParen
| LBracket -- ^ [
| RBracket
| LBrace -- ^ {
| RBrace
| Def
| Data
| Case
| LambdaCase
| Record
| Instance
| EOF
deriving Show
-- | Convent a TkTp into a string representing it
unlex :: TkTp -> String
unlex Lambda = "λ"
unlex Forall = ""
unlex Colon = ":"
unlex WildCard = "_"
unlex ImpArr = ""
unlex ExpArr = ""
unlex (Char c) = show c
unlex (String s) = show s
unlex (Identifier i) = unId i
unlex (Int i) = show i
unlex LComment = "{-"
unlex RComment = "-}"
unlex LParen = "("
unlex RParen = ")"
unlex LBracket = "["
unlex RBracket = "]"
unlex LBrace = "{"
unlex RBrace = "}"
unlex Def = "def"
unlex Data = "data"
unlex Case = "case"
unlex LambdaCase = "λcase"
unlex Record = "record"
unlex Instance = "instance"
unlex EOF = "<EOF>"
data AlexUserState = AlexUserState
{ _filePath :: FilePath
, _fileText :: String
} deriving Show
makeLenses ''AlexUserState
Loading…
Cancel
Save