checkwriting

#!/usr/bin/env perl
#
# Author : Devdatta Akhawe  http://www.cs.berkeley.edu/~devdatta 
#

# Original Idea and list of words by Matthew Might
# http://matt.might.net/articles/shell-scripts-for-passive-voice-weasel-words-duplicates/

use strict ;
use warnings;
use Getopt::Long;

my @switch_list = ('passive','dups','weasel','abbr','typography','strunk','user');
my %options= map {$_=>1} @switch_list;
my $vimmode = 0;
Getopt::Long::Configure('pass_through');
GetOptions( \%options, 'd','v');
if($options{'v'}){
  $vimmode=1;
}

if($options{'d'}){
  $_ = 0 foreach values %options;
  delete $options{'d'};
}
Getopt::Long::Configure('no_pass_through');

GetOptions( \%options, 'wordfile=s', 'def_color=s',map {("$_!",$_."_color=s")} @switch_list);
my ($passive_color,$typography_color,$weasel_color,$dup_color,$abbr_color,$strunk_color,$user_color,$def_color) = (
getBashColor($options{'passive_color'},'red'),
getBashColor($options{'typography_color'},'yellow'),
getBashColor($options{'weasel_color'},'green'),
getBashColor($options{'dup_color'},'purple'),
getBashColor($options{'abbr_color'},'blue'),
getBashColor($options{'strunk_color'},'cyan'),
getBashColor($options{'user_color'},'darkyellow'),
getBashColor($options{'def_color'},'def'),
);

if ($vimmode) {
  ($passive_color,$typography_color,$weasel_color,$dup_color,$abbr_color,$strunk_color,$user_color,$def_color) = (
    '**',
    '**',
    '**',
    '**',
    '**',
    '**',
    '**',
    '**',
  );
}
#intialize default color
print $def_color unless $vimmode;
my $filename="";
my @files=@ARGV;
$options{'diffmode'}=0;
if(not @files){
  #There are no files. Switch to diff output handling
  $options{'diffmode'}=1;
}
  
if($#files==0 and -d $files[0]){
  my $dirname=shift @files;
  $dirname =~ s/\/$//;
  @files= glob("$dirname/*tex $dirname/*bbl");
}

my $str='';
#use stdin if no file available
@files=("/dev/stdin") unless @files;

#HACK for <5.10
my $LevelN;
if($] < 5.010){
  $LevelN = qr/ (?> [^{}]+ | \{ (??{ $LevelN }) \} )* /x;
}


my @user_words=();
foreach my $filename ( $ENV{'HOME'}.'/.awc_wordlist', 'awc_wordlist' ,  $options{'wordfile'} ){
  next unless $filename;
  if(-e $filename){
  open my $fh,'<',$filename or die "Error opening $filename";
  while(<$fh>){ 
    next if m/^#/;
    chomp; 
    next unless $_;
    s/\s+/\\s+/g; 
    push @user_words,$_;
    }
  }else{
    if($options{'wordfile'} and ($filename eq $options{'wordfile'})){
      die "Couldn't find user defined wordfile ".$options{'wordfile'};
    }

  }
}


while(($filename=shift @files)){
    {
    open my $fh,'<',$filename or die "Error opening $filename";
    local $/;
    $str=<$fh>;
    close($fh);
    }

    #remove lstlistings from the check
    #TODO: remove lstlistings, but replace each line with a blank line
    # so that line numbers don't get screwed up
    #$str =~ s/\\begin\{lstlisting\}.*?\\end\{lstlisting\}//sg;


    if($options{'diffmode'}){
      $str=~ s/^(?:(?:[^\+].*)|(?:\+(?:(?:\+.*)|(.*))))$/$1||''/meg;
      $filename='diff_additions';
    }
    $str =~ s/([^\\])%.*$/$1/mg ;
    my $count=0;
    if($filename =~ m/bbl$/){
      #for bbl files only look for URL errors
      $count += fixURL() if $options{'typography'};
    }else{
    #spaces since \b on both sides had too many false positives like -,:
    $count += fixTypography() if $options{'typography'};
    $count += fixPassive() if $options{'passive'};
    $count += fixDups() if $options{'dups'};
    $count += fixWeasel() if $options{'weasel'};
    $count += fixStrunk() if $options{'strunk'};
    $count += fixAbbr() if $options{'abbr'};
    $count += fixUserWords() if $options{'user'} and @user_words;
    }
    next unless $count;
    my $linenum=0;
    if($filename =~ m/([^\/]*)$/){
        $filename = $1 ;
    }
    my $extra="";
    open my $fh,'<:utf8',\$str or die $!;
    while(my $line= <$fh>){
      $linenum++;
      next unless $line =~ m/\x{EFFF}/;
      $line =~ s/\x{EFFF}//g;
      # we can't do this while setting str since that messes up line numbers
      # I am pretty sure this is ok since the % would prevent match across lines
      # this is moot if ignorecomment is turned on
      next if $line =~ m/^\s*%/;
      print "$filename:$linenum: $line";
      $extra =1 ;
    }
    close $fh;
    # some spacing from the new file
    print "\n" if @files and $extra;
    
}

