created basic lexer

.gitignore

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

TODO

@@ -0,0 +1 @@
+floats?

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

lib/MyLib.hs

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

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?
-```

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

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: ")

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)
+
+}

src/Lexer/Misc.hs

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

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