ghc/driver/ghc-iface.lprl

   1 %************************************************************************
   2 %*                                                                      *
   3 \section[Driver-iface-thing]{Interface-file handling}
   4 %*                                                                      *
   5 %************************************************************************
   6
   7 \begin{code}
   8 %OldVersion = ();
   9 %Decl    = (); # details about individual definitions
  10 %Stuff   = (); # where we glom things together
  11 %HiExists      = ('old',-1,  'new',-1); # 1 <=> definitely exists; 0 <=> doesn't
  12 %HiHasBeenRead = ('old', 0,  'new', 0);
  13 %ModuleVersion = ('old', 0,  'new', 0);
  14
  15 %HiSections = ();
  16
  17 sub postprocessHiFile {
  18     local($hsc_hi,              # The iface info produced by hsc.
  19           $hifile_target,       # The name both of the .hi file we
  20                                 # already have and which we *might*
  21                                 # replace.
  22           $going_interactive) = @_;
  23
  24     local($new_hi) = "$Tmp_prefix.hi-new";
  25     local($show_hi_diffs) = $HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target;
  26
  27     print STDERR "*** New hi file follows...\n" if $Verbose;
  28     system("$Cat $hsc_hi 1>&2") if $Verbose;
  29
  30     &constructNewHiFile($hsc_hi, *hifile_target, $new_hi, $show_hi_diffs);
  31
  32     # run diff if they asked for it
  33     if ($show_hi_diffs) {
  34         if ( $HiDiff_flag eq 'usages' ) {
  35             # lots of near-useless info; but if you want it...
  36             &run_something("$Cmp -s $hifile_target $new_hi || $Diff $hifile_target $new_hi 1>&2 || exit 0",
  37                 "Diff'ing old and new .$HiSuffix files"); # NB: to stderr
  38         } else {
  39             # strip out usages, *then* run diff
  40             local($hi_before) = "$Tmp_prefix.hi-before";
  41             local($hi_after)  = "$Tmp_prefix.hi-now";
  42
  43             &deUsagifyHi($hifile_target, $hi_before);
  44             &deUsagifyHi($new_hi,        $hi_after);
  45
  46             &run_something("$Cmp -s $hi_before $hi_after || $Diff $hi_before $hi_after 1>&2 || exit 0",
  47                 "Diff'ing old and new .$HiSuffix files"); # NB: to stderr
  48         }
  49     }
  50
  51     # if we produced an interface file "no matter what",
  52     # print what we got on stderr (ToDo: honor -ohi flag)
  53     if ( $HiOnStdout ) {
  54         system("$Cat $new_hi 1>&2");
  55     } else {
  56         &run_something("$Cmp -s $hifile_target $new_hi || ( $Rm $hifile_target && $Cp $new_hi $hifile_target )",
  57            "Replace .$HiSuffix file, if changed");
  58     }
  59 }
  60
  61 sub deUsagifyHi {
  62     local($ifile,$ofile) = @_;
  63
  64     open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
  65     open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
  66
  67     # read up to _usages_ line
  68     $_ = <OLDHIF>;
  69     while ($_ ne '') {
  70         print NEWHIF $_ unless /^(__interface|import)/;
  71         $_ = <OLDHIF>;
  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           $show_hi_diffs) = @_;
  85     local($hiname,$hidir);
  86
  87     &readHiFile('new',$hsc_hi)        unless $HiHasBeenRead{'new'} == 1;
  88     if ($Specific_hi_file eq '') {  # -ohi is used even if  module name != stem of filename.
  89         ($hiname = $hifile_target) =~ s/([^\/]*\/)*(.*)\.$HiSuffix/$2/;
  90         if ($ModuleName{'new'} ne $hiname) {
  91           ($hidir  = $hifile_target) =~ s/([^\/]*\/)*.*\.$HiSuffix/$1/;
  92           $hifile_target = $hidir . $ModuleName{'new'} . ".$HiSuffix";
  93         }
  94     }
  95     &readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1;
  96
  97     open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n");
  98
  99     local(@decl_names) = ();    # Declarations in new module
 100     foreach $v (sort (keys %Decl)) {
 101         next unless $v =~ /^new:(.*$)/;
 102         push(@decl_names,$1);
 103     }
 104
 105     local($new_module_version) = &calcNewModuleVersion(@decl_names);
 106     print NEWHI "__interface ", $ModuleName{'new'}, " $new_module_version $ProjectVersionInt where\n";
 107
 108     print NEWHI $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
 109     print NEWHI $Stuff{'new:instance_modules'} unless $Stuff{'new:instance_modules'} eq '';
 110     print NEWHI $Stuff{'new:exports'};
 111     print NEWHI $Stuff{'new:fixities'} unless $Stuff{'new:fixities'} eq '';
 112     print NEWHI $Stuff{'new:instances'} unless $Stuff{'new:instances'} eq '';
 113
 114     foreach $v (@decl_names) {
 115         &printNewItemVersion(NEWHI, $v, $new_module_version, $show_hi_diffs);           # Print new version number
 116         print NEWHI $Decl{"new:$v"};            # Print the new decl itself
 117     }
 118
 119     close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n");
 120 }
 121 \end{code}
 122
 123 Read the .hi file made by the compiler, or the old one.
 124 All the declarations in the file are stored in
 125
 126         $Decl{"$mod:$v"}
 127
 128 where $mod is "new" or "old", depending on whether it's the new or old
 129         .hi file that's being read.
 130
 131 and $v is
 132         for values v    "v"
 133         for tycons T    "type T" or "data T"
 134         for classes C   "class C"
 135
 136
 137 \begin{code}
 138 sub readHiFile {
 139     local($mod,             # module to read; can be special tag 'old'
 140                             # (old .hi file for module being compiled) or
 141                             # 'new' (new proto-.hi file for...)
 142           $hifile) = @_;    # actual file to read
 143
 144     # info about the old version of this module's interface
 145     $HiExists{$mod}      = -1; # 1 <=> definitely exists; 0 <=> doesn't
 146     $HiHasBeenRead{$mod} = 0;
 147     $ModuleVersion{$mod} = 0;
 148     $Stuff{"$mod:instance_modules"} = '';
 149     $Stuff{"$mod:usages"}           = ''; # stuff glommed together
 150     $Stuff{"$mod:exports"}          = '';
 151     $Stuff{"$mod:fixities"}         = '';
 152     $Stuff{"$mod:instances"}        = '';
 153     $Stuff{"$mod:declarations"}     = '';
 154
 155     if (! -f $hifile) { # no pre-existing .hi file
 156         $HiExists{$mod} = 0;
 157         return();
 158     }
 159
 160     open(HIFILE, "< $hifile") || &tidy_up_and_die(1,"Can't open $hifile (read)\n");
 161     $HiExists{$mod} = 1;
 162     hi_line: while (<HIFILE>) {
 163         next if /^ *$/; # blank line
 164
 165         if ( /^__interface ([A-Z]\S*) (\d+)/ ) {
 166             if ( $mod ne 'new' ) {
 167                 $ModuleVersion{$mod} = $2;
 168             }
 169             $ModuleName{$mod}    = $1; # used to decide name of iface file.
 170
 171         } elsif ( /^import / ) {
 172             $Stuff{"$mod:usages"} .= $_; # save the whole thing
 173
 174         } elsif ( /^__instimport/ ) {
 175             $Stuff{"$mod:instance_modules"} .= $_;
 176
 177         } elsif ( /^__export/ ) {
 178             $Stuff{"$mod:exports"} .= $_;
 179
 180         } elsif ( /^infix(r|l)? / ) {
 181             $Stuff{"$mod:fixities"} .= $_;
 182
 183         } elsif ( /^instance / ) {
 184             $Stuff{"$mod:instances"} .= $_;
 185
 186         } elsif ( /^--.*/ ) { # silently ignore comment lines.
 187             ;
 188         } else {  # We're in a declaration
 189
 190         # Strip off the initial version number, if any
 191            if ( /^([0-9]+)\s+(.*\n)/ ) {
 192
 193                 # The "\n" is because we need to keep the newline at
 194                 # the end, so that it looks the same as if there's no version
 195                 # number and this if statement doesn't fire.
 196
 197                 # So there's an initial version number
 198                 $version = $1;
 199                 $_ = $2;
 200            }
 201
 202            if ( /^type\s+(\S+)/ ) {
 203                         # Type declaration
 204                 $current_name = "type $1";
 205                 $Decl{"$mod:$current_name"} = $_;
 206                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 207
 208            } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?(\S+)\s+/ ) {
 209                         # Data declaration
 210                 $current_name = "data $3";
 211                 $Decl{"$mod:$current_name"} = $_;
 212                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 213
 214            } elsif ( /^class\s+(\{[^{}]*\}\s+=>\s+)?(\S+)\s+/ ) {
 215                         # Class declaration
 216                 # must be wary of => bit matching after "where"...
 217                 # ..hence the [^{}] part
 218                 # NB: a class decl may not have a where part at all
 219                 $current_name = "class $2";
 220                 $Decl{"$mod:$current_name"} = $_;
 221                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 222
 223            } elsif ( /^(\S+)\s+::\s+/ ) {
 224                         # Value declaration
 225                 $current_name = $1;
 226                 $Decl{"$mod:$current_name"} = $_;
 227                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 228
 229             } else { # Continuation line
 230                 print STDERR "$Pgm:junk old iface line?:$_";
 231                 # $Decl{"$mod:$current_name"} .= $_
 232             }
 233
 234        }
 235     }
 236
 237     close(HIFILE) || &tidy_up_and_die(1,"Failed reading from $hifile\n");
 238     $HiHasBeenRead{$mod} = 1;
 239 }
 240 \end{code}
 241
 242 \begin{code}
 243 sub calcNewModuleVersion {
 244     local (@decl_names) = @_;
 245
 246     return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0;
 247         # could use "time()" as initial version; if a module existed, then was deleted,
 248         # then comes back, we don't want the resurrected one to have an
 249         # lower version number than the original (in case there are any
 250         # lingering references to the original in other .hi files).
 251
 252     local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two
 253     local($changed_version)   = $unchanged_version + 1;
 254
 255     foreach $t ( 'usages' , 'exports', 'instance_modules', 'instances', 'fixities' ) {
 256         return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"};
 257     }
 258
 259 # Decl need separate treatment; they aren't in $Stuff
 260     foreach $v (@decl_names) {
 261         return(&mv_change($changed_version,"$v changed")) if $Decl{"old:$v"} ne $Decl{"new:$v"};
 262     }
 263
 264     print STDERR "$Pgm: module version unchanged at $unchanged_version\n";
 265     return($unchanged_version);
 266 }
 267
 268 sub mv_change {
 269     local($mv, $str) = @_;
 270
 271     print STDERR "$Pgm: module version changed to $mv; reason: $str\n";
 272     return($mv);
 273 }
 274
 275 sub printNewItemVersion {
 276     local($hifile, $item, $mod_version, $show_hi_diffs) = @_;
 277     local($idecl) = $Decl{"new:$item"};
 278
 279
 280     if (! defined($Decl{"old:$item"})) {        # Old decl doesn't exist
 281         if ($show_hi_diffs) {print STDERR "new: $item\n";}
 282         print $hifile  "$mod_version ";         # Use module version
 283
 284     } elsif (! defined($OldVersion{"$item"}) ) {
 285         if ($show_hi_diffs) {print STDERR "$item: no old version?!\n";}
 286         print $hifile  "$mod_version ";                 # Use module version
 287
 288     } elsif ($idecl ne $Decl{"old:$item"})  {   # Old decl differs from new decl
 289         local($odecl) = $Decl{"old:$item"};
 290         if ($show_hi_diffs) {print STDERR "changed: $item\nOld: $odecl", "New: $idecl";}
 291         print $hifile  "--old: ", $OldVersion{"$item"}, " $odecl"
 292                         if $Keep_HiDiffs;         # show old in interface file
 293         print $hifile  "$mod_version ";           # Use module version
 294
 295     } else {                                    # Identical decls, so use old version number
 296         #if ($show_hi_diffs) {print STDERR "$item: unchanged\n";}
 297         print $hifile  $OldVersion{"$item"}, " ";
 298     }
 299     return;
 300 }
 301 \end{code}
 302
 303 \begin{code}
 304 # make "require"r happy...
 305 1;
 306 \end{code}