" Vim Compiler File
" Compiler:	GHC
" Maintainer:	Claus Reinke <claus.reinke@talk21.com>
" Last Change:	19/10/2007
"
" part of haskell plugins: http://www.cs.kent.ac.uk/~cr3/toolbox/haskell/Vim/

" ------------------------------ paths & quickfix settings first
"

if exists("current_compiler") && current_compiler == "ghc"
  finish
endif
let current_compiler = "ghc"

let s:scriptname = "ghc.vim"

if (!exists("g:ghc") || !executable(g:ghc)) 
  if !executable('ghc') 
    echoerr s:scriptname.": can't find ghc. please set g:ghc, or extend $PATH"
    finish
  else
    let g:ghc = 'ghc'
  endif
endif    
let ghc_version = substitute(system(g:ghc . ' --version'),'\n','','')

" set makeprg (for quickfix mode) 
execute 'setlocal makeprg=' . g:ghc .'\ -e\ :q\ %'
"execute 'setlocal makeprg=' . g:ghc .'\ --make\ %'

" quickfix mode: 
" ignore banner and empty lines, 
" fetch file/line-info from error message
setlocal errorformat=%E%f:%l:%c:\ %m,
                    \%E%f:%l:%c:,
                    \%+C\ \ %#%m

" oh, wouldn't you guess it - ghc reports (partially) to stderr..
setlocal shellpipe=2>

" ------------------------- but ghc can do a lot more for us..
"

" allow map leader override
if !exists("maplocalleader")
  let maplocalleader='_'
endif

" initialize map of identifiers to their types
let b:ghc_types = {}

if exists("g:haskell_functions")
  finish
endif
let g:haskell_functions = "ghc"

" avoid hit-enter prompts
set cmdheight=3

map <LocalLeader>T :call GHC_ShowType(1)<cr>
map <LocalLeader>t :call GHC_ShowType(0)<cr>
function! GHC_ShowType(addTypeDecl)
  let namsym   = Haskell_GetNameSymbol(getline('.'),col('.'),0)
  if namsym==[]
    redraw
    echo 'no name/symbol under cursor!'
    return 0
  endif
  let [_,symb,qual,unqual] = namsym
  let name  = qual=='' ? unqual : qual.'.'.unqual
  let pname = ( symb ? '('.name.')' : name ) 
  call GHC_HaveTypes()
  if !has_key(b:ghc_types,name)
    redraw
    echo pname "type not known"
  else
    redraw
    for type in split(b:ghc_types[name],' -- ')
      echo pname "::" type
      if a:addTypeDecl
        call append( line(".")-1, pname . " :: " . type )
      endif
    endfor
  endif
endfunction

" show type of identifier under mouse pointer in balloon
if has("balloon_eval")
  set ballooneval
  set balloondelay=600
  set balloonexpr=GHC_TypeBalloon()
  function! GHC_TypeBalloon()
    if exists("b:current_compiler") && b:current_compiler=="ghc" 
      let [line] = getbufline(v:beval_bufnr,v:beval_lnum)
      let namsym = Haskell_GetNameSymbol(line,v:beval_col,0)
      if namsym==[]
        return ''
      endif
      let [start,symb,qual,unqual] = namsym
      let name  = qual=='' ? unqual : qual.'.'.unqual
      let pname = name " ( symb ? '('.name.')' : name )
      silent call GHC_HaveTypes()
      if has("balloon_multiline")
        return (has_key(b:ghc_types,pname) ? split(b:ghc_types[pname],' -- ') : '') 
      else
        return (has_key(b:ghc_types,pname) ? b:ghc_types[pname] : '') 
      endif
    else
      return ''
    endif
  endfunction
endif

map <LocalLeader>si :call GHC_ShowInfo()<cr>
function! GHC_ShowInfo()
  let namsym   = Haskell_GetNameSymbol(getline('.'),col('.'),0)
  if namsym==[]
    redraw
    echo 'no name/symbol under cursor!'
    return 0
  endif
  let [_,symb,qual,unqual] = namsym
  let name = qual=='' ? unqual : (qual.'.'.unqual)
  let output = GHC_Info(name)
  redraw
  echo output
endfunction

function! GHC_HaveTypes()
  if b:ghc_types == {}
    return GHC_BrowseAll()
  endif
endfunction

" update b:ghc_types after successful make
au QuickFixCmdPost make if getqflist()==[] | silent call GHC_BrowseAll() | endif

command! GHCReload call GHC_BrowseAll()
function! GHC_BrowseAll()
  " let imports = Haskell_GatherImports()
  " let modules = keys(imports[0]) + keys(imports[1])
  let imports = {} " no need for them at the moment
  let current = GHC_NameCurrent()
  let b:ghc_types = {}
  if current != []
    return GHC_BrowseMultiple(imports,['*'.current[0]])
  else
    return GHC_BrowseMultiple(imports,['*Main'])
  endif
endfunction

function! GHC_NameCurrent()
  let last = line("$")
  let l = 1
  while l<last
    let ml = matchlist( getline(l), '^module\s*\([^ (]*\)')
    if ml != []
      let [_,module;x] = ml
      return [module]
    endif
    let l += 1
  endwhile
  redraw
  echo "cannot find module header for file " . expand("%")
  return []
endfunction

