gistfile1.txt

#lang racket

(require parser-tools/lex)
(require parser-tools/yacc)
(require (prefix-in : parser-tools/lex-sre))

(provide parse-program current-source-name)

(define current-source-name (make-parameter #f))

(define (make-boolean lexeme) (string=? lexeme "true"))

(define key->keyword string->keyword)

(define (key->string k) k)


(define-tokens cap-tokens (NUMBER STRING ID BOOLEAN KEY))

(define-tokens
  cap-privileges 
  (PATH EXEC STAT READSYMLINK EXECFILES READFILES WRITEFILES APPENDFILES 
   LINK CONTENT CREATEDIR CREATEFILE ADD ADDLINK ADDSYMLINK 
   UNLINKFILE UNLINKDIR READLINK RENAME LOOKUP READ WRITE APPEND))

(define-tokens cap-keys (STDIN STDOUT STDERR ARGS CAPS))

(define-empty-tokens 
  cap-punct 
  (EOF PAIR COMMA OPAR CPAR THEN ELSE OBRAC CBRAC OCBRAC CCBRAC IN 
       EQ REQ SEQ FUN FOR DO IF PROV VAR VAL CTC ARROW WITH ASSIGN AND ONLY
       DIR FILE AS))

(define-lex-abbrev cap-id 
  (:+ (union alphabetic numeric "-" "_" "+" "/" "!" "?" "=" ">" "<" "*")))

(define get-string-token
  (lexer
   [(:~ #\" #\\) (cons (car (string->list lexeme))
                       (get-string-token input-port))]
   [(:: #\\ #\\) (cons #\\ (get-string-token input-port))]
   [(:: #\\ #\newline) (cons #\newline (get-string-token input-port))]
   [(:: #\\ #\") (cons #\" (get-string-token input-port))]
   [#\" null]))


(define cap-lexer
  (lexer-src-pos
   [(:: "#" (:* (:~ "\n"))) (return-without-pos (cap-lexer input-port))]
   [whitespace (return-without-pos (cap-lexer input-port))]
   [(:+ numeric) (token-NUMBER (string->number lexeme))]
   ["\"" (token-STRING (list->string (get-string-token input-port)))]
   ["," (token-COMMA)]
   [";" (token-SEQ)]
   ["(" (token-OPAR)]
   [")" (token-CPAR)]
   ["{" (token-OCBRAC)]
   ["}" (token-CCBRAC)]
   ["&" (token-AND)]
   ["in" (token-IN)]
   ["[" (token-OBRAC)]
   ["then" (token-THEN)]
   ["else" (token-ELSE)]
   ["]" (token-CBRAC)]
   ["=" (token-EQ)]
   ["*" (token-PAIR)]
   ["directory/c" (token-DIR)]
   ["file/c" (token-FILE)]
   ["+link" (token-LINK "link")]
   ["+contents" (token-CONTENT "contents")]
   ["+create-dir" (token-CREATEDIR "create-dir")]
   ["+create-file" (token-CREATEFILE "create-file")]
   ["+add-link" (token-ADDLINK "add-link")]
   ["+add-symlink" (token-ADDSYMLINK "add-symlink")]
   ["+unlink-file" (token-UNLINKFILE "unlink-file")]
   ["+unlink-dir" (token-UNLINKDIR "unlink-dir")]
   ["+read-link" (token-READLINK "read-link")]
   ["+rename" (token-RENAME "rename")]
   ["+lookup" (token-LOOKUP "lookup")]
   ["+read" (token-READ "read")]
   ["+write" (token-WRITE "write")]
   ["+append" (token-APPEND "append")]
   ["+path" (token-PATH "path")]
   ["+stat" (token-STAT "stat")]
   ["+read-symlink" (token-READSYMLINK "read-symlink")]
   ["+exec" (token-EXEC "exec")]
   ["+exec-files" (token-EXECFILES "exec-files")]
   ["+read-files" (token-READFILES "read-files")]
   ["+write-files" (token-WRITEFILES "write-files")]
   ["+append-files" (token-APPENDFILES "append-files")]
   [":=" (token-ASSIGN)]
   [":" (token-CTC)]
   ["true" (token-BOOLEAN (make-boolean lexeme))]
   ["false" (token-BOOLEAN (make-boolean lexeme))]
   ["do" (token-DO)]
   ["if" (token-IF)]
   ["only" (token-ONLY)]
   ["with" (token-WITH)]
   ["->" (token-ARROW)]
   ["var" (token-VAR)]
   ["val" (token-VAL)]
   ["for" (token-FOR)]
   ["fun" (token-FUN)]
   ["as" (token-AS)]
   ["provide" (token-PROV)]
   ["require" (token-REQ)]
   ["#:caps" (token-CAPS "caps")]
   ["#:args" (token-ARGS "args")]
   ["#:stdin" (token-STDIN "stdin")]
   ["#:stdout" (token-STDOUT "stdout")]
   ["#:stderr" (token-STDERR "stderr")]
   [cap-id (token-ID (string->symbol lexeme))]
   [(eof) (token-EOF)])) 


(define (mk-src-pos start end)
  (list current-source-name
        (position-line start) 
        (position-col start) 
        (position-offset start) 
        (- (position-offset end) (position-offset start))))


(define (cap-parser-error tok-ok? tok-name tok-value start-pos end-pos)
  (raise-syntax-error 'shill/cap
                      (if tok-ok?
                          (format "Unexpected token ~S" tok-name)
                          (format "Invalid token ~S" tok-name))
                      (datum->syntax #f tok-value (mk-src-pos start-pos end-pos))))


(define ((mk-parser which) ip)
  (define (go)
    (port-count-lines! ip)
    (which (lambda () (cap-lexer ip))))
  (if (current-source-name)
      (go)
      (parameterize ([current-source-name (object-name ip)]
                     [file-path (object-name ip)])
        (go))))  

(define cap-parser 
  (parser
   (tokens cap-tokens cap-punct cap-privileges)
   (src-pos)
   (start program)
   (end EOF)
   (error cap-parser-error)
   (debug "parse-debug")
   (precs (left ARROW PAIR THEN ELSE))
   (grammar
    (program [() empty]
             [(pre-statement program) (list* $1 $3)])
    (pre-statement [(REQ import-specs) (list* 'require $2)]
                   [(PROV export-specs) `(provide (contract-out ,@$2))]
                   [(statements) $1])
    (import-specs ;;todo
     )
    (export-specs ;;todo
     )
    (import-spec [(STRING) (list $1)]
                 [(STRING WITH OBRAC renames CBRAC) `(rename-in ,$1 ,@$3)])
    (rename [(ID AS ID) `(,$1 ,$3)])
    (renames [(rename) $1]
             [(rename COMMA renames) (cons $1 $3)])
    (export-spec [(OBRAC ID COLON contract CBRAC) `(,$2 ,$4)])
    (statements [(statement) (list $1)]
                [(statement statements) (list* $1 $3)])
    (statement [(expr SEQ) $1]
               [(VAL ID EQ expr SEQ) (list 'val $2 $4)]
               [(VAR ID EQ expr SEQ) (list 'var $2 $4)])
    (expr [(ID) $1]
          [(BOOLEAN) $1]
          [(NUMBER) $1]
          [(STRING) $1]
          [(FOR for-clauses DO expr) (list* 'for $2 $5)] 
          [(IF  expr THEN expr) (list 'if $2 $4 '(void))] 
          [(IF  expr THEN expr ELSE expr) (list 'if $2 $4 $6)] 
          [(FUN OPAR ids CPAR expr) (list* 'lambda $3 $6)]
          [(ID OPAR args CPAR) (list* $1 $3)]
          [(contract) $1]
          [(OCBRAC statements CCBRAC) `(let () ,@$2)]
          [(ID ASSIGN expr) (list 'set-var $1 $3)])                                          
    (export [(OBRAC ID CTC contract CBRAC) (list $2 $4)])
    (contract ;; [(expr) $1]
              [(DIR OPAR top-dirkeywords CPAR) (list* 'directory/c $3)]
              [(FILE OPAR top-filekeywords CPAR) (list* 'file/c $3)]
              [(OPAR expr CPAR) (list $2)]
              [(expr ARROppW expr) (list '-> $1 $3)]
              [(OCBRAC contracts CCBRAC ARROW expr) (list* '-> (append $2 (list $5)))])              
    (contracts ;; [() empty]
               [(expr PAIR expr) (list $1 $3)]
               [(expr PAIR contracts) (cons $1 $3)])
    (ids [() empty]
         [(ID) (list $1)]
         [(ID COMMA ids) (list* $1 $3)])
    (for-clauses [(for-clause) (list $1)]
                 [(for-clause COMMA for-clauses) (list* $1 $3)])
    (for-clause [(ID IN expr) (list $1 $3)])
    (args [() empty]
          [(expr) (list $1)]
          [(expr COMMA args) (cons $1 $3)]) 
    (dirmodifier [(expr) $1]
                 [(OCBRAC dirkeywords CCBRAC) $2])
    (filemodifier [(expr) $1]
                  [(OCBRAC filekeywords CCBRAC) $2])
    (simpledirkeyword [(PATH) $1]
                      [(EXECFILES) $1]
                      [(STAT) $1]
                      [(READFILES) $1]
                      [(WRITEFILES) $1]
                      [(APPENDFILES) $1])
    (complexdirkeyword-only [(CONTENT) $1])
    (complexdirkeyword-if [(ADDLINK) $1]
                          [(UNLINKFILE) $1]
                          [(UNLINKDIR) $1]
                          [(RENAME) $1])
    (complexdirkeyword-if-and [(ADDSYMLINK) $1]
                              [(READSYMLINK) $1])
    (complexdirkeyword-with-if [(CREATEDIR) $1]
                               [(CREATEFILE) $1]
                               [(LOOKUP) $1])
    (simplefilekeyword [(PATH) $1]
                       [(LINK) $1]
                       [(EXEC) $1]
                       [(STAT) $1])
    (complexfilekeyword [(READ) $1]
                        [(WRITE) $1]
                        [(APPEND) $1])
    (dirkeyword [(simpledirkeyword) (list 'list $1 #t)]
                [(complexdirkeyword-only) (list 'list $1 #t)]
                [(complexdirkeyword-only ONLY expr) (list 'list $1 #t $3)]
                [(complexdirkeyword-with-if) (list 'list $1 #t)]
                [(complexdirkeyword-with-if WITH dirmodifier) (list 'list $1 #t $3)]
                [(complexdirkeyword-with-if IF expr) (list 'list $1 #t $3)]
                [(complexdirkeyword-with-if WITH dirmodifier IF expr) (list 'list $1 #t $5 $3)]
                [(complexdirkeyword-with-if IF expr WITH dirmodifier) (list 'list $1 #t $3 $5)]
                [(complexdirkeyword-if) (list 'list $1 #t)]
                [(complexdirkeyword-if IF expr) (list 'list $1 #t $3)]
                [(complexdirkeyword-if-and) (list 'list $1 #t)]
                [(complexdirkeyword-if-and IF expr) (list 'list $1 #t $3)]
                [(complexdirkeyword-if-and IF expr AND expr) (list 'list $1 #t $3 $5)])
    (filekeyword [(simplefilekeyword) (list 'list $1 #t)]
                 [(complexfilekeyword) (list 'list $1 #t)]
                 [(complexfilekeyword IF expr) (list 'list $1 #t $3)])
    (dirkeywords [() empty]
                 [(dirkeyword)  $1]
                 [(dirkeyword COMMA dirkeywords) (list 'cons $1 $3)])
    (filekeywords [() empty] 
                  [(filekeyword) (list $1)]
                  [(filekeyword COMMA dirkeywords) (list 'cons $1 $3)])
    (top-dirkeyword [(simpledirkeyword) (list (key->keyword $1) (list 'list $1 #t))]
                    [(complexdirkeyword-only) (list (key->keyword $1) (list 'list $1 #t))]
                    [(complexdirkeyword-only ONLY expr) (list (key->keyword $1) (list 'list $1 #t $3))]
                    [(complexdirkeyword-with-if) (list (key->keyword $1) (list 'list $1 #t))]
                    [(complexdirkeyword-with-if WITH dirmodifier) (list (key->keyword $1) (list 'list $1 #t $3))]
                    [(complexdirkeyword-with-if IF expr) (list (key->keyword $1) (list 'list $1 #t $3))]
                    [(complexdirkeyword-with-if WITH dirmodifier IF expr) (list (key->keyword $1) #t (list 'list $1 #t $3 $5))]
                    [(complexdirkeyword-with-if IF expr WITH dirmodifier) (list (key->keyword $1) #t (list 'list $1 #t $5 $3))]
                    [(complexdirkeyword-if) (list (key->keyword $1) (list 'list $1 #t))]
                    [(complexdirkeyword-if IF expr) (list (key->keyword $1) (list 'list $1 #t $3))]
                    [(complexdirkeyword-if-and) (list (key->keyword $1) (list 'list $1 #t))]
                    [(complexdirkeyword-if-and IF expr) (list (key->keyword $1) (list 'list $1 #t $3))]
                    [(complexdirkeyword-if-and IF expr AND expr) (list (key->keyword $1) (list 'list $1 #t $3 $5))])
    (top-filekeyword [(simplefilekeyword) (list (key->keyword $1) (list 'list $1 #t))]
                     [(complexfilekeyword) (list  (key->keyword $1) (list 'list $1 #t))] 
                     [(complexfilekeyword IF expr) (list (key->keyword $1) (list 'list $1 #t $3))])
    (top-dirkeywords [() empty]
                     [(top-dirkeyword)  $1]
                     [(top-dirkeyword COMMA top-dirkeywords) (append $1 $3)])
    (top-filekeywords [() empty] 
                      [(top-filekeyword)  $1]
                      [(top-filekeyword COMMA top-filekeywords) (append $1 $3)]))))




(define parse-program (mk-parser cap-parser))