cool

src/Rlp/Lex.x

@@ -1,5 +1,5 @@
 {
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns, LambdaCase #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Rlp.Lex
@@ -39,10 +39,20 @@ $nl             = [\n\r]
 $white_no_nl    = $white # $nl
 
 $namechar       = [$alpha $digit \' \#]
+$reservedsym    = [\(\)\,\;\[\]\`\{\}]
+$asciisym       = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
+$namesym        = $asciisym # \;
 
-@varname        = $lower $namechar*
+@reservedop =
+    "=" | \\ | "->" | "::" | "|"
 
-@digits         = $digit+
+@varname   = $lower $namechar*
+@conname   = $upper $namechar*
+@varsym    = $namesym+
+@consym    = \: $namesym*
+
+
+@decimal   = $digit+
 
 rlp :-
     
@@ -55,8 +65,8 @@ rlp :-
 {
     \n                  { beginPush bol }
     @varname            { tokenWith TokenVarName }
-    @digits             { tokenWith (TokenLitInt . readInt) }
+    @decimal            { tokenWith (TokenLitInt . readInt) }
-    "="                 { constToken TokenEquals }
+    @reservedop         { tokenWith readReservedOp }
 }
 
 -- control characters
@@ -86,6 +96,14 @@ rlp :-
 
 {
 
+readReservedOp :: Text -> RlpToken
+readReservedOp = \case
+    "="     -> TokenEquals
+    "\\"    -> TokenLambda
+    "->"    -> TokenArrow
+    "::"    -> TokenHasType
+    s       -> error (show s)
+
 -- | @andBegin@, with the subtle difference that the start code is set
 --   /after/ the action
 thenBegin :: LexerAction a -> Int -> LexerAction a
@@ -127,6 +145,12 @@ alexGetByte inp = case inp ^. aiBytes of
 getInput :: P AlexInput
 getInput = use psInput
 
+takeInput :: Int -> AlexInput -> Text
+takeInput n inp = T.cons c cs
+    where
+        c = inp ^. aiPrevChar
+        cs = T.take (max 0 (n-1)) $ inp ^. aiSource
+
 getLexState :: P Int
 getLexState = use (psLexState . singular _head)
 
@@ -148,8 +172,8 @@ constToken t inp l = do
 tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
 tokenWith tf inp l = do
     pos <- getPos
-    let t = tf (T.take l $ inp ^. aiSource)
+    let t = takeInput l inp
-    pure (Located (pos,l) t)
+    pure (Located (pos,l) (tf t))
 
 getPos :: P Position
 getPos = use (psInput . aiPos)
@@ -176,10 +200,10 @@ initParseState s = ParseState
     }
 
 initAlexInput :: Text -> AlexInput
-initAlexInput s = AlexInput
+initAlexInput t = AlexInput
-    { _aiPrevChar   = '\0'
+    { _aiPrevChar   = c
     , _aiSource     = s
-    , _aiBytes      = []
+    , _aiBytes      = b
     , _aiPos        = (1,1)
     }
 

src/Rlp/Parse/Types.hs

@@ -44,11 +44,15 @@ data RlpToken
     | TokenConSym Name
     -- keywords
     | TokenData
-    | TokenPipe
     | TokenLet
     | TokenIn
-    -- control symbols
+    -- reserved ops
+    | TokenArrow
+    | TokenPipe
+    | TokenHasType
+    | TokenLambda
     | TokenEquals
+    -- control symbols
     | TokenSemicolon
     | TokenLBrace
     | TokenRBrace