exit if $vimmode;
print "\n";
print $passive_color,'PASSIVE VOICE',"   " if $options{'passive'};
print $typography_color,'TYPOGRAPHY ERRORS',"   " if $options{'typography'};
print $weasel_color,'WEASEL WORDS',"   " if $options{'weasel'};
print $dup_color,'DUPLICATES',"   " if $options{'dups'};
print $strunk_color,'STRUNK AND WHITE',"   " if $options{'strunk'};
print $abbr_color,'ABBR',"   " if $options{'abbr'};
print $user_color,'USER' if $options{'user'};
print "\n";

#reset to terminal default
print getBashColor('def');

sub fixPassive{
  my @irregulars=(
"awoken",
"been","born","beat",
"become","begun","bent",
"beset","bet","bid",
"bidden","bound","bitten",
"bled","blown","broken",
"bred","brought","broadcast",
"built","burnt","burst",
"bought","cast","caught",
"chosen","clung","come",
"cost","crept","cut",
"dealt","dug","dived",
"done","drawn","dreamt",
"driven","drunk","eaten","fallen",
"fed","felt","fought","found",
"fit","fled","flung","flown",
"forbidden","forgotten",
"foregone","forgiven",
"forsaken","frozen",
"gotten","given","gone",
"ground","grown","hung",
"heard","hidden","hit",
"held","hurt","kept","knelt",
"knit","known","laid","led",
"leapt","learnt","left",
"lent","let","lain","lighted",
"lost","made","meant","met",
"misspelt","mistaken","mown",
"overcome","overdone","overtaken",
"overthrown","paid","pled","proven",
"put","quit","read","rid","ridden",
"rung","risen","run","sawn","said",
"seen","sought","sold","sent",
"set","sewn","shaken","shaven",
"shorn","shed","shone","shod",
"shot","shown","shrunk","shut",
"sung","sunk","sat","slept",
"slain","slid","slung","slit",
"smitten","sown","spoken","sped",
"spent","spilt","spun","spit",
"split","spread","sprung","stood",
"stolen","stuck","stung","stunk",
"stridden","struck","strung",
"striven","sworn","swept",
"swollen","swum","swung","taken",
"taught","torn","told","thought",
"thrived","thrown","thrust",
"trodden","understood","upheld",
"upset","woken","worn","woven",
"wed","wept","wound","won",
"withheld","withstood","wrung",
"written");
  my $regex = '\b(am|are|were|being|is|been|was|be)\b(\s+)(\w+ed|('.join('|',@irregulars).'))\b';
  return $str =~ s/$regex/\x{EFFF}$def_color$passive_color$1$def_color$2$passive_color$3$def_color\x{EFFF}/goi;
}

sub fixWeasel{
 #TODO add better support for wordfile
 my $regex ='\b(might|appears\s+to\s+be|it\s+is\s+easy\s+to\s+see|theoretically|actual|In\s+this\s+paper|almost|many|various|very|fairly|several|extremely|exceedingly|quite|remarkably|few|surprisingly|mostly|largely|huge|tiny|((are|is) a number)|excellent|interestingly|significantly|substantially|clearly|vast|relatively|completely)\b';
 return $str =~ s/$regex/\x{EFFF}$weasel_color$1$def_color\x{EFFF}/goi;
}

sub fixDups{
return $str =~ s/\b(\w+)(\s+)(\1)\b/\x{EFFF}$dup_color$1$def_color$2$dup_color$3$def_color\x{EFFF}/iog;
}

sub fixAbbr{
  my $c = ($str =~ s/\b(et\.\s+al|i\.e(?!\.)|et\s+al(?!\.))\b/\x{EFFF}$abbr_color$1$def_color\x{EFFF}/og);
  $c += ($str =~ s/\b(e\.g\.(?!,)|e\.g(?!\.))/\x{EFFF}$abbr_color$1$def_color\x{EFFF}/og);
  return $c;
}

sub fixStrunk{
  my $count=0;
  $count += fixStrunkWords();
  return $count;
}

