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.
  53     if ( $HiOnStdout ) {
  54         if ( $HiWith ne '' ) {
  55             # output some of the sections
  56             local($hi_after)  = "$Tmp_prefix.hi-now";
  57
  58             foreach $hi ( split(' ',$HiWith) ) {
  59                 $HiSection{$hi} = 1;
  60             }
  61             &hiSectionsOnly($new_hi, $hi_after);
  62
  63             system("$Cat $hi_after 1>&2 ; $Rm $hi_after; ");
  64         } else {
  65             system("$Cat $new_hi 1>&2");
  66         }
  67     } else {
  68         &run_something("$Cmp -s $hifile_target $new_hi || ( $Rm $hifile_target && $Cp $new_hi $hifile_target )",
  69            "Replace .$HiSuffix file, if changed");
  70     }
  71 }
  72
  73 sub deUsagifyHi {
  74     local($ifile,$ofile) = @_;
  75
  76     open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
  77     open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
  78
  79     # read up to _usages_ line
  80     $_ = <OLDHIF>;
  81     while ($_ ne '') {
  82         print NEWHIF $_ unless /^(__interface|import)/;
  83         $_ = <OLDHIF>;
  84     }
  85
  86     close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n");
  87     close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n");
  88 }
  89 \end{code}
  90
  91 \begin{code}
  92 sub hiSectionsOnly {
  93     local($ifile,$ofile) = @_;
  94
  95     open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
  96     open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
  97
  98     # read up to _usages_ line
  99     $_ = <OLDHIF>;
 100     while ($_ ne '' ) {
 101         if ( /^__export/ && $HiSection {'exports'}           ||
 102              /^import /  && $HiSection {'imports'}           ||
 103              /^\d+ ([^ ]+ :: |type |data |class |newtype )/  && $HiSection {'declarations'} ||
 104              /^instance / && $HiSection {'instances'} ) {
 105              print NEWHIF $_;
 106              $_ = <OLDHIF>;
 107         } else {
 108           $_ = <OLDHIF>;
 109         }
 110     }
 111
 112     close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n");
 113     close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n");
 114 }
 115 \end{code}
 116
 117 \begin{code}
 118 sub constructNewHiFile {
 119     local($hsc_hi,          # The iface info produced by hsc.
 120           *hifile_target,   # Pre-existing .hi filename (if it exists)
 121           $new_hi,          # Filename for new one
 122           $show_hi_diffs) = @_;
 123     local($hiname,$hidir);
 124     local($mod_name_dec);
 125
 126     &readHiFile('new',$hsc_hi)        unless $HiHasBeenRead{'new'} == 1;
 127
 128     # Sigh, we need decode the module name found in the interface file
 129     # since that's the (base)name we want to use when outputting the
 130     # interface file.
 131     $mod_name_dec = $ModuleName{'new'};
 132     $mod_name_dec =~ s/zz/z/g;
 133     $mod_name_dec =~ s/ZZ/Z/g;
 134
 135     if ($Specific_hi_file eq '') {  # -ohi is used even if  module name != stem of filename.
 136         ($hiname = $hifile_target) = $1 if  $hifile_target =~ /\/?([^\/]+)\.$HiSuffix$/;
 137         if ( $mod_name_dec ne $hiname ) {
 138           $hidir = '';
 139           # strip off basename only if we've got a dirname.
 140           ($hidir  = $hifile_target) =~ s/(.*\/)[^\/]*$/$1/
 141                       if ( $hifile_target =~ /\/$hiname\.$HiSuffix/ );
 142           $hifile_target = $hidir . $mod_name_dec . ".$HiSuffix";
 143         }
 144     }
 145     &readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1;
 146
 147     open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n");
 148
 149     local(@decl_names) = ();    # Declarations in new module
 150     foreach $v (sort (keys %Decl)) {
 151         next unless $v =~ /^new:(.*$)/;
 152         push(@decl_names,$1);
 153     }
 154
 155     local($new_module_version) = &calcNewModuleVersion(@decl_names);
 156     print NEWHI "__interface ", $PackageName{'new'}, $ModuleName{'new'}, " $new_module_version $Orphan{'new'} $ProjectVersionInt where\n";
 157     print NEWHI $Stuff{'new:exports'};
 158     print NEWHI $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
 159     print NEWHI $Stuff{'new:instances'} unless $Stuff{'new:instances'} eq '';
 160
 161     foreach $v (@decl_names) {
 162         &printNewItemVersion(NEWHI, $v, $new_module_version, $show_hi_diffs);           # Print new version number
 163         print NEWHI $Decl{"new:$v"};            # Print the new decl itself
 164     }
 165     print NEWHI $Stuff{'new:rules'} unless $Stuff{'new:rules'} eq '';
 166     print NEWHI $Stuff{'new:deprecations'} unless $Stuff{'new:deprecations'} eq '';
 167
 168     close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n");
 169 }
 170 \end{code}
 171
 172 Read the .hi file made by the compiler, or the old one.
 173 All the declarations in the file are stored in
 174
 175         $Decl{"$mod:$v"}
 176
 177 where $mod is "new" or "old", depending on whether it's the new or old
 178         .hi file that's being read.
 179
 180 and $v is
 181         for values v    "v"
 182         for tycons T    "type T" or "data T"
 183         for classes C   "class C"
 184
 185
 186 \begin{code}
 187 sub readHiFile {
 188     local($mod,             # module to read; can be special tag 'old'
 189                             # (old .hi file for module being compiled) or
 190                             # 'new' (new proto-.hi file for...)
 191           $hifile) = @_;    # actual file to read
 192
 193     # info about the old version of this module's interface
 194     $HiExists{$mod}      = -1; # 1 <=> definitely exists; 0 <=> doesn't
 195     $HiHasBeenRead{$mod} = 0;
 196     $ModuleVersion{$mod} = 0;
 197     $Stuff{"$mod:usages"}           = ''; # stuff glommed together
 198     $Stuff{"$mod:exports"}          = '';
 199     $Stuff{"$mod:instances"}        = '';
 200     $Stuff{"$mod:declarations"}     = '';
 201     $Stuff{"$mod:rules"}            = '';
 202     $Stuff{"$mod:deprecations"}     = '';
 203
 204     if (! -f $hifile) { # no pre-existing .hi file
 205         $HiExists{$mod} = 0;
 206         return();
 207     }
 208
 209     open(HIFILE, "< $hifile") || &tidy_up_and_die(1,"Can't open $hifile (read)\n");
 210     $HiExists{$mod} = 1;
 211     hi_line: while (<HIFILE>) {
 212         next if /^ *$/; # blank line
 213
 214         if ( /^__interface ("[A-Za-z]*"\s*)([A-Z]\S*)\s+(\d+)?\s*(\!)?/ ) {
 215             if ( $mod ne 'new' ) {
 216                 # Reading old .hi file
 217                 $ModuleVersion{$mod} = $3;
 218             }
 219
 220             $PackageName{$mod} = $1;
 221             $ModuleName{$mod}  = $2; # used to decide name of iface file.
 222             $Orphan{$mod}      = $4;
 223                 # optional "!" indicates that the
 224                 # module contains orphan rules or instance decls
 225
 226         } elsif ( /^import / ) {
 227             $Stuff{"$mod:usages"} .= $_; # save the whole thing
 228
 229         } elsif ( /^__export/ ) {
 230             $Stuff{"$mod:exports"} .= $_;
 231
 232         } elsif ( /^instance / ) {
 233             $Stuff{"$mod:instances"} .= $_;
 234
 235         } elsif ( /^{-## __R / ) {
 236             $Stuff{"$mod:rules"} .= $_;
 237
 238         } elsif ( /^{-## __D / ) {
 239             $Stuff{"$mod:deprecations"} .= $_;
 240
 241         } elsif ( /^-[-]+ .*/ ) { # silently ignore comment lines.
 242             ;
 243         } else {  # We're in a declaration
 244
 245         # Strip off the initial version number, if any
 246            if ( /^([0-9]+)\s+(.*\n)/ ) {
 247
 248                 # The "\n" is because we need to keep the newline at
 249                 # the end, so that it looks the same as if there's no version
 250                 # number and this if statement doesn't fire.
 251
 252                 # So there's an initial version number
 253                 $version = $1;
 254                 $_ = $2;
 255            }
 256
 257            if ( /^type\s+(\S+)/ ) {
 258                         # Type declaration
 259                 $current_name = "type $1";
 260                 $Decl{"$mod:$current_name"} = $_;
 261                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 262
 263            } elsif ( /^(newtype|data)\s+({.*}\s+=>\s+)?(\S+)\s+/ ) {
 264                         # Data declaration
 265                         # The (...)? parts skips over the context of a data decl
 266                         # to find the name of the type constructor.  The curly
 267                         # brackets are part of the iface file syntax for contexts
 268                 $current_name = "data $3";
 269                 $Decl{"$mod:$current_name"} = $_;
 270                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 271
 272            } elsif ( /^class\s+(\{[^{}]*\}\s+=>\s+)?(\S+)\s+/ ) {
 273                         # Class declaration
 274                 # must be wary of => bit matching after "where"...
 275                 # ..hence the [^{}] part
 276                 # NB: a class decl may not have a where part at all
 277                 $current_name = "class $2";
 278                 $Decl{"$mod:$current_name"} = $_;
 279                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 280
 281            } elsif ( /^infix(r|l)?\s+[0-9]\s+(\S+)/ ) {
 282                     # fixity declaration
 283                 $current_name = "fixity $2";
 284                 $Decl{"$mod:$current_name"} = $_;
 285                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 286
 287            } elsif ( /^(\S+)\s+::\s+/ ) {
 288                         # Value declaration
 289                 $current_name = $1;
 290                 $Decl{"$mod:$current_name"} = $_;
 291                 if ($mod eq "old") { $OldVersion{$current_name} = $version; }
 292
 293             } else { # Continuation line
 294                 # print STDERR "$Pgm:junk old iface line?:$_";
 295                 $Decl{"$mod:$current_name"} .= $_
 296             }
 297
 298        }
 299     }
 300
 301     close(HIFILE) || &tidy_up_and_die(1,"Failed reading from $hifile\n");
 302     $HiHasBeenRead{$mod} = 1;
 303 }
 304 \end{code}
 305
 306 \begin{code}
 307 sub calcNewModuleVersion {
 308     local (@decl_names) = @_;
 309
 310     return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0;
 311         # could use "time()" as initial version; if a module existed, then was deleted,
 312         # then comes back, we don't want the resurrected one to have an
 313         # lower version number than the original (in case there are any
 314         # lingering references to the original in other .hi files).
 315
 316     local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two
 317     local($changed_version)   = $unchanged_version + 1;
 318
 319     if ($Orphan{'old'} ne $Orphan{'new'}) {
 320         return(&mv_change($changed_version, "orphan-hood changed"));
 321     }
 322
 323     foreach $t ( 'usages' , 'exports', 'instances', 'fixities', 'rules', 'deprecations' ) {
 324         return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"};
 325     }
 326
 327 # Decl need separate treatment; they aren't in $Stuff
 328     foreach $v (@decl_names) {
 329         return(&mv_change($changed_version,"$v changed")) if $Decl{"old:$v"} ne $Decl{"new:$v"};
 330     }
 331
 332     print STDERR "$Pgm: module version unchanged at $unchanged_version\n"
 333         if $Verbose;
 334     return($unchanged_version);
 335 }
 336
 337 sub mv_change {
 338     local($mv, $str) = @_;
 339
 340     print STDERR "$Pgm: module version changed to $mv; reason: $str\n"
 341         if $Verbose;
 342     return($mv);
 343 }
 344
 345 sub printNewItemVersion {
 346     local($hifile, $item, $mod_version, $show_hi_diffs) = @_;
 347     local($idecl) = $Decl{"new:$item"};
 348
 349
 350     if (! defined($Decl{"old:$item"})) {        # Old decl doesn't exist
 351         if ($show_hi_diffs) {print STDERR "new: $item\n";}
 352         print $hifile  "$mod_version ";         # Use module version
 353
 354     } elsif (! defined($OldVersion{"$item"}) ) {
 355         if ($show_hi_diffs) {print STDERR "$item: no old version?!\n";}
 356         print $hifile  "$mod_version ";                 # Use module version
 357
 358     } elsif ($idecl ne $Decl{"old:$item"})  {   # Old decl differs from new decl
 359         local($odecl) = $Decl{"old:$item"};
 360         if ($show_hi_diffs) {print STDERR "changed: $item\nOld: $odecl", "New: $idecl";}
 361         print $hifile  "--old: ", $OldVersion{"$item"}, " $odecl"
 362                         if $Keep_HiDiffs;         # show old in interface file
 363         print $hifile  "$mod_version ";           # Use module version
 364
 365     } else {                                    # Identical decls, so use old version number
 366         #if ($show_hi_diffs) {print STDERR "$item: unchanged\n";}
 367         print $hifile  $OldVersion{"$item"}, " ";
 368     }
 369     return;
 370 }
 371 \end{code}
 372
 373 \begin{code}
 374 # make "require"r happy...
 375 1;
 376 \end{code}