ghc/driver/ghc-iface.lprl

   1 %************************************************************************
   2 %*                                                                      *
   3 \section[Driver-iface-thing]{Interface-file handling}
   4 %*                                                                      *
   5 %************************************************************************
   6
   7 \begin{code}
   8 sub postprocessHiFile {
   9     local($hsc_hi,              # The iface info produced by hsc.
  10           $hifile_target,       # The name both of the .hi file we
  11                                 # already have and which we *might*
  12                                 # replace.
  13           $going_interactive) = @_;
  14
  15     local($new_hi) = "$Tmp_prefix.hi-new";
  16
  17 #   print STDERR `$Cat $hsc_hi`;
  18
  19     &constructNewHiFile($hsc_hi, $hifile_target, $new_hi);
  20
  21     # run diff if they asked for it
  22     if ($HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target) {
  23         if ( $HiDiff_flag eq 'usages' ) {
  24             # lots of near-useless info; but if you want it...
  25             &run_something("$Cmp -s $hifile_target $new_hi || $Diff $hifile_target $new_hi 1>&2 || exit 0",
  26                 "Diff'ing old and new .$HiSuffix files"); # NB: to stderr
  27         } else {
  28             # strip out usages, *then* run diff
  29             local($hi_before) = "$Tmp_prefix.hi-before";
  30             local($hi_after)  = "$Tmp_prefix.hi-now";
  31
  32             &deUsagifyHi($hifile_target, $hi_before);
  33             &deUsagifyHi($new_hi,        $hi_after);
  34
  35             &run_something("$Cmp -s $hi_before $hi_after || $Diff $hi_before $hi_after 1>&2 || exit 0",
  36                 "Diff'ing old and new .$HiSuffix files"); # NB: to stderr
  37         }
  38     }
  39
  40     # if we produced an interface file "no matter what",
  41     # print what we got on stderr (ToDo: honor -ohi flag)
  42     if ( $HiOnStdout ) {
  43         print STDERR `$Cat $new_hi`;
  44     } else {
  45         &run_something("$Cmp -s $hifile_target $new_hi || ( $Rm $hifile_target && $Cp $new_hi $hifile_target )",
  46            "Replace .$HiSuffix file, if changed");
  47     }
  48 }
  49
  50 sub deUsagifyHi {
  51     local($ifile,$ofile) = @_;
  52
  53     open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
  54     open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
  55
  56     # read up to __usages__ line
  57     $_ = <OLDHIF>;
  58     while ($_ ne '' && ! /^__usages__/) {
  59         print NEWHIF $_ unless /^(interface |\{-# GHC_PRAGMA)/;
  60         $_ = <OLDHIF>;
  61     }
  62     if ( $_ ne '' ) {
  63         # skip to next __<anything> line
  64         $_ = <OLDHIF>;
  65         while ($_ ne '' && ! /^__/) { $_ = <OLDHIF>; }
  66
  67         # print the rest
  68         while ($_ ne '') {
  69             print NEWHIF $_;
  70             $_ = <OLDHIF>;
  71         }
  72     }
  73
  74     close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n");
  75     close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n");
  76 }
  77 \end{code}
  78
  79 \begin{code}
  80 sub constructNewHiFile {
  81     local($hsc_hi,          # The iface info produced by hsc.
  82           $hifile_target,   # Pre-existing .hi filename (if it exists)
  83           $new_hi) = @_;    # Filename for new one
  84
  85     &readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1;
  86     &readHiFile('new',$hsc_hi)        unless $HiHasBeenRead{'new'} == 1;
  87
  88     open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n");
  89
  90     local($new_module_version) = &calcNewModuleVersion();
  91     print NEWHI "interface ", $ModuleName{'new'}, " $new_module_version\n";
  92
  93     print NEWHI "__usages__\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
  94
  95     local(@version_keys) = sort (keys %Version);
  96     local($num_ver_things) = 0;
  97     foreach $v (@version_keys) {
  98         next unless $v =~ /^new:(.*$)/;
  99         last if $num_ver_things >= 1;
 100         $num_ver_things++;
 101     }
 102
 103     print NEWHI "__versions__\n" unless $num_ver_things < 1;
 104     foreach $v (@version_keys) {
 105         next unless $v =~ /^new:(.*$)/;
 106         $v = $1;
 107
 108         &printNewItemVersion($v, $new_module_version), "\n";
 109     }
 110
 111     print NEWHI "__exports__\n";
 112     print NEWHI $Stuff{'new:exports'};
 113
 114     if ( $Stuff{'new:instance_modules'} ) {
 115         print NEWHI "__instance_modules__\n";
 116         print NEWHI $Stuff{'new:instance_modules'};
 117     }
 118
 119     if ( $Stuff{'new:fixities'} ) {
 120         print NEWHI "__fixities__\n";
 121         print NEWHI $Stuff{'new:fixities'};
 122     }
 123
 124     if ( $Stuff{'new:declarations'} ) {
 125         print NEWHI "__declarations__\n";
 126         print NEWHI $Stuff{'new:declarations'};
 127     }
 128
 129     if ( $Stuff{'new:instances'} ) {
 130         print NEWHI "__instances__\n";
 131         print NEWHI $Stuff{'new:instances'};
 132     }
 133
 134     if ( $Stuff{'new:pragmas'} ) {
 135         print NEWHI "__pragmas__\n";
 136         print NEWHI $Stuff{'new:pragmas'};
 137     }
 138
 139     close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n");
 140 }
 141 \end{code}
 142
 143 \begin{code}
 144 %Version = ();
 145 %Decl    = (); # details about individual definitions
 146 %Stuff   = (); # where we glom things together
 147 %HiExists      = ('old',-1,  'new',-1); # 1 <=> definitely exists; 0 <=> doesn't
 148 %HiHasBeenRead = ('old', 0,  'new', 0);
 149 %ModuleVersion = ('old', 0,  'new', 0);
 150
 151 sub readHiFile {
 152     local($mod,             # module to read; can be special tag 'old'
 153                             # (old .hi file for module being compiled) or
 154                             # 'new' (new proto-.hi file for...)
 155           $hifile) = @_;    # actual file to read
 156
 157     # info about the old version of this module's interface
 158     $HiExists{$mod}      = -1; # 1 <=> definitely exists; 0 <=> doesn't
 159     $HiHasBeenRead{$mod} = 0;
 160     $ModuleVersion{$mod} = 0;
 161     $Stuff{"$mod:usages"}           = ''; # stuff glommed together
 162     $Stuff{"$mod:exports"}          = '';
 163     $Stuff{"$mod:instance_modules"} = '';
 164     $Stuff{"$mod:instances"}        = '';
 165     $Stuff{"$mod:fixities"}         = '';
 166     $Stuff{"$mod:declarations"}     = '';
 167     $Stuff{"$mod:pragmas"}          = '';
 168
 169     if (! -f $hifile) { # no pre-existing .hi file
 170         $HiExists{$mod} = 0;
 171         return();
 172     }
 173
 174     open(HIFILE, "< $hifile") || &tidy_up_and_die(1,"Can't open $hifile (read)\n");
 175     $HiExists{$mod} = 1;
 176     local($now_in) = '';
 177     hi_line: while (<HIFILE>) {
 178         next if /^ *$/; # blank line
 179         next if /\{-# GHC_PRAGMA INTERFACE VERSION 20 #-\}/;
 180
 181         # avoid pre-1.3 interfaces
 182 #print STDERR "now_in:$now_in:$_";
 183         if ( /\{-# GHC_PRAGMA INTERFACE VERSION . #-\}/ ) {
 184             $HiExists{$mod} = 0;
 185             last hi_line;
 186         }
 187
 188         if ( /^interface ([A-Z]\S*) (\d+)/ ) {
 189             $ModuleName{$mod}    = $1; # not sure this is used much...
 190             $ModuleVersion{$mod} = $2;
 191
 192         } elsif ( /^interface ([A-Z]\S*)/ && $mod eq 'new' ) { # special case: no version
 193             $ModuleName{'new'} = $1;
 194
 195         } elsif ( /^__([a-z]+)__$/ ) {
 196             $now_in = $1;
 197
 198         } elsif ( $now_in eq 'usages' && /^(\S+)\s+(\d+)\s+:: (.*)/ ) {
 199             $Stuff{"$mod:usages"} .= $_; # save the whole thing
 200
 201         } elsif ( $now_in eq 'versions' && /^(\S+) (\d+)/ ) {
 202             local($item) = $1;
 203             local($n)    = $2;
 204 #print STDERR "version read:item=$item, n=$n, line=$_";
 205             $Version{"$mod:$item"} = $n;
 206
 207         } elsif ( $now_in eq 'versions' && /^(\S+)/ && $mod eq 'new') { # doesn't have versions
 208             local($item) = $1;
 209 #print STDERR "new version read:item=$item, line=$_";
 210             $Version{"$mod:$item"} = 'y'; # stub value...
 211
 212         } elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities|pragmas)$/ ) {
 213             $Stuff{"$mod:$1"} .= $_; # just save it up
 214
 215         } elsif ( $now_in eq 'declarations' ) { # relatively special treatment needed...
 216             $Stuff{"$mod:declarations"} .= $_; # just save it up
 217
 218             if ( /^[A-Z][A-Za-z0-9_']*\.(\S+)\s+::\s+/ ) {
 219                 $Decl{"$mod:$1"} = $_;
 220
 221             } elsif ( /^type\s+[A-Z][A-Za-z0-9_']*\.(\S+)/ ) {
 222                 $Decl{"$mod:$1"} = $_;
 223
 224             } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) {
 225                 $Decl{"$mod:$3"} = $_;
 226
 227             } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+.*where\s+\{.*\};/ ) {
 228                 $Decl{"$mod:$2"} = $_; # must be wary of => bit matching after "where"...
 229             } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) {
 230                 $Decl{"$mod:$2"} = $_;
 231
 232             } else { # oh, well...
 233                 print STDERR "$Pgm: decl line didn't match?\n$_";
 234             }
 235
 236         } else {
 237             print STDERR "$Pgm:junk old iface line?:section:$now_in:$_";
 238         }
 239     }
 240
 241 #   foreach $i ( sort (keys %Decl)) {
 242 #       print STDERR "$i: ",$Decl{$i}, "\n";
 243 #   }
 244
 245     close(HIFILE) || &tidy_up_and_die(1,"Failed reading from $hifile\n");
 246     $HiHasBeenRead{$mod} = 1;
 247 }
 248 \end{code}
 249
 250 \begin{code}
 251 sub calcNewModuleVersion {
 252
 253     return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0;
 254         # could use "time()" as initial version; if a module existed, then was deleted,
 255         # then comes back, we don't want the resurrected one to have an
 256         # lower version number than the original (in case there are any
 257         # lingering references to the original in other .hi files).
 258
 259     local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two
 260     local($changed_version)   = $unchanged_version + 1;
 261
 262     return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'};
 263
 264     foreach $t ( 'exports', 'instance_modules', 'instances', 'fixities', 'declarations', 'pragmas' ) {
 265         return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"};
 266     }
 267
 268     return($unchanged_version);
 269 }
 270
 271 sub mv_change {
 272     local($mv, $str) = @_;
 273
 274     print STDERR "$Pgm: module version changed to $mv; reason: $str\n";
 275     return($mv);
 276 }
 277
 278 sub printNewItemVersion {
 279     local($item, $mod_version) = @_;
 280
 281     if (! defined($Decl{"new:$item"}) ) {
 282 # it's OK, because the thing is almost-certainly wired-in
 283 #       print STDERR "$item: no decl?! (nothing into __versions__)\n";
 284         return;
 285     }
 286
 287     local($idecl) = $Decl{"new:$item"};
 288
 289     if (! defined($Decl{"old:$item"})) {
 290         print STDERR "new: $item\n";
 291         print NEWHI  "$item $mod_version\n";
 292     } elsif ($idecl ne $Decl{"old:$item"})  {
 293         print STDERR "changed: $item\n";
 294         print NEWHI  "$item $mod_version\n";
 295     } elsif (! defined($Version{"old:$item"}) ) {
 296         print STDERR "$item: no old version?!\n"
 297     } else {
 298         print NEWHI  "$item ", $Version{"old:$item"}, "\n";
 299     }
 300     return;
 301 }
 302 \end{code}
 303
 304 \begin{code}
 305 sub findHiChanges {
 306     local($hsc_hi,              # The iface info produced by hsc.
 307           $hifile_target) = @_; # Pre-existing .hi filename (if it exists)
 308 }
 309 \end{code}
 310
 311 \begin{code}
 312 # make "require"r happy...
 313 1;
 314 \end{code}