Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file lineEdit.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628(****************************************************************************)(* *)(* This file is part of MOPSA, a Modular Open Platform for Static Analysis. *)(* *)(* Copyright (C) 2017-2019 The MOPSA Project. *)(* *)(* This program is free software: you can redistribute it and/or modify *)(* it under the terms of the GNU Lesser General Public License as published *)(* by the Free Software Foundation, either version 3 of the License, or *)(* (at your option) any later version. *)(* *)(* This program is distributed in the hope that it will be useful, *)(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)(* GNU Lesser General Public License for more details. *)(* *)(* You should have received a copy of the GNU Lesser General Public License *)(* along with this program. If not, see <http://www.gnu.org/licenses/>. *)(* *)(****************************************************************************)(**
Simple line-editing for interactive sessions in the terminal.
Assumes an UTF-8 console with standard ANSI escape codes.
*)(** {2 Entering raw mode} *)(** ********************* *)letorg_stdin_attr=trySomeUnix.(tcgetattrstdin)withUnix.Unix_error_->None(* if Unix module is not supported *)(** Whether terminal control is available *)lettc_available()=org_stdin_attr<>None(** Enter raw mode before starting line edition. *)letenter_raw_mode()=matchorg_stdin_attrwith|Someattr->letopenUnixinlettt={attrwithc_isig=false;c_ixon=false;c_icanon=false;c_echo=false;c_icrnl=false;c_inlcr=false;c_vmin=0;c_vtime=1;}intcsetattrstdinTCSADRAINtt|None->failwith"Raw terminal mode not supported (tcsetattr not available)"(** Exit raw mode after finishing line edition.
Do not call print to the console when in raw mode.
*)letexit_raw_mode()=matchorg_stdin_attrwith|None->()|Someattr->Unix.(tcsetattrstdinTCSADRAINattr)(** Ensure that we restore the terminal when quitting. *)let_=at_exitexit_raw_mode(** {2 FIFO character buffer} *)(** ************************* *)moduleFIFO=structtypet={mutablecin:charlist;(* chars are accumulated here *)mutablecout:charlist;(* chars are read from here *)}letcreate()={cin=[];cout=[];}letis_empty(b:t):bool=b.cin=[]&&b.cout=[]letlength(b:t):int=List.lengthb.cin+List.lengthb.coutletadd(b:t)(c:char):unit=b.cin<-c::b.cinletget(b:t):char=matchb.coutwith|a::r->b.cout<-r;a|[]->(* time to get more chars from the accumulated buffer *)matchList.rev(b.cin)with|a::r->b.cin<-[];b.cout<-r;a|[]->invalid_arg"Empty FIFO"letget_opt(b:t):charoption=ifis_emptybthenNoneelseSome(getb)letclear(b:t):unit=b.cin<-[];b.cout<-[]end(** {2 Character input} *)(** ******************* *)(** Non blocking read_char. *)letread_char_unbuf_opt():charoption=flushstdout;letopenUnixinletb=Bytes.make1' 'inletr=readstdinb01inifr=0thenNoneelseifr=1thenSome(Bytes.getb0)elsefailwith"Read error"(** Block until a char is available and return it. *)letrecread_char_unbuf():char=matchread_char_unbuf_opt()with|Somex->x|None->read_char_unbuf()(** We may need to scan the input to get the answer for a
get_position call.
Hence, we keep a FIFO of inputs read while scanning.
*)letrabuf=FIFO.create()(** Put (back) in FIFO. *)letunread_char(c:char)=FIFO.addrabufcletunread_char_list(c:charlist)=List.iterunread_charc(** Non blocking read_char.
Fetch from the read-ahead buffer first.
*)letread_char_opt():charoption=ifFIFO.is_emptyrabufthenread_char_unbuf_opt()elseSome(FIFO.getrabuf)(** Block until a char is available and return it.
Fetch from the read-ahead buffer first.
*)letread_char():char=ifFIFO.is_emptyrabufthenread_char_unbuf()elseFIFO.getrabuf(** Put all chars possible in the read-ahead buffer. *)letrecread_flush():unit=matchread_char_unbuf_opt()with|Somex->unread_charx;read_flush()|None->()(** {2 Cursor manipulation} *)(** *********************** *)letpf=Printf.printfletps=print_string(** Moves the cursor up, down, left, or right n positions. *)letcursor_upn=pf"\027[%iA"nletcursor_downn=pf"\027[%iB"nletcursor_rightn=pf"\027[%iC"nletcursor_leftn=pf"\027[%iD"n(** Go to the begining of the n-th next / previous line. *)letnext_linen=pf"\027[%iE"nletperv_linen=pf"\027[%iF"n(** Move to line l, column c (starting at 1). *)letset_columnc=pf"\027[%iG"cletset_positionlc=pf"\027[%i;%iH"lc(** Clear the whole screen / line. *)letclear_screen()=ps"\027[2J"letclear_line()=ps"\027[2K"(** Clear the screen / line from the cursor position until the end. *)letclear_end_screen()=ps"\027[0J"letclear_end_line()=ps"\027[0K"(** Clear the screen / line up to the cursor position from the begining. *)letclear_start_screen()=ps"\027[1J"letclear_start_line()=ps"\027[1K"(** Scroll some number of lines up / down. *)letscroll_upn=pf"\027[%iS"nletscroll_downn=pf"\027[%iT"n(** Save / restore the cursor position. *)letsave_position()=ps"\027[s"letrestore_position()=ps"\027[u"(** Return the cursur line and column (starting at 1).
Return (0,0) in case of an error.
*)letget_position():int*int=(*read_flush ();*)(* write ESC[6n *)print_string"\027[6n";(* read back ESC[<line>;<col>R *)letrecwait()=matchread_char_unbuf()with|'\027'->wait2()|x->unread_charx;wait()andwait2()=matchread_char_unbuf()with|'['->()|'\027'->unread_char'\027';wait2()|x->unread_char_list['\027';x];wait()inletrecupdtacc=letc=read_char_unbuf()inifc>='0'&&c<='9'thenupdt(acc*10+Char.codec-Char.code'0')elsec,accinwait();letr1,l=updt0inifr1<>';'then0,0elseletr2,c=updt0inifr2<>'R'then0,0elsel,c(** Return the height and width of the window. *)letget_window_size():int*int=(* save cursor position *)letl,c=get_position()in(* go bottom and right as far as we can *)cursor_right999;cursor_down999;(* cursor position indicates the size *)leth,w=get_position()in(* restore cursor position *)set_positionlc;h,w(** {2 UTF-8 buffers} *)(** ***************** *)(** Byte-size of the utf-8 char starting with code c. *)letsizeof_uchar(c:char):int=leti=Char.codecinifiland0x80=0then1elseifiland0xe0=0xc0then2elseifiland0xf0=0xe0then3elseifiland0xf8=0xf0then4elseifiland0xfb=0xf8then5elseifiland0xfe=0xfbthen6else1(* error *)(** Buffers backed by byte sequences that grow automatically.
Support insertion and deletion at any position within the buffer.
Include some support for UTF-8 encoding.
*)moduleUBuf=structtypet={mutablebuf:Bytes.t;(* buffer *)mutablelen:int;(* nb of bytes actually used *)}(* internal function to ensure that there is room for nb more bytes *)letensure(b:t)(nb:int)=ifb.len+nb>Bytes.lengthb.bufthen(letbuf=Bytes.create(2*(b.len+nb))inBytes.blitb.buf0buf0b.len;b.buf<-buf)(** Create an empty buffer. *)letcreate()={buf=Bytes.create2;len=0;}(** Creates a copy of a buffer. *)letcopy(b:t):t={buf=Bytes.copyb.buf;len=b.len;}(** Buffer contents, as a string. *)letcontents(b:t):string=Bytes.sub_stringb.buf0b.len(** Buffer size in bytes. *)letbyte_length(b:t):int=b.len(** Buffer size in utf-8 chars. *)letuchar_length(b:t):int=leti,len=ref0,ref0inwhile!i<b.lendoi:=!i+sizeof_uchar(Bytes.getb.buf!i);incrlendone;!len(** Byte index of the nb-th utf-8 char. *)letindex_of_uchar(b:t)(nb:int):int=letidx=ref0infor_=0tonb-1doif!idx>=b.lentheninvalid_arg"index_of_uchar";idx:=!idx+sizeof_uchar(Bytes.getb.buf!idx)done;!idx(** Get the byte at the specified byte index. *)letnth(b:t)(i:int):char=ifi<0||i>=b.lentheninvalid_arg"nth";Bytes.getb.bufi(** Get the substring from the specified byte index. *)letsub(b:t)(i:int)(len:int):string=ifi<0||i+len>b.lentheninvalid_arg"sub";Bytes.sub_stringb.bufilen(** Append a byte at the end of the buffer. *)letadd_char(b:t)(c:char):unit=ensureb1;Bytes.setb.bufb.lenc;b.len<-b.len+1(** Append a part of a string at the end of the buffer. *)letadd_substring(b:t)(s:string)(off:int)(len:int):unit=ifoff<0||len<0||off+len>String.lengthstheninvalid_arg"add_substring";iflen>0then(ensureblen;Bytes.blit_stringsoffb.bufb.lenlen;b.len<-b.len+len)(** Append a string at the end of the buffer. *)letadd_string(b:t)(s:string):unit=add_substringbs0(String.lengths)(** Insert a byte at the specified byte index. *)letinsert_char(b:t)(i:int)(c:char):unit=ifi<0||i>b.lentheninvalid_arg"insert_char";ensureb1;ifb.len>ithenBytes.blitb.bufib.buf(i+1)(b.len-i);Bytes.setb.bufic;b.len<-b.len+1(** Insert a substring at the specified byte index. *)letinsert_substring(b:t)(dst:int)(s:string)(src:int)(len:int):unit=ifsrc<0||len<0||src+len>String.lengths||dst<0||dst>b.lentheninvalid_arg"insert_substring";ensureblen;ifb.len>dstthenBytes.blitb.bufdstb.buf(dst+len)(b.len-dst);Bytes.blit_stringssrcb.bufdstlen;b.len<-b.len+len(** Insert a string at the specified byte index. *)letinsert_string(b:t)(dst:int)(s:string):unit=ifdst<0||dst>b.lentheninvalid_arg"insert_string";letlen=String.lengthsinensureblen;ifb.len>dstthenBytes.blitb.bufdstb.buf(dst+len)(b.len-dst);Bytes.blit_strings0b.bufdstlen;b.len<-b.len+len(** Delete some bytes at the specified byte index. *)letdelete(b:t)(i:int)(len:int)=ifi<0||len<0||i+len>b.lentheninvalid_arg"delete";ifb.len>i+lenthenBytes.blitb.buf(i+len)b.bufi(b.len-i-len);b.len<-b.len-len(** Reset the buffer to 0 length. *)letclear(b:t)=b.len<-0;b.buf<-Bytes.create2(** Print to buffer. *)letoutput(ch:out_channel)(b:t)=output_stringch(contentsb)end(** {2 Line editing} *)(** **************** *)(** Line edition context, maintained between calls to read_line. *)typectx={mutablectx_history:UBuf.tlist;}letcreate_ctx()={ctx_history=[];}(* \\ followed by end-of-line *)letbackslash_eol=Str.regexp"\\\\\\(\n\\|\r\\|\r\n\\)"(** Main line editing function, with support for cursor movement and history.
You can print a prompt before calling this function.
Return the string that was read.
Throw Exit when Ctrl+C or Ctrl+D is typed.
*)letread_line_tcctx=ctx.ctx_history<-(UBuf.create())::ctx.ctx_history;(* current buffer *)letbuf=ref(List.hdctx.ctx_history)in(* position in history *)lethpos=ref0in(* know when to quit *)letcontinue=reftrueintry(* setup terminal parameters *)enter_raw_mode();leth,w=get_window_size()inletorg_l,org_c=get_position()in(* start of line *)letorg_l=reforg_lin(* mutable, in case of scrolling *)letcur=ref0in(* cursor position, in characters within buf *)(* line, column where the n-th character is displayed *)letcur_posn=letrecdoitlcin=ifn=0||i>=UBuf.byte_length!bufthen(l,c)elseletx=UBuf.nth!bufiinifx='\n'||x='\r'thendoit(l+1)1(i+1)(n-1)elsedoit(l+c/w)(cmodw+1)(i+sizeof_ucharx)(n-1)indoit!org_lorg_c0nin(* cursor position corresponding to the given line, column *)letpos_curdstldstc=letrecdoitlcin=if(l>=dstl&&c>=dstc)||i>=UBuf.byte_length!bufthennelseletx=UBuf.nth!bufiinifx='\n'||x='\r'thenifl=dstlthenn(* don't go past dstl if line is shorter than dstc *)elsedoit(l+1)1(i+1)(n+1)elsedoit(l+c/w)(cmodw+1)(i+sizeof_ucharx)(n+1)indoit!org_lorg_c00in(* edition loop *)while!continuedo(* show line *)set_position!org_lorg_c;clear_end_screen();UBuf.outputstdout!buf;print_string" ";(* detect scrolling *)letend_l,_=cur_pos(-1)inifend_l>hthenorg_l:=!org_l+h-end_l;(* show cursor at the correct position *)cur:=max0(min!cur(UBuf.uchar_length!buf));letcur_l,cur_c=cur_pos!curinset_positioncur_lcur_c;flushstdout;(* handle input *)matchread_char()with(* return *)|'\r'|'\n'->if!cur>0&&UBuf.nth!buf(UBuf.index_of_uchar!buf(!cur-1))='\\'then((* after a \, insert a new-line *)letpos=UBuf.index_of_uchar!buf!curinincrcur;UBuf.insert_char!bufpos'\n')else(* otherwise, finish line input *)continue:=false(* special characters *)|'\027'->(matchread_char()with|'['->(matchread_char()with(* up *)|'A'->ifcur_l=!org_lthenif!hpos<List.lengthctx.ctx_history-1then((* go up in history *)hpos:=!hpos+1;buf:=List.nthctx.ctx_history!hpos;cur:=UBuf.uchar_length!buf)else()else(* go up in the line *)cur:=pos_cur(cur_l-1)cur_c(* down *)|'B'->ifcur_l=end_lthenif!hpos>0then((* go down in history *)hpos:=!hpos-1;buf:=List.nthctx.ctx_history!hpos;cur:=UBuf.uchar_length!buf)else()else(* go down in line *)cur:=pos_cur(cur_l+1)cur_c(* right *)|'C'->cur:=min(UBuf.uchar_length!buf)(!cur+1)(* left *)|'D'->cur:=max0(!cur-1)(* home *)|'H'->cur:=0(* end *)|'F'->cur:=UBuf.uchar_length!buf(* delete *)|'3'->let_=read_char()in(* ~ *)if!cur<UBuf.uchar_length!bufthen(letpos=UBuf.index_of_uchar!buf!curinletlen=sizeof_uchar(UBuf.nth!bufpos)inUBuf.delete!bufposlen)|_->())(* alt-enter: insert a new-line *)|'\n'|'\r'->UBuf.insert_char!buf(UBuf.index_of_uchar!buf!cur)'\n';incrcur|_->())(* backspace *)|'\127'->if!cur>0then(cur:=!cur-1;letpos=UBuf.index_of_uchar!buf!curinletlen=sizeof_uchar(UBuf.nth!bufpos)inUBuf.delete!bufposlen)(* ctrl+C / ctrl+D: quit *)|'\003'|'\004'->raiseExit(* visible character *)|xwhenx>=' '->letpos=UBuf.index_of_uchar!buf!curinincrcur;UBuf.insert_char!bufposx;(* add remaining bytes in case of a multi-byte utf-8 character *)letlen=sizeof_ucharxinfori=1tolen-1doUBuf.insert_char!buf(pos+i)(read_char())done(* unhandled control character *)|_->()done;(* fix history *)if!hpos<>0thenctx.ctx_history<-(UBuf.copy!buf)::(List.tlctx.ctx_history);(* end: fix terminal *)print_string"\n";flushstdout;exit_raw_mode();(* return string, removing \ at end of lines *)lets=(UBuf.contents!buf)^"\n"inStr.global_replacebackslash_eol"\n"swithx->(* error: fix terminal and re-raise exception *)print_string"\n";flushstdout;exit_raw_mode();raisex(** Line edition, with fall-back to Stdlib.read_line if there is no terminal control. *)letread_linectx=iftc_available()thenread_line_tcctxelseStdlib.read_line()