-- Copyright 2009-2011 Corey O'Connor{-# LANGUAGE BangPatterns #-}{-# LANGUAGE RankNTypes #-}{-# LANGUAGE ScopedTypeVariables #-}{-# LANGUAGE ExistentialQuantification #-}{-# LANGUAGE GADTs #-}{-# LANGUAGE FlexibleContexts #-}moduleGraphics.Vty.Terminal.Generic(moduleGraphics.Vty.Terminal.Generic,OutputBuffer)whereimportData.MarshallingimportGraphics.Vty.PictureimportGraphics.Vty.SpanimportGraphics.Vty.DisplayRegionimportGraphics.Vty.DisplayAttributesimportControl.Monad(liftM)importControl.Monad.TransimportqualifiedData.ByteString.InternalasBSCoreimportData.IORefimportData.String.UTF8hiding(foldl)importqualifiedData.VectorasVectorimportSystem.IO-- | An handle to a terminal that hides the implementation.dataTerminalHandlewhereTerminalHandle::Terminalt=>t->IORefTerminalState->TerminalHandlestate_ref::TerminalHandle->IORefTerminalStatestate_ref(TerminalHandle_s_ref)=s_refnew_terminal_handle::forallmt.(MonadIOm,Terminalt)=>t->mTerminalHandlenew_terminal_handlet=dos_ref<-liftIO$newIORefinitial_terminal_statereturn$TerminalHandlets_ref-- | The current terminal state. This may not exactly be known.dataTerminalState=TerminalState{known_fattr::MaybeFixedAttr}-- | Initially we know nothing about a terminal's state.initial_terminal_state::TerminalStateinitial_terminal_state=TerminalStateNothingclassTerminaltwhere-- | Text identifier for the terminal. Used for debugging.terminal_ID::t->String-- | release_terminal::MonadIOm=>t->m()-- | Clear the display and initialize the terminal to some initial display state. ---- The expectation of a program is that the display starts in some initial state. -- The initial state would consist of fixed values:-- - cursor at top left-- - UTF-8 character encoding-- - drawing characteristics are the default-- The abstract operation I think all these behaviors are instances of is reserving exclusive-- access to a display such that:-- - The previous state cannot be determined-- - When exclusive access to a display is release the display returns to the previous state.reserve_display::MonadIOm=>t->m()-- | Return the display to the state before reserve_display-- If no previous state then set the display state to the initial state.release_display::MonadIOm=>t->m()-- | Returns the current display bounds.display_bounds::MonadIOm=>t->mDisplayRegion-- Internal method used to provide the DisplayTerminal instance to the DisplayHandle-- constructor.display_terminal_instance::MonadIOm=>t->DisplayRegion->(foralld.DisplayTerminald=>d->DisplayHandle)->mDisplayHandle-- | Output the byte buffer of the specified size to the terminal device. The size is equal to-- end_ptr - start_ptroutput_byte_buffer::t->OutputBuffer->Word->IO()-- | Handle of output deviceoutput_handle::t->IOHandleinstanceTerminalTerminalHandlewhereterminal_ID(TerminalHandlet_)=terminal_IDtrelease_terminal(TerminalHandlet_)=release_terminaltreserve_display(TerminalHandlet_)=reserve_displaytrelease_display(TerminalHandlet_)=release_displaytdisplay_bounds(TerminalHandlet_)=display_boundstdisplay_terminal_instance(TerminalHandlet_)=display_terminal_instancetoutput_byte_buffer(TerminalHandlet_)=output_byte_buffertoutput_handle(TerminalHandlet_)=output_handletdataDisplayHandlewhereDisplayHandle::foralld.DisplayTerminald=>d->TerminalHandle->DisplayState->DisplayHandle-- | Acquire display access to the given region of the display.-- Currently all regions have the upper left corner of (0,0) and the lower right corner at -- (max display_width provided_width, max display_height provided_height)display_context::MonadIOm=>TerminalHandle->DisplayRegion->mDisplayHandledisplay_contexttb=dos<-initial_display_statedisplay_terminal_instancetb(\d->DisplayHandledts)dataDisplayState=DisplayState{previous_output_ref::IORef(MaybeDisplayOps)}initial_display_state::MonadIOm=>mDisplayStateinitial_display_state=liftMDisplayState$liftIO$newIORefNothingclassDisplayTerminaldwhere-- | Provide the bounds of the display context. context_region::d->DisplayRegion-- | Maximum number of colors supported by the context.context_color_count::d->Word-- | sets the output position to the specified row and column. Where the number of bytes-- required for the control codes can be specified seperate from the actual byte sequence.move_cursor_required_bytes::d->Word->Word->Wordserialize_move_cursor::MonadIOm=>d->Word->Word->OutputBuffer->mOutputBuffershow_cursor_required_bytes::d->Wordserialize_show_cursor::MonadIOm=>d->OutputBuffer->mOutputBufferhide_cursor_required_bytes::d->Wordserialize_hide_cursor::MonadIOm=>d->OutputBuffer->mOutputBuffer-- | Assure the specified output attributes will be applied to all the following text until the-- next output attribute change. Where the number of bytes required for the control codes can-- be specified seperate from the actual byte sequence. The required number of bytes must be-- at least the maximum number of bytes required by any attribute changes. The serialization-- equations must provide the ptr to the next byte to be specified in the output buffer.---- The currently applied display attributes are provided as well. The Attr data type can-- specify the style or color should not be changed from the currently applied display-- attributes. In order to support this the currently applied display attributes are required.-- In addition it may be possible to optimize the state changes based off the currently applied-- display attributes.attr_required_bytes::d->FixedAttr->Attr->DisplayAttrDiff->Wordserialize_set_attr::MonadIOm=>d->FixedAttr->Attr->DisplayAttrDiff->OutputBuffer->mOutputBuffer-- | Reset the display attributes to the default display attributesdefault_attr_required_bytes::d->Wordserialize_default_attr::MonadIOm=>d->OutputBuffer->mOutputBuffer-- | See Graphics.Vty.Terminal.XTermColor.inline_hackinline_hack::MonadIOm=>d->m()inline_hack_d=return()instanceDisplayTerminalDisplayHandlewherecontext_region(DisplayHandled__)=context_regiondcontext_color_count(DisplayHandled__)=context_color_countdmove_cursor_required_bytes(DisplayHandled__)=move_cursor_required_bytesdserialize_move_cursor(DisplayHandled__)=serialize_move_cursordshow_cursor_required_bytes(DisplayHandled__)=show_cursor_required_bytesdserialize_show_cursor(DisplayHandled__)=serialize_show_cursordhide_cursor_required_bytes(DisplayHandled__)=hide_cursor_required_bytesdserialize_hide_cursor(DisplayHandled__)=serialize_hide_cursordattr_required_bytes(DisplayHandled__)=attr_required_bytesdserialize_set_attr(DisplayHandled__)=serialize_set_attrddefault_attr_required_bytes(DisplayHandled__)=default_attr_required_bytesdserialize_default_attr(DisplayHandled__)=serialize_default_attrdinline_hack(DisplayHandled__)=inline_hackd-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.utf8_text_required_bytes::UTF8BSCore.ByteString->Wordutf8_text_required_bytesstr=let(_,_,src_bytes_length)=BSCore.toForeignPtr(toRepstr)intoEnumsrc_bytes_length-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.serialize_utf8_text::MonadIOm=>UTF8BSCore.ByteString->OutputBuffer->mOutputBufferserialize_utf8_textstrdest_ptr=let(src_fptr,src_ptr_offset,src_bytes_length)=BSCore.toForeignPtr(toRepstr)inliftIO$withForeignPtrsrc_fptr$\src_ptr->doletsrc_ptr'=src_ptr`plusPtr`src_ptr_offsetBSCore.memcpydest_ptrsrc_ptr'(toEnumsrc_bytes_length)return(dest_ptr`plusPtr`src_bytes_length)-- | Displays the given `Picture`.---- 0. The image is cropped to the display size. ---- 1. Converted into a sequence of attribute changes and text spans.-- -- 2. The cursor is hidden.---- 3. Serialized to the display.---- 4. The cursor is then shown and positioned or kept hidden.---- -- todo: specify possible IO exceptions.-- abstract from IO monad to a MonadIO instance.output_picture::MonadIOm=>DisplayHandle->Picture->m()output_picture(DisplayHandledts)pic=dolet!r=context_regiondlet!ops=spans_for_picpicrlet!initial_attr=FixedAttrdefault_style_maskNothingNothing-- Diff the previous output against the requested output. Differences are currently on a per-row-- basis.diffs::[Bool]<-liftIO(readIORef(previous_output_refs))>>=\mprevious_ops->casemprevious_opsofNothing->return$replicate(fromEnum$region_height$effected_regionops)TrueJustprevious_ops->ifeffected_regionprevious_ops/=effected_regionopsthenreturn$replicate(fromEnum$region_height$effected_regionops)Trueelsereturn$zipWith(/=)(Vector.toList$display_opsprevious_ops)(Vector.toList$display_opsops)-- determine the number of bytes required to completely serialize the output ops.lettotal=hide_cursor_required_bytesd+default_attr_required_bytesd+required_bytesdinitial_attrdiffsops+casepic_cursorpicofNoCursor->0Cursorxy->letm=cursor_output_mapops$pic_cursorpic(ox,oy)=char_to_output_posm(x,y)inshow_cursor_required_bytesd+move_cursor_required_bytesdoxoy-- ... then serializeliftIO$allocaBytes(fromEnumtotal)$\start_ptr->doptr<-serialize_hide_cursordstart_ptrptr'<-serialize_default_attrdptrptr''<-serialize_output_opsdptr'initial_attrdiffsopsend_ptr<-casepic_cursorpicofNoCursor->returnptr''Cursorxy->doletm=cursor_output_mapops$pic_cursorpic(ox,oy)=char_to_output_posm(x,y)serialize_show_cursordptr''>>=serialize_move_cursordoxoy-- todo: How to handle exceptions?caseend_ptr`minusPtr`start_ptrofcount|count<0->fail"End pointer before start of buffer."|toEnumcount>total->fail$"End pointer past end of buffer by "++show(toEnumcount-total)|otherwise->output_byte_buffertstart_ptr(toEnumcount)-- Cache the output spans.liftIO$writeIORef(previous_output_refs)(Justops)return()required_bytes::DisplayTerminald=>d->FixedAttr->[Bool]->DisplayOps->Wordrequired_bytesdin_fattrdiffsops=let(_,n,_,_)=Vector.foldl'required_bytes'(0,0,in_fattr,diffs)(display_opsops)innwhererequired_bytes'(y,current_sum,fattr,True:diffs')span_ops=let(s,fattr')=span_ops_required_bytesdyfattrspan_opsin(y+1,s+current_sum,fattr',diffs')required_bytes'(y,current_sum,fattr,False:diffs')_span_ops=(y+1,current_sum,fattr,diffs')required_bytes'(_y,_current_sum,_fattr,[])_span_ops=error"shouldn't be possible"span_ops_required_bytes::DisplayTerminald=>d->Word->FixedAttr->SpanOps->(Word,FixedAttr)span_ops_required_bytesdyin_fattrspan_ops=-- The first operation is to set the cursor to the start of the rowletheader_required_bytes=move_cursor_required_bytesd0y-- then the span ops are serialized in the order specifiedinVector.foldl'(\(current_sum,fattr)op->let(c,fattr')=span_op_required_bytesdfattropin(c+current_sum,fattr'))(header_required_bytes,in_fattr)span_opsspan_op_required_bytes::DisplayTerminald=>d->FixedAttr->SpanOp->(Word,FixedAttr)span_op_required_bytesdfattr(AttributeChangeattr)=letattr'=limit_attr_for_displaydattrdiffs=display_attr_diffsfattrfattr'c=attr_required_bytesdfattrattr'diffsfattr'=fix_display_attrfattrattr'in(c,fattr')span_op_required_bytes_dfattr(TextSpan__str)=(utf8_text_required_bytesstr,fattr)serialize_output_ops::(MonadIOm,DisplayTerminald)=>d->OutputBuffer->FixedAttr->[Bool]->DisplayOps->mOutputBufferserialize_output_opsdstart_ptrin_fattrdiffsops=do(_,end_ptr,_,_)<-Vector.foldM'serialize_output_ops'(0,start_ptr,in_fattr,diffs)(display_opsops)returnend_ptrwhereserialize_output_ops'(y,out_ptr,fattr,True:diffs')span_ops=serialize_span_opsdyout_ptrfattrspan_ops>>=return.(\(out_ptr',fattr')->(y+1,out_ptr',fattr',diffs'))serialize_output_ops'(y,out_ptr,fattr,False:diffs')_span_ops=return(y+1,out_ptr,fattr,diffs')serialize_output_ops'(_y,_out_ptr,_fattr,[])_span_ops=error"shouldn't be possible"serialize_span_ops::(MonadIOm,DisplayTerminald)=>d->Word->OutputBuffer->FixedAttr->SpanOps->m(OutputBuffer,FixedAttr)serialize_span_opsdyout_ptrin_fattrspan_ops=do-- The first operation is to set the cursor to the start of the rowout_ptr'<-serialize_move_cursord0yout_ptr-- then the span ops are serialized in the order specifiedVector.foldM(\(out_ptr'',fattr)op->serialize_span_opdopout_ptr''fattr)(out_ptr',in_fattr)span_opsserialize_span_op::(MonadIOm,DisplayTerminald)=>d->SpanOp->OutputBuffer->FixedAttr->m(OutputBuffer,FixedAttr)serialize_span_opd(AttributeChangeattr)out_ptrfattr=doletattr'=limit_attr_for_displaydattrfattr'=fix_display_attrfattrattr'diffs=display_attr_diffsfattrfattr'out_ptr'<-serialize_set_attrdfattrattr'diffsout_ptrreturn(out_ptr',fattr')serialize_span_op_d(TextSpan__str)out_ptrfattr=doout_ptr'<-serialize_utf8_textstrout_ptrreturn(out_ptr',fattr)marshall_to_terminal::(Terminalt)=>t->Word->(PtrWord8->IO(PtrWord8))->IO()marshall_to_terminaltcf=dostart_ptr<-mallocBytes(fromEnumc)-- -- todo: capture exceptions?end_ptr<-fstart_ptrcaseend_ptr`minusPtr`start_ptrofcount|count<0->fail"End pointer before start pointer."|toEnumcount>c->fail$"End pointer past end of buffer by "++show(toEnumcount-c)|otherwise->output_byte_buffertstart_ptr(toEnumcount)freestart_ptrreturn()-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this-- needs to be translated to column, row positions.dataCursorOutputMap=CursorOutputMap{char_to_output_pos::(Word,Word)->(Word,Word)}cursor_output_map::DisplayOps->Cursor->CursorOutputMapcursor_output_mapspan_ops_cursor=CursorOutputMap{char_to_output_pos=\(cx,cy)->(cursor_column_offsetspan_opscxcy,cy)}cursor_column_offset::DisplayOps->Word->Word->Wordcursor_column_offsetspan_opscxcy=letcursor_row_ops=Vector.unsafeIndex(display_opsspan_ops)(fromEnumcy)(out_offset,_,_)=Vector.foldl'(\(d,current_cx,done)op->ifdonethen(d,current_cx,done)elsecasespan_op_has_widthopofNothing->(d,current_cx,False)Just(cw,ow)->casecomparecx(current_cx+cw)ofGT->(d+ow,current_cx+cw,False)EQ->(d+ow,current_cx+cw,True)LT->(d+columns_to_char_offset(cx-current_cx)op,current_cx+cw,True))(0,0,False)cursor_row_opsinout_offset-- | Not all terminals support all display attributes. This filters a display attribute to what the-- given terminal can display.limit_attr_for_display::DisplayTerminald=>d->Attr->Attrlimit_attr_for_displaydattr=attr{attr_fore_color=clamp_color$attr_fore_colorattr,attr_back_color=clamp_color$attr_back_colorattr}whereclamp_colorDefault=Defaultclamp_colorKeepCurrent=KeepCurrentclamp_color(SetToc)=clamp_color'cclamp_color'(ISOColorv)|context_color_countd<8=Default|context_color_countd<16&&v>=8=SetTo$ISOColor(v-8)|otherwise=SetTo$ISOColorvclamp_color'(Color240v)-- TODO: Choose closes ISO color?|context_color_countd<8=Default|context_color_countd<16=Default|context_color_countd==240=SetTo$Color240v|otherwise=letp::Double=fromIntegralv/240.0v'=floor$p*(fromIntegral$context_color_countd)inSetTo$Color240v'