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