#!/usr/bin/env bash

# This script checks MLton's basis library implementation for type errors using
# SML/NJ.

set -e 

name=`basename $0`
dir=`dirname $0`
root=`cd $dir/.. && pwd`
here=`pwd`
basis="$root/basis-library/basis.sml"

die () {
	echo >&2 "$1"
	exit 1
}

usage () {
	die "usage: $name [{2002|1997|...} [file.sml | file.cm]]"
}

rewrite () {
	sed 's/_build_const\(.*\);/(PRIM\1)/' |
	sed 's/_build_const/PRIM/' |
	sed 's/_const\(.*\);/(PRIM\1)/' |
	sed 's/_const/PRIM/' |
	sed 's/_prim\(.*\);/(PRIM\1)/' |
	sed 's/_prim/PRIM/' |
	sed 's/_import\(.*\);/(PRIM\1)/' |
	sed 's/_import/PRIM/' |
	sed 's/fun bigIntConstant x = x/fun bigIntConstant(x:smallInt):bigInt = raise Fail "bigIntConstant"/' |
	sed 's/#"\([^"\]*\(\\.[^"\]*\)*\)"/#ZZZ\1ZZZ/g' |
	sed 's/\([^\]\)"\([^"\]*\(\\.[^"\]*\)*\)"/\1(STRING_CONST "\2")/g' |
	sed 's/#ZZZ\(\(.\)\|\(..\)\|\([^Z][^Z][^Z].*\)\)ZZZ/#"\1"/g' |
        sed 's/(\*#line 0.0 \(.*\)\*)/(*#line 0.0 "\1"*)/'
}

function rewrite_file() {
	f="$1"
	if [ ! -r "$f" ]; then
		die "error: $f is missing"
	fi
(
	echo "(*#line 0.0 $f*)"
	cat $f
) | rewrite
}

rewrite_files () {
	files=`cat $1 | grep -v "^#" | grep -v overload | grep -v Group`
	for f in $files; do
		if [ ! -r "$f" ]; then
			die "error: $f is missing"
		fi
	done
	(for f in $files; do
		echo "(*#line 0.0 $f*)"
	        cat $f
	done | rewrite)
}

SML_FILE=""
CM_FILE=""
case "$#" in
0)
	LIB='2002'
	;;
1)
	LIB=$1
	;;
2)
	LIB=$1
	if [ "$2" == "`basename $2 .sml`.sml" -a -r "$2" ]; then
		SML_FILE=$2
	elif [ "$2" == "`basename $2 .cm`.cm" -a -r "$2" ]; then
		CM_FILE=$2
	else usage
        fi
        ;;
*)
	usage
	;;
esac

if [ ! -r "$root/basis-library/libs/basis-$LIB/bind" ]; then
	echo >&2 "invalid lib: $LIB"
	usage
fi

LIB="basis-$LIB"

