Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file text.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460open!Core_kernelopen!ImportmoduleQ=structincludeQletbackground_color="background-color"|>Symbol.internandconcat="concat"|>Symbol.internanddisplay="display"|>Symbol.internandfont_lock_face="font-lock-face"|>Symbol.internandforeground_color="foreground-color"|>Symbol.internandget_text_property="get-text-property"|>Symbol.internandmouse_face="mouse-face"|>Symbol.internandmultibyte_string_p="multibyte-string-p"|>Symbol.internandpropertize="propertize"|>Symbol.internandremove_list_of_text_properties="remove-list-of-text-properties"|>Symbol.internandstring="string"|>Symbol.internandstring_bytes="string-bytes"|>Symbol.internandstring_to_multibyte="string-to-multibyte"|>Symbol.internandstring_to_unibyte="string-to-unibyte"|>Symbol.internandtext_properties_at="text-properties-at"|>Symbol.internendincludeValue.Make_subtype(structletname="text"lethere=[%here]letis_in_subtype=Value.is_stringend)letchar_codeti=Symbol.funcall2Q.aref(t|>to_value)(i|>Value.of_int_exn)|>Char_code.of_value_exn;;letset_char_codetichar_code=Symbol.funcall3_iQ.aset(t|>to_value)(i|>Value.of_int_exn)(char_code|>Char_code.to_value);;letof_utf8_bytesstring=string|>Value.of_utf8_bytes|>of_value_exnletto_utf8_bytest=t|>to_value|>Value.to_utf8_bytes_exnmoduleCompare_as_string=structmoduleT0=structtypenonrect=tletcompare=Comparable.lift[%compare:string]~f:to_utf8_bytesletof_string=of_utf8_bytesletto_string=to_utf8_bytesendmoduleT=structincludeT0includeSexpable.Of_stringable(T0)endincludeTincludeComparable.Make(T)endletlengtht=Symbol.funcall1Q.length(t|>to_value)|>Value.to_int_exnletconcatts=Symbol.funcallNQ.concat(ts:tlist:>Value.tlist)|>of_value_exnmoduleFace_spec=structmoduleOne=structtypet=|AttributesofFace.Attribute_and_value.tlist|FaceofFace.t[@@derivingsexp_of]letnormalize=function|Face_ast->t|Attributesattributes->Attributes(attributes|>Face.Attribute_and_value.sort_by_attribute_name);;letcomparet1t2=matcht1,t2with|Faceface1,Faceface2->String.compare(Face.to_nameface1)(Face.to_nameface2)|Attributesa1,Attributesa2->List.compareFace.Attribute_and_value.compare_attribute_namea1a2|Face_,_->-1|_,Face_->1;;letto_value(t:t):Value.t=matchtwith|Attributesattributes->Value.list(List.fold(List.revattributes)~init:[]~f:(funac(Face.Attribute_and_value.T(attribute,value))->(attribute|>Face.Attribute.to_symbol|>Symbol.to_value)::(value|>Face.Attribute.to_valueattribute)::ac))|Faceface->face|>Face.to_value;;letraise_unexpectedvalue=raise_s[%message"[Face.One.of_value_exn] got unexpected value"(value:Value.t)];;letof_value_exnvalue:t=matchFace.of_value_exnvaluewith|x->Facex|exception_->ifnot(Value.is_consvalue)thenraise_unexpectedvalue;letcar=Value.car_exnvalueinletcdr=Value.cdr_exnvalueinifnot(Value.is_conscdr)then((* Old style specs: [(background-color . color)] [(foreground-color . color)] *)letsymbol=car|>Symbol.of_value_exninletcolor=cdr|>Color.of_value_exninifSymbol.equalsymbolQ.foreground_colorthenAttributes[T(Foreground,Colorcolor)]elseifSymbol.equalsymbolQ.background_colorthenAttributes[T(Background,Colorcolor)]elseraise_unexpectedvalue)else(letrecloopvalueac=ifValue.is_nilvaluethenAttributes(List.revac)else(ifnot(Value.is_consvalue)thenraise_unexpectedvalue;letcar=Value.car_exnvalueinletcdr=Value.cdr_exnvalueinifValue.is_conscarthenloopcdr((car|>Face.Attribute_and_value.of_value_exn)::ac)elseletmoduleA=Face.Attribute.Packedinlet(A.Tattribute)=car|>A.of_value_exninloop(Value.cdr_exncdr)(T(attribute,Value.car_exncdr|>Face.Attribute.of_value_exnattribute)::ac))inloopvalue[]);;endtypet=One.tlist[@@derivingsexp_of]letnormalizet=t|>List.map~f:One.normalize|>List.sort~compare:One.compareletto_valuet=matchtwith|[]->Value.nil|[one]->One.to_valueone|_->Value.list(List.mapt~f:One.to_value);;letof_value_exnvalue=ifValue.is_nilvaluethen[]else(matchOne.of_value_exnvaluewith|one->[one]|exception_->Value.to_list_exnvalue~f:One.of_value_exn);;letof_value_exnvalue=tryof_value_exnvaluewith|exn->raise_s[%message"[Text.Face_spec.of_value_exn] got unexpected value"(value:Value.t)(exn:exn)];;endmoduleDisplay_spec=structtypenonrect={property:Display_property.t;text:t}[@@derivingsexp_of]letto_value(t:t):Value.t=Value.list[Display_property.to_valuest.property|>Value.list;t.text|>to_value];;(* We expect values to be of the form ['((margin MARGIN) TEXT)]. *)letof_value_exnvalue:t=matchValue.to_list_exnvalue~f:identwith|[]|[_]|_::_::_::_->raise_s[%sexp"Display_spec: Could not convert value",(value:Value.t)]|[prop;txt]->{property=Display_property.of_values_exn(Value.car_exnprop,Value.car_exn(Value.cdr_exnprop));text=txt|>of_value_exn};;endmoduleProperty_name=structmoduletypeS=sigmoduleProperty_value:sigtypet[@@derivingsexp_of]valof_value_exn:Value.t->tvalto_value:t->Value.tendvalname:Symbol.tendtype'at=(moduleSwithtypeProperty_value.t='a)letname(typea)(t:at)=letmoduleT=(valt)inT.name;;letname_as_valuet=t|>name|>Symbol.to_valueletsexp_of_t_t=[%sexp(namet:Symbol.t)]letof_value_exn(typea)(t:at)=letmoduleT=(valt)inT.Property_value.of_value_exn;;letto_value(typea)(t:at)=letmoduleT=(valt)inT.Property_value.to_value;;moduleUnknown=structmoduleProperty_value=structincludeValueletof_value_exn=Fn.idletto_value=Fn.idendendmodulePacked=structtype'aproperty_name='attypet=T:_property_name->tletsexp_of_t(Tp)=[%sexp(p:_t)]letname(Tp)=namepletname_as_value(Tp)=name_as_valuepletall_except_unknown=ref[]letof_name_as_value_exnvalue=matchSymbol.of_value_exnvaluewith|exception_->raise_s[%message"[Text.Property.Packed.of_name_as_value_exn] got unexpected value"(value:Value.t)]|symbol->(matchList.find!all_except_unknown~f:(funt->Symbol.equalsymbol(namet))with|Somet->t|None->T(modulestructincludeUnknownletname=symbolend));;endletcreate_and_register(typea)(t:(moduleSwithtypeProperty_value.t=a))=Packed.all_except_unknown:=Tt::!Packed.all_except_unknown;t;;moduleFace_name=structmoduleProperty_value=Face_specendmoduleDisplay_name=structmoduleProperty_value=Display_specendletface:_t=create_and_register(modulestructincludeFace_nameletname=Q.faceend);;letmouse_face:_t=create_and_register(modulestructincludeFace_nameletname=Q.mouse_faceend);;letfont_lock_face:_t=create_and_register(modulestructincludeFace_nameletname=Q.font_lock_faceend);;letdisplay:_t=create_and_register(modulestructincludeDisplay_nameletname=Q.displayend);;endmoduleProperty=structtypet=T:'aProperty_name.t*'a->tletsexp_of_t(T(property_name,property_value))=letmoduleProperty_name=(valproperty_name)in[%message""~_:(Property_name.name:Symbol.t)~_:(property_value:Property_name.Property_value.t)];;letrecof_property_list_exnvalue=ifValue.is_nilvaluethen[]elseifnot(Value.is_consvalue)thenraise_s[%message"[Text.Property.of_property_list_exn] got unexpected value"(value:Value.t)]elseletmoduleN=Property_name.Packedinlet(N.Tproperty_name)=Value.car_exnvalue|>N.of_name_as_value_exninletproperty_value_and_rest=Value.cdr_exnvalueinT(property_name,Value.car_exnproperty_value_and_rest|>Property_name.of_value_exnproperty_name)::of_property_list_exn(Value.cdr_exnproperty_value_and_rest);;letto_property_listts=List.fold(List.revts)~init:[]~f:(funac(T(name,value))->letmoduleName=(valname)in(Name.name|>Symbol.to_value)::(value|>Name.Property_value.to_value)::ac);;endletpropertizetproperties=Symbol.funcallNQ.propertize((t|>to_value)::(properties|>Property.to_property_list))|>of_value_exn;;letproperty_valuet~atproperty_name=letvalue=Symbol.funcall3Q.get_text_property(at|>Value.of_int_exn)(property_name|>Property_name.name|>Symbol.to_value)(t|>to_value)inifValue.is_nilvaluethenNoneelseSome(value|>Property_name.of_value_exnproperty_name);;letpropertiest~at=Symbol.funcall2Q.text_properties_at(at|>Value.of_int_exn)(t|>to_value)|>Property.of_property_list_exn;;letget_startstart=(matchstartwith|Somei->i|None->0)|>Value.of_int_exn;;letget_endtend_=(matchend_with|Somei->i|None->lengtht)|>Value.of_int_exn;;letset_property?start?end_tproperty_nameproperty_value=Symbol.funcall5_iQ.put_text_property(start|>get_start)(end_|>get_endt)(property_name|>Property_name.name_as_value)(property_value|>Property_name.to_valueproperty_name)(t|>to_value);;letadd_properties?start?end_tproperties=Symbol.funcall4_iQ.add_text_properties(start|>get_start)(end_|>get_endt)(properties|>Property.to_property_list|>Value.list)(t|>to_value);;letset_properties?start?end_tproperties=Symbol.funcall4_iQ.set_text_properties(start|>get_start)(end_|>get_endt)(properties|>Property.to_property_list|>Value.list)(t|>to_value);;letremove_properties?start?end_tproperty_names=Symbol.funcall4_iQ.remove_list_of_text_properties(start|>get_start)(end_|>get_endt)(property_names|>List.map~f:Property_name.Packed.name_as_value|>Value.list)(t|>to_value);;letis_multibytet=Symbol.funcall1Q.multibyte_string_p(t|>to_value)|>Value.to_bool;;letnum_bytest=Symbol.funcall1Q.string_bytes(t|>to_value)|>Value.to_int_exnletto_multibytet=Symbol.funcall1Q.string_to_multibyte(t|>to_value)|>of_value_exn;;letto_unibyte_exnt=Symbol.funcall1Q.string_to_unibyte(t|>to_value)|>of_value_exn;;letof_char_arraychars=Symbol.funcallN_arrayQ.string(Array.mapchars~f:Char_code.to_value)|>of_value_exn;;externalto_char_array:t->Char_code.tarray="ecaml_text_to_char_array"