sub fixTypography{
  my $c= 0;
  #footnotes look better if started after punctuations
  if($] >= 5.010){
    my $regex = '(\\\\footnote)(\{(?:(?>[^{}]+)|(?2))+\})([.,:=;-])';
    $c +=  ($str =~ s/$regex/\x{EFFF}$typography_color$1$def_color\x{EFFF}$2\x{EFFF}$typography_color$3$def_color\x{EFFF}/og);
  }else{
  $c+=($str =~ s/(\\footnote)(\{$LevelN\})([.,:=;-])/\x{EFFF}$typography_color$1$def_color\x{EFFF}$2\x{EFFF}$typography_color$3$def_color\x{EFFF}/og);
  }

  #Latex assumes a '.' ends a sentence unless its after a uppercase letter
  #http://www.ece.ucdavis.edu/~jowens/commonerrors.html
  $c += ($str =~ s/\b((?:et\sal\.|i\.e\.|etc\.|vs\.) )/\x{EFFF}$typography_color$1<slash escape the space>$def_color\x{EFFF}/og);
  $c += ($str =~ s/([^\s]*[A-Z]\.)(?=\s|$)/\x{EFFF}$typography_color$1<add a \\\@>$def_color\x{EFFF}/og);
  $c += ($str =~ s/\b(,\set\sal\.)/\x{EFFF}$typography_color$1<no comma before et al.>$def_color\x{EFFF}/og);
  $c += ($str =~ s/(\s\d{4,}\b)/\x{EFFF}$typography_color$1$def_color\x{EFFF}/go) if $options{'number'};
  #URLs should be typeset with \url
  $c += fixURL();
  return $c;
}

sub fixStrunkWords{
  my $regex=qr{ #initially from the  chapter IV (
and\/or | anticipate | as \s good \s or \s better \s than | as \s yet | 
as \s to \s whether | certainly | factor | feature 
| finalize | importantly | insightful | in[ ]terms[ ]off | interesting(?:ly)? | irregardless | meaningful(?:ly)? | nice(?:ly)? | 
one \s of \s the \s most| respective(?:ly)? |
(?:most|very) \s unique | 
utilize | very  | the fact that |
rather | little | pretty #from the last chapter
}x;
  my $c = $str =~ s/\b($regex)\b/\x{EFFF}$strunk_color$1$def_color\x{EFFF}/g;
  $c += $str =~ s/([.?]\s*However)/\x{EFFF}$strunk_color$1$def_color\x{EFFF}/g;
  return $c;
}


sub fixStrunkRule2{
  #broken broken broken
  my $word = qr/[a-z]{2,}/;
  my $words = qr/$word(?:\s+$word)*/;
  return $str =~ s/(,\s*$words\s*)(?=\s+and\s*$words)/\x{EFFF}$dup_color$1$def_color\x{EFFF}/goi;
}


sub fixURL{
  #http://daringfireball.net/2010/07/improved_regex_for_matching_urls
  my $regex=qr{
  \b
  (                       # Capture 1: entire matched URL
    (?:
      (ht|f)tps?:\/\/               # http or https protocol
      |                       #   or
      www\d{0,3}[.]           # "www.", "www1.", "www2." … "www999."
      |                           #   or
      [a-z0-9.\-]+[.][a-z]{2,4}\/  # looks like domain name followed by a slash
    )
    (?:                       # One or more:
      [^\s()<>]+                  # Run of non-space, non-()<>
      |                           #   or
      \(([^\s()<>]+|(\([^\s()<>]+\)))*\)  # balanced parens, up to 2 levels
    )+
    (?:                       # End with:
      \(([^\s()<>]+|(\([^\s()<>]+\)))*\)  # balanced parens, up to 2 levels
      |                               #   or
      [^\s`!()\[\]{};:'".,<>?«»“”‘’]        # not a space or one of these punct chars
    )
  )}x;
  return $str =~ s/(\\url\{[^}]*\})|($regex)/$1 || "\x{EFFF}$typography_color$2$def_color\x{EFFF}"/eog;
}

sub getBashColor{
# Color codes are at http://www.cyberciti.biz/faq/bash-shell-change-the-color-of-my-shell-prompt-under-linux-or-unix/
  my $color=lc($_[0]||'');
  my $shade='light';
  $shade= 'dark' if $color =~ s/^dark//;
  $color =~ s/^light//;
  return "\e[00m" if $color =~ m/^def/;
  my $i=0;
  my %color_hash=map {$_ => $i++} ('black','red','green','yellow','blue','purple','cyan','white');
  return getBashColor($_[1]||'def') unless exists $color_hash{$color};
  return "\e[".($shade eq "dark" ? '0' : '1').';3'.$color_hash{$color}.'m';
}


 sub fixUserWords{
   my $regex = '\b((?:'.join(')|(?:',@user_words).'))\b';
   #non case-sensitive
   return $str =~ s/$regex/\x{EFFF}$user_color$1$def_color\x{EFFF}/go;
}