rm -f $basis
cat >>$basis <<-EOF
	val _ = SMLofNJ.Internals.GC.messages false
        val _ = #set CM.Control.verbose false
        val _ =
   	   let
	      open Control
              open MC
	   in
              polyEqWarn := false
	      ; bindNonExhaustiveWarn := true
	      ; matchNonExhaustiveWarn := true
	      ; matchNonExhaustiveError := true
	      ; matchRedundantWarn := true
	      ; matchRedundantError := false
	   end
        ;
	fun PRIM (x:char vector) = raise Fail "_prim"
	fun STRING_CONST (x:string) : char vector = raise Fail "<string constant>"
        structure Types = struct
          type 'a array = 'a array
          datatype bool = datatype bool
          type char = char
          type exn = exn
          type int8 = Int32.int
          type int16 = Int32.int
          type int32 = Int32.int
          type int64 = IntInf.int
          type intInf = IntInf.int
          type int = int32
          datatype list = datatype list
          datatype pointer = T
          type real32 = real
	  type real64 = real
          datatype ref = datatype ref
          datatype preThread = T
          datatype thread = T
	  datatype 'a weak = T of 'a
          type word8 = Word8.word
	  type word16 = Word32.word
          type word32 = Word32.word
	  datatype word64 = T
          type 'a vector = 'a vector
          
          datatype 'a option = T
        end
        signature GENERAL = sig end
        structure General = struct end
        signature OPTION = sig end
        structure Option = struct end
        signature BOOL = sig end
        structure Bool = struct end
        signature SML90 = sig end
        structure SML90 = struct end
        signature CHAR = sig end
        structure Char = struct end
        structure WideChar = struct end
        signature STRING = sig end
        structure String = struct end
        structure WideString = struct end
        signature SUBSTRING = sig end
        structure Substring = struct end
        structure WideSubstring = struct end
        signature STRING_CVT = sig end
        structure StringCvt = struct end
        signature BYTE = sig end
        structure Byte = struct end
        signature INTEGER = sig end
        structure Int = struct end
        structure Int8 = struct end
        structure Int16 = struct end
        structure Int32 = struct end
        structure Int64 = struct end
        structure FixedInt = struct end
        structure LargeInt = struct end
        structure Position = struct end
        signature INT_INF = sig end
        structure IntInf = struct end
        signature WORD = sig end
        structure Word = struct end
        structure Word8 = struct end
        structure Word16 = struct end
        structure Word32 = struct end
        structure Word64 = struct end
        structure LargeWord = struct end
        structure SysWord = struct end
        signature PACK_WORD = sig end
        structure Pack8Big = struct end
        structure Pack8Little = struct end
        structure Pack16Big = struct end
        structure Pack16Little = struct end
        structure Pack32Big = struct end
        structure Pack32Little = struct end
        structure Pack64Big = struct end
        structure Pack64Little = struct end
        signature REAL = sig end
        structure Real = struct end
        structure Real32 = struct end
        structure Real64 = struct end
        structure Real128 = struct end
        structure LargeReal = struct end
        signature MATH = sig end
        structure Math = struct end
        signature IEEE_REAL = sig end
        structure IEEEReal = struct end
        signature PACK_REAL = sig end
        structure PackRealBig = struct end
        structure PackRealLittle = struct end
        structure PackReal32Big = struct end
        structure PackReal32Little = struct end
        structure PackReal64Big = struct end
        structure PackReal64Little = struct end
        structure PackReal128Big = struct end
        structure PackReal128Little = struct end
        signature LIST = sig end
        structure List = struct end
        signature LIST_PAIR = sig end
        structure ListPair = struct end
        signature VECTOR = sig end
        structure Vector = struct end
        signature MONO_VECTOR = sig end
        structure CharVector = struct end
        structure WideCharVector = struct end
        structure BoolVector = struct end
        structure IntVector = struct end
        structure RealVector = struct end
        structure WordVector = struct end
        structure Int8Vector = struct end
        structure Int16Vector = struct end
        structure Int32Vector = struct end
        structure Int64Vector = struct end
        structure Real32Vector = struct end
        structure Real64Vector = struct end
        structure Real128Vector = struct end
        structure Word8Vector = struct end
        structure Word16Vector = struct end
        structure Word32Vector = struct end
        structure Word64Vector = struct end
        signature ARRAY = sig end
        structure Array = struct end
        signature MONO_ARRAY = sig end
        structure CharArray = struct end
        structure WideCharArray = struct end
        structure BoolArray = struct end
        structure IntArray = struct end
        structure RealArray = struct end
        structure WordArray = struct end
        structure Int8Array = struct end
        structure Int16Array = struct end
        structure Int32Array = struct end
        structure Int64Array = struct end
        structure Real32Array = struct end
        structure Real64Array = struct end
        structure Real128Array = struct end
        structure Word8Array = struct end
        structure Word16Array = struct end
        structure Word32Array = struct end
        structure Word64Array = struct end
        signature ARRAY2 = sig end
        structure Array2 = struct end
        signature MONO_ARRAY2 = sig end
        structure CharArray2 = struct end
        structure WideCharArray2 = struct end
        structure BoolArray2 = struct end
        structure IntArray2 = struct end
        structure RealArray2 = struct end
        structure WordArray2 = struct end
        structure Int8Array2 = struct end
        structure Int16Array2 = struct end
        structure Int32Array2 = struct end
        structure Int64Array2 = struct end
        structure Real32Array2 = struct end
        structure Real64Array2 = struct end
        structure Real128Array2 = struct end
        structure Word8Array2 = struct end
        structure Word16Array2 = struct end
        structure Word32Array2 = struct end
        structure Word64Array2 = struct end
        signature IO = sig end
        structure IO = struct end
        signature TEXT_IO = sig end
        structure TextIO = struct end
        signature TEXT_STREAM_IO = sig end
        signature BIN_IO = sig end
        structure BinIO = struct end
        signature IMPERATIVE_IO = sig end
        functor ImperativeIO () = struct end
        signature STREAM_IO = sig end
        functor StreamIO () = struct end
        signature PRIM_IO = sig end
        structure BinPrimIO = struct end
        structure TextPrimIO = struct end
        structure WideTextPrimIO = struct end
        functor PrimIO () = struct end
        signature OS = sig end
        structure OS = struct end
        signature OS_FILE_SYS = sig end
        signature OS_IO = sig end
        signature OS_PATH = sig end
        signature OS_PROCESS = sig end
        signature COMMAND_LINE = sig end
        structure CommandLine = struct end
        signature UNIX = sig end
        structure Unix = struct end
        signature DATE = sig end
        structure Date = struct end
        signature TIME = sig end
        structure Time = struct end
        signature TIMER = sig end
        structure Timer = struct end
        signature POSIX = sig end
        structure Posix = struct end
        signature POSIX_ERROR = sig end
        signature POSIX_FILE_SYS = sig end
        signature POSIX_FLAGS = sig end
        signature POSIX_IO = sig end
        signature POSIX_PROC_ENV = sig end
        signature POSIX_PROCESS = sig end
        signature POSIX_SIGNAL = sig end
        signature POSIX_SYS_DB = sig end
        signature POSIX_TTY = sig end
        signature NET_HOST_DB = sig end
        structure NetHostDB = struct end
        signature NET_PROT_DB = sig end
        structure NetProtDB = struct end
        signature NET_SERV_DB = sig end
        structure NetServDB = struct end
        signature SOCKET = sig end
        structure Socket = struct end
        signature GENERIC_SOCK = sig end
        structure GenericSock = struct end
        signature INET_SOCK = sig end
        structure INetSock = struct end
        signature UNIX_SOCK = sig end
        structure UnixSock = struct end
	nonfix * / mod div ^ + - := o > < >= <= = <> :: @ before

        open Types
EOF
cat >>$basis <<-EOF
	local
EOF
cd $root/basis-library
rewrite_files >>$basis 'libs/build'
cat >>$basis <<-EOF
	in
EOF
cd $root/basis-library
rewrite_files >>$basis "libs/$LIB/bind"
cat >>$basis <<-EOF
	end
EOF
cd $here
case "$SML_FILE" in
"")
	;;
*)
	rewrite_file >>$basis "$SML_FILE"
	;;
esac
case "$CM_FILE" in
"")
	;;
*)
	rewrite_files >>$basis "$CM_FILE"
	;;
esac
cat >>$basis <<-EOF
	(*#line 0.0 "check-basis"*)
	val _ = case 1 of 1 => 1
EOF
chmod -w $basis
sml <$basis