function! GHC_BrowseMultiple(imports,modules)
  redraw
  echo "browsing modules" a:modules
  let command = ":b " . join( a:modules, " \n :b ") 
  let command = substitute(command,'\(:b \(\S*\)\)','putStrLn "-- \2" \n \1','g')
  let output = system(g:ghc . ' -v0 --interactive ' . expand("%") , command )
  return GHC_Process(a:imports,output)
endfunction

function! GHC_Info(what)
  call GHC_HaveTypes()
  let output = system(g:ghc . ' -v0 --interactive ' . expand("%"), ":i ". a:what)
  return output
endfunction

function! GHC_Process(imports,output)
  let b       = a:output
  let imports = a:imports
  let linePat = '^\(.\{-}\)\n\(.*\)'
  let contPat = '\s\+\(.\{-}\)\n\(.*\)'
  let typePat = '^\(\s*\)\(\S*\)\s*::\(.*\)'
  let modPat  = '^-- \(\S*\)'
  if !(b=~modPat)
    echo s:scriptname.": GHCi reports errors (try :make?)"
    return 0
  endif
  let ml = matchlist( b , linePat )
  while ml != []
    let [_,l,rest;x] = ml
    let mlDecl = matchlist( l, typePat )
    if mlDecl != []
      let [_,indent,id,type;x] = mlDecl
      let ml2 = matchlist( rest , '^'.indent.contPat )
      while ml2 != []
        let [_,c,rest;x] = ml2
        let type .= c
        let ml2 = matchlist( rest , '^'.indent.contPat )
      endwhile
      let id   = substitute(id, '^(\(.*\))$', '\1', '')
      let type = substitute( type, '\s\+', " ", "g" )
      " using :browse *<current>, we get both unqualified and qualified ids
      if current_module " || has_key(imports[0],module) 
        if has_key(b:ghc_types,id) && !(matchstr(b:ghc_types[id],escape(type,'[].'))==type)
          let b:ghc_types[id] .= ' -- '.type
        else
          let b:ghc_types[id] = type
        endif
      endif
      if 0 " has_key(imports[1],module) 
        let qualid = module.'.'.id
        let b:ghc_types[qualid] = type
      endif
    else
      let mlMod = matchlist( l, modPat )
      if mlMod != []
        let [_,module;x] = mlMod
        let current_module = module[0]=='*'
        let module = current_module ? module[1:] : module
      endif
    endif
    let ml = matchlist( rest , linePat )
  endwhile
  return 1
endfunction

" use ghci :browse index for insert mode omnicompletion (CTRL-X CTRL-O)
function! GHC_CompleteImports(findstart, base)
  if a:findstart 
    let namsym   = Haskell_GetNameSymbol(getline('.'),col('.'),-1) " insert-mode: we're 1 beyond the text
    if namsym==[]
      redraw
      echo 'no name/symbol under cursor!'
      return -1
    endif
    let [start,symb,qual,unqual] = namsym
    return (start-1)
  else " find keys matching with "a:base"
    let res = []
    let l   = len(a:base)-1
    call GHC_HaveTypes()
    for key in keys(b:ghc_types) 
      if key[0 : l]==a:base
        let res += [{"word":key,"menu":":: ".b:ghc_types[key],"dup":1}]
      endif
    endfor
    return res
  endif
endfunction
set omnifunc=GHC_CompleteImports
set completeopt=menu,menuone,longest

map <LocalLeader>ct :call GHC_CreateTagfile()<cr>
function! GHC_CreateTagfile()
  redraw
  echo "creating tags file" 
  let output = system(g:ghc . ' -e ":ctags" ' . expand("%"))
  " for ghcs older than 6.6, you would need to call another program 
  " here, such as hasktags
  echo output
endfunction

command! -nargs=1 GHCi redraw | echo system(g:ghc.' '.expand("%").' -e <f-args>')

" use :make 'not in scope' errors to explicitly list imported ids
" cursor needs to be on import line, in correctly loadable module
map <LocalLeader>ie :call GHC_MkImportsExplicit()<cr>
function! GHC_MkImportsExplicit()
  let save_cursor = getpos(".")
  let line   = getline('.')
  let lineno = line('.')
  let ml     = matchlist(line,'^import\(\s*qualified\)\?\s*\([^( ]\+\)')
  if ml!=[]
    let [_,q,mod;x] = ml
    silent make
    if getqflist()==[]
      call setline(lineno,'-- '.line)
      silent write
      silent make
      let qflist = getqflist()
      call setline(lineno,line)
      silent write
      let ids = []
      for d in qflist
        let ml = matchlist(d.text,'Not in scope: `\([^'']*\)''')
        if ml!=[]
          let [_,qid;x] = ml
          let id  = ( qid =~ "^[A-Z]" ? substitute(qid,'.*\.\([^.]*\)$','\1','') : qid )
          let pid = ( id =~ "[a-zA-Z0-9_']\\+" ? id : '('.id.')' )
          let ids += [pid]
        endif
      endfor
      call setline(lineno,'import'.q.' '.mod.'('.join(ids,',').')')
    endif
  endif
  call setpos('.', save_cursor)
endfunction

let opts = ["-fglasgow-exts","-fallow-undecidable-instances","-fallow-overlapping-instances","-fno-monomorphism-restriction","-fno-mono-pat-binds","-fno-cse","-fbang-patterns","-funbox-strict-fields"]
for o in opts
  exe 'amenu ]OPTIONS_GHC.'.o.' :call append(0,"{-# OPTIONS_GHC '.o.' #-}")<cr>'
endfor
map <LocalLeader>opt :popup ]OPTIONS_GHC<cr>