lex.icl

   1 implementation module lex
   2
   3 import Data.Either
   4 import Data.List
   5 import StdString
   6 import System.CommandLine
   7 import StdFile
   8 import StdMisc
   9 from StdFunc import id, const
  10 import Data.Maybe
  11 import Control.Applicative
  12 import Control.Monad
  13 import Control.Monad.State
  14 import Data.Functor
  15 from Data.Func import $
  16 from Text import class Text, instance Text String
  17 import qualified Text
  18
  19 lexer :: [Char] -> LexerOutput
  20 lexer _ = undef
  21
  22 instance toString LexerOutput where
  23         toString (Left l) = "Error: " +++ l
  24         toString (Right x) = 'Text'.concat (print 0 x)
  25         where
  26                 print :: Int [Token] -> [String]
  27                 print _ [] = []
  28                 print i [(IdentToken l):rest] = [toString l:print i rest]
  29                 print i [(NumberToken j):rest] = [toString j:print i rest]
  30                 print i [(CharToken c):rest] = ["'":toString c:"'":print i rest]
  31                 print i [VarToken:rest] = ["var":print i rest]
  32                 print i [VoidToken:rest] = ["Void":print i rest]
  33                 print i [ReturnToken:rest] = ["return":print i rest]
  34                 print i [IfToken:rest] = ["if":print i rest]
  35                 print i [ElseToken:rest] = ["else":print i rest]
  36                 print i [WhileToken:rest] = ["while":print i rest]
  37                 print i [TrueToken:rest] = ["True":print i rest]
  38                 print i [FalseToken:rest] = ["False":print i rest]
  39                 print i [BraceOpenToken:rest] = ["(":print i rest]
  40                 print i [BraceCloseToken:rest] = [")":print i rest]
  41                 print i [CBraceOpenToken:rest] = ["{\n":tab (i+1):print (i+1) rest]
  42                 print i [CBraceCloseToken:rest] = ["}\n":tab (i-1):print (i-1) rest]
  43                 print i [SquareOpenToken:rest] = ["[":print i rest]
  44                 print i [SquareCloseToken:rest] = ["]":print i rest]
  45                 print i [CommaToken:rest] = [", ":print i rest]
  46                 print i [ColonToken:rest] = [":":print i rest]
  47                 print i [SColonToken:rest] = [";\n":tab i:print i rest]
  48                 print i [DotToken:rest] = [".":print i rest]
  49                 print i [PlusToken:rest] = [" + ":print i rest]
  50                 print i [DashToken:rest] = [" - ":print i rest]
  51                 print i [StarToken:rest] = [" * ":print i rest]
  52                 print i [SlashToken:rest] = [" / ":print i rest]
  53                 print i [PercentToken:rest] = [" % ":print i rest]
  54                 print i [AssignmentToken:rest] = [" = ":print i rest]
  55                 print i [LesserToken:rest] = [" < ":print i rest]
  56                 print i [BiggerToken:rest] = [" > ":print i rest]
  57                 print i [ExclamationToken:rest] = ["!":print i rest]
  58                 print i [DoubleColonToken:rest] = [" :: ":print i rest]
  59                 print i [LesserEqToken:rest] = [" <= ":print i rest]
  60                 print i [GreaterEqToken:rest] = [" >= ":print i rest]
  61                 print i [EqualsToken:rest] = [" == ":print i rest]
  62                 print i [AmpersandsToken:rest] = [" && ":print i rest]
  63                 print i [PipesToken:rest] = [" || ":print i rest]
  64                 print i [ArrowToken:rest] = [" -> ":print i rest]
  65
  66 tab :: Int -> String
  67 tab 0 = ""
  68 tab i = "\t" +++ tab (i-1)
  69
  70 lex :: [Char] -> LexerOutput
  71 lex ['v':'a':'r':rest] = undef
  72 lex ['V':'o':'i':'d':rest] = undef
  73 lex ['r':'e':'t':'u':'r':'n':rest] = undef
  74 lex ['i':'f':rest] = undef
  75 lex ['e':'l':'s':'e':rest] = undef
  76 lex ['w':'h':'i':'l':'e':rest] = undef
  77 lex ['T':'r':'u':'e':rest] = undef
  78 lex ['F':'a':'l':'s':'e':rest] = undef
  79 lex [':':':':rest] = undef
  80 lex ['<':'=':rest] = undef
  81 lex ['>':'=':rest] = undef
  82 lex ['=':'=':rest] = undef
  83 lex ['&':'&':rest] = undef
  84 lex ['|':'|':rest] = undef
  85 lex ['-':'>':rest] = undef
  86 lex ['(':rest] = undef
  87 lex [')':rest] = undef
  88 lex ['{':rest] = undef
  89 lex ['{':rest] = undef
  90 lex ['[':rest] = undef
  91 lex [':rest]':rest] = undef
  92 lex [',':rest] = undef
  93 lex [':':rest] = undef
  94 lex [';':rest] = undef
  95 lex ['.':rest] = undef
  96 lex ['+':rest] = undef
  97 lex ['-':rest] = undef
  98 lex ['*':rest] = undef
  99 lex ['/':rest] = undef
 100 lex ['%':rest] = undef
 101 lex ['=':rest] = undef
 102 lex ['<':rest] = undef
 103 lex ['>':rest] = undef
 104 lex ['!':rest] = undef
 105 lex ['\'':'\\':x:'\'':rest] = case x of
 106         'a' = undef // (CharToken '\a')
 107         'b' = undef // (CharToken '\b')
 108         'f' = undef // (CharToken '\f')
 109         'n' = undef // (CharToken '\n')
 110         'r' = undef // (CharToken '\r')
 111         't' = undef // (CharToken '\t')
 112         'v' = undef // (CharToken '\v')
 113         _ = Left ("Illegal escape: \\" +++ toString x)
 114 lex ['\'':x:'\'':rest] = undef
 115 lex [x:xs]
 116 | isSpace x = lex xs
 117 | isDigit x = undef //Parse Int
 118 | isAlpha x = undef //Parse ident
 119 | otherwise = Left ("Unexpected character: " +++ toString x)
 120
 121 :: LexerOutput :== Either String [Token]
 122
 123 Start = toString sp
 124         where
 125                 sp :: LexerOutput
 126                 sp = Right [
 127                         WhileToken,
 128                         BraceOpenToken,
 129                         TrueToken,
 130                         BraceCloseToken,
 131                         CBraceOpenToken,
 132                         VarToken,
 133                         IdentToken ['x'],
 134                         AssignmentToken,
 135                         IdentToken ['x'],
 136                         PlusToken,
 137                         NumberToken 5,
 138                         SColonToken,
 139                         CBraceCloseToken]
 140
 141 //:: LexerOutput a :== Either String a
 142 //
 143 //
 144 //runParser :: (Parser a) [Char] -> (LexerOutput a, [Char])
 145 //runParser (Parser p) s = p s
 146 //
 147 //lexer :: [Char] -> LexerOutput [Token]
 148 //
 149 ////lexer functions
 150 //identT  = alpha >>= \a -> many (char '_' <|> alphaNum) >>= \as -> return $ IdentToken [a:as]
 151 //numberT = optional (char '-') >>= \sign -> (some digit) >>= \n -> case sign of
 152 //            Nothing -> return $ NumberToken $ 5  //fromString n
 153 //            _       -> return $ NumberToken $ -5 //(fromString n) * -1
 154 //charLT  = CharToken <$> (char '\'' *> item <* char '\'')
 155 //char2T  = item >>= \c1 -> case c1 of
 156 //            ':' = char ':' >>| return DoubleColonToken
 157 //            '<' = char '=' >>| return LesserEqToken
 158 //            '>' = char '=' >>| return GreaterEqToken
 159 //            '=' = char '=' >>| return EqualsToken
 160 //            '&' = char '&' >>| return AmpersandsToken
 161 //            '|' = char '|' >>| return PipesToken
 162 //            '-' = char '>' >>| return ArrowToken
 163 //            _   = zero
 164 //char1T  = item >>= \c1 -> findT c1 charTokenMap
 165 //varT    = string (fromString "var") >>| return VarToken
 166 //voidT   = string (fromString "Void") >>| return VoidToken
 167 //returnT = string (fromString "return") >>| return ReturnToken
 168 //ifT     = string (fromString "if") >>| return IfToken
 169 //elseT   = string (fromString "else") >>| return ElseToken
 170 //whileT  = string (fromString "while") >>| return WhileToken
 171 //trueT   = string (fromString "True") >>| return TrueToken
 172 //falseT  = string (fromString "False") >>| return FalseToken
 173 ////note, for the anyToken parser the order matters!
 174 //anyT    = char2T <|> char1T <|> varT <|> voidT <|> returnT <|> ifT <|> elseT <|> whileT <|>
 175 //          trueT <|> falseT <|> numberT <|> identT <|> charLT
 176 //
 177 //Start :: *World -> *World
 178 //Start w
 179 //# (args, w) = getCommandLine w // We lezen nu nog standaard van stdin
 180 //# (out, w) = stdio w
 181 //# (toparse, out) = readEntireFile out
 182 //# out = out <<< toString (lexer toparse)
 183 //# (b, w) = fclose out w
 184 //| not b = setReturnCode 1 w
 185 //= w
 186 //      where
 187 //              readEntireFile :: *File -> *([Char], *File)
 188 //              readEntireFile f
 189 //              # (b, c, f) = freadc f
 190 //              | not b = ([], f)
 191 //              # (cs, f) = readEntireFile f
 192 //              = ([c:cs], f)
 193 //
 194 //
 195 //
 196 //charTokenMap =  [('(', BraceOpenToken)
 197 //                ,(')', BraceCloseToken)
 198 //                ,('{', CBraceOpenToken)
 199 //                ,('}', CBraceCloseToken)
 200 //                ,('[', SquareOpenToken)
 201 //                ,(']', SquareCloseToken)
 202 //                ,(',', CommaToken)
 203 //                ,(':', ColonToken)
 204 //                ,(';', SColonToken)
 205 //                ,('.', DotToken)
 206 //                ,('+', PlusToken)
 207 //                ,('-', DashToken)
 208 //                ,('*', StarToken)
 209 //                ,('/', SlashToken)
 210 //                ,('%', PercentToken)
 211 //                ,('=', AssignmentToken)
 212 //                ,('<', LesserToken)
 213 //                ,('>', BiggerToken)
 214 //                ,('!', ExclamationToken)]
 215 //findT c []           = fail "Unrecognized character"
 216 //findT c [(k,v):xs]   = if (c==k) (return v) (findT c xs)
 217 //
 218 //
 219 //// Clean adaption of Yard, a parsec like parser combinator
 220 //:: Parser a = Parser ([Char] -> (LexerOutput a, [Char]))
 221 //
 222 //runParser :: (Parser a) [Char] -> (LexerOutput a, [Char])
 223 //runParser (Parser p) s = p s
 224 //
 225 //instance Functor Parser where
 226 //    fmap f s    = liftM f s
 227 //
 228 //instance Applicative Parser where
 229 //    pure a      = Parser $ \s -> (Right a, s)
 230 //    (<*>) sf s  = ap sf s
 231 //
 232 //instance Monad Parser where
 233 //    bind p f    = Parser $ \s -> let (out, rest) = runParser p s in case out of
 234 //                    Left e  = (Left e, rest)
 235 //                    Right t = runParser (f t) rest
 236 //
 237 ////gives us some, many and optional
 238 //instance Alternative Parser where
 239 //    empty       = zero
 240 //    (<|>) p1 p2 = Parser $ \s -> let (out, rest) = runParser p1 s in case out of
 241 //                    Left e  = runParser p2 s
 242 //                    Right t = (Right t, rest)
 243 //
 244 ////parser that fails with error
 245 //fail :: String -> Parser a
 246 //fail e = Parser $ \s -> (Left e, s)
 247 //
 248 ////parser that always fails
 249 //zero :: Parser a
 250 //zero = fail "Zero parser"
 251 //
 252 ////matches exactly one Char
 253 //item :: Parser Char
 254 //item = Parser $ \s -> case s of
 255 //        []      = (Left "Unexpected empty input", s)
 256 //        [x:xs]  = (Right x, xs)
 257 //
 258 ////matches any char which satisfies f
 259 //satisfy :: (Char -> Bool) -> Parser Char
 260 //satisfy f = item >>= (\r -> if (f r) (return r) zero)
 261 //
 262 ////tries a parser, if it fails returns a default value
 263 //optionalDef :: a (Parser a) -> Parser a
 264 //optionalDef def p = p <|> return def
 265 //
 266 ////matched given char
 267 //char :: Char -> Parser Char
 268 //char c = satisfy (\i -> c==i) //I hate that we can't do: satisfy (==c)
 269 //
 270 //alpha :: Parser Char
 271 //alpha = satisfy isAlpha
 272 //
 273 //digit :: Parser Char
 274 //digit = satisfy isDigit
 275 //
 276 //alphaNum :: Parser Char
 277 //alphaNum = alpha <|> digit
 278 //
 279 ////matches a given String
 280 //string :: [Char] -> Parser [Char]
 281 //string s = mapM_ char s >>| return s