(* FP-eksamensopgave, MLDoc *)

(* Forfatter: Anders Bjerg Pedersen, 070183 *)

(* Afleveringsdato: 27. oktober 2006 *)

app use ["Item.sml", "IO.sig", "Scan.sig", "Decl.sig", "Display.sig"];

app load ["Msp","FileSys"];



(* Implementering af modul IO: *)

structure IO :> IO =
struct

exception IOError of string;

open FileSys;

(* readFrom-funktionen bruger meget fra aflevering 6, tilføjet en exception: *)

fun readFrom ""       = ""
  | readFrom fileName = 
     let val ins = TextIO.openIn fileName
     in
         TextIO.inputAll ins before TextIO.closeIn ins
     end handle IO => raise IOError fileName;


(* writeTo ligner meget, dog skal der her tages højde for, at systemet giver 
   exception Io, hvis der forsøges openOut på en skrivebeskyttet fil: *)
 
fun writeTo fileName str =
     let val ous = TextIO.openOut fileName handle Io _ => raise IOError fileName
	 in
         TextIO.output(ous,str) before TextIO.closeOut ous
     end;

	
end


(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)

(* Implementering af modul Scan: *)

structure Scan :> Scan =
struct

datatype item = datatype Item.item;

(* BEMÆRK: Kildekoden i dette modul kan være korrekt eller ukorrekt, 
   hvilket medfører, at ukorrekt kildekode alligevel fortolkes. *)


(* Vi sætter vores text-type til string, dermed bliver 
   konverteringsfunktionerne trivielle: *)
			  
type text = string;

fun fromString str = str;

fun toString str = str;


(* To lister med declarators og keywords og to funktioner, der er sande, hvis en 
   streng er iblandt en af listerne: *)

val declarator' = ["exception","fun","val","abstype","datatype","eqtype","type","withtype",
                   "functor","signature","structure"];
val keyword'    = ["and","andalso","as","case","do","else","end","fn","handle","if","in",
                   "infix","infixr","let","local","nonfix","of","op","open","orelse","raise",
                   "rec","then","while","include","sharing","sig","struct","where"];

fun declarator y = List.exists (fn x => x = y) declarator';
fun keyword y    = List.exists (fn x => x = y) keyword';


exception ScanError of string


(* Funktionen f tager 4 argumenter: en streng, der skal tjekkes; hvad der skal tjekkes efter;
   en akkumulator, der indeholder resten af str og til sidst en variabel, der har længden af test.
   BEMÆRK: der tages IKKE højde for indlejrede kommentarer eller anførselstegn!  
   Desuden går vi efter specifikationen, at en uafsluttet kommentar/streng returnerer NONE: *)

fun f("",_,_,_)       = NONE
  | f(str,test,akk,l) = 
    if size str < l then NONE
    else
	  if String.substring(str,0,l) = test
	  then SOME((if l=2 then COMMENT else STRINGCONSTANT) akk,String.substring(str,l,(size str) - l))
	  else f(String.substring(str,1,(size str)-1),test,akk ^ String.substring(str,0,1),l);

(* Og de to funktioner getComment og getStringConstant bruger så f til at returnere indholdet 
   af hvad, der nu er tjekket efter. *)
	  
fun getComment ""  = NONE
  | getComment str = f(str,"*)","",2);
fun getStringConstant "" = NONE
  | getStringConstant str = f(str,"\"","",1);


(* getWhiteSpaces' returnerer den længste streng af mellemrumstegn
   ud fra en char list.
   getWhitespaces får en streng som input fra getWhiteSpaces' og returnerer 
   tuplet bestående af den længste følge af mellemrumstegn efterfulgt 
   af resten af strengen: *)
  
fun getWhiteSpaces' [] = ""
  | getWhiteSpaces' (x::xs)  =
      if Char.isSpace(x) then (str x) ^ getWhiteSpaces'(xs)
	  else "";

fun getWhiteSpaces("") = ("","")
  | getWhiteSpaces(x)  = 
    let val y = getWhiteSpaces'(explode(x))
	    val rest = String.substring(x,size y,size x - size y)
	in	
	  (y,rest)
    end;

(* getWord virker på nøjagtig samme måde som getWhiteSpaces, blot returnerer 
   den det længste "ord", der indleder strengen, efterfulgt af resten.
   BEMÆRK: på grund af min udformning af getWord, kan den godt returnere
   et ord af længde 1. Dette har meget uheldige konsekvenser, da vi så kan 
   få en meget lang række identifiers i stedet for chars fra vores getItem, 
   som vi ingen steder får lavet om. Dette er uheldig mangel i implementationen. *)
	
fun getWord' [] = ""
  | getWord' (x::xs)  =
      if Char.isAlpha(x) then (str x) ^ getWord'(xs)
	  else "";

fun getWord("") = ("","")
  | getWord(x)  = 
    let val y = getWord'(explode(x))
	    val rest = String.substring(x,size y,size x - size y)
	in	
	  (y,rest)
    end;

(* Og næsten det samme med getChars, her er der bare lidt flere betingelser, 
   der skal være opfyldt: *)

fun getChars' [] = ""
  | getChars' (x::xs)  =
      if not(Char.isSpace x orelse Char.isAlpha x orelse x = #"("
        orelse x = #"*" orelse x = #")" orelse x = #"\"") then (str x) ^ getChars'(xs)
	  else "";

fun getChars("") = ("","")
  | getChars(x)  = 
    let val y = getChars'(explode(x))
	    val rest = String.substring(x,size y,size x - size y)
	in	
	  (y,rest)
    end;

(* Vi anvender skabelonen fra kursets forum til udformningen af getItem.
   Vores getItem'-funktion pattern matcher på en char list og returnerer 
   SOME(item,rest), hvis charlisten indledes af noget brugbart, ellers 
   returneres NONE. getItem på en streng kalder så getItem på den 
   tilsvarende charlist: *)

local
fun getItem' (css as #"(" :: #"*" :: cs) = getComment(implode(cs))
  | getItem' (css as #"\"" :: cs) = getStringConstant(implode(cs))
  | getItem' (#"(" :: cs) = SOME(PARENOPEN,implode(cs))
  | getItem' (#")" :: cs) = SOME(PARENCLOSE,implode(cs))
  | getItem' (#"*" :: cs) = SOME(ASTERISK,implode(cs))
  | getItem' (css as x :: cs) =
      if Char.isSpace x
      then 
   let
       val (whitespaces,rest) = getWhiteSpaces(implode(css))
   in
       SOME (WHITESPACE whitespaces,rest)
   end
      else
   if Char.isAlpha x
   then
       let
         val (word,rest) = getWord(implode(css))
       in
         if keyword word
         then SOME(KEYWORD word,rest)
         else 
		   if declarator word
           then SOME (DECLARATOR word,rest)
           else SOME (IDENTIFIER word,rest)
       end
   else
       let
         val (other,rest) = getChars(implode(css))
       in
         SOME(CHARS other,rest)
       end
in
fun getItem(x) = getItem'(explode(x))
end;

(* Til sidst er der items-funktionen, der giver os en liste med alle de leksikalske 
   elementer i en text. Den bruger selvfølgelig getItem: *)

local  
fun items'("") = []
  | items'(x) = case getItem(fromString(x)) of
                  NONE => raise ScanError x
                | SOME(a,b) => a :: items'(b)
in
fun items(x) = items'(fromString(x))
end;

end


(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)


(* Implementering af modul Decl: *)

structure Decl :> Decl =
struct

datatype item = datatype Item.item

type declaration = { declarator : string, identifier : string, comment : string }

(* BEMÆRK: Vi anvender "skabelonen" givet på kursets forum! *)

(* Funktionen cleanSpace fjerner whitespaces fra en liste af items: *)

fun cleanSpace([])    = []
  | cleanSpace((WHITESPACE _)::xs) = cleanSpace(xs)
  | cleanSpace(x::xs) = x :: cleanSpace(xs);


(* Funktionen records producerer declarations i en liste, og records samler 
   funktionaliteten af cleanSpace og records' og genererer dermed den ønskede 
   liste af poster: *)

local
  fun records'([]) = []
    | records'((COMMENT x1)::(DECLARATOR x2)::(IDENTIFIER x3)::xs) 
      = {comment=x1,declarator=x2,identifier=x3}::records'(xs)
    | records'((DECLARATOR x2)::(IDENTIFIER x3)::xs) 
      = {comment="",declarator=x2,identifier=x3}::records'(xs)
    | records'(x::xs) = records'(xs)
in
  fun records(xs) = records'(cleanSpace(xs))
end;


(* Til at sortere listen med declarations bruger vi igen vores 
   sorteringsfunktion qsortWith fra aflevering 5: *)
	 
local
    fun partition(_,[],samlg) = ([],[])
      | partition(pivot,x::xr,samlg)
        = let val (xv,xh) = partition(pivot,xr,samlg)
          in if samlg(x,pivot) then (x::xv,xh)
    	  					   else (xv,x::xh)
          end
	fun quicksort([],samlg)     = []
      | quicksort(x::xr,samlg)
        = let val (xv,xh) = partition(x,xr,samlg)
   	      in quicksort(xv,samlg) @ x :: quicksort(xh,samlg)
	      end
in
    fun qsortWith samlg s = quicksort(s,samlg)
end;

(* Vi grupperer vores deklaratorer efter deres type og laver funktioner, 
   der tjekker, om en streng er blandt deklaratorerne: *)

val valDec = ["exception","fun","val"];
val typDec = ["abstype","datatype","eqtype","type","withtype"];
val modDec = ["functor","signature","structure"];

fun isValDec(str) = List.exists (fn x => x = str) valDec;
fun isTypDec(str) = List.exists (fn x => x = str) typDec;
fun isModDec(str) = List.exists (fn x => x = str) modDec;


(* Vores sorteringsfunktion tjekker slavisk, om to declarations står korrekt efter hinanden: *)
  
fun sort({comment=_:string,declarator=d1:string,identifier=i1:string},{comment=_,declarator=d2,identifier=i2}) =
if isModDec(d1) then not(isModDec(d2)) orelse i1 <= i2
else
  if isTypDec(d1) then not(isModDec(d2)) andalso (isValDec(d2) orelse i1 <= i2)
  else
    isValDec(d1) andalso i1 <= i2;

(* Og til sidst anvendes qsortWith på records-funktionen efter sorteringen sort: *)
	
fun decls(xs) = qsortWith sort (records(xs));

end


(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)


(* Implementering af modul Display: *)

structure Display :> Display =
struct 

datatype item = datatype Item.item

type declaration = { declarator : string, identifier : string, comment : string }

open Msp;

(* Vi erklærer konkateneringsoperatoren for wseq som infix: *)

infix &&;

(* Og sætter vores displaytype til Msp.wseq, derfor er vores to 
   konverteringsfunktioner nødt til at være hhv. $ og flatten: *)

type display = Msp.wseq;

fun fromString str = $ str;
fun toString str = flatten str;

(* Funktionen convWhitespaces laver en WHITESPACE-tegnfølge om til dens HTML-repræsentation, og
   funktionen displayItem laver pattern matching på inputtet og anvender htmlencode 
   til at erstatte de relevante tegn (&,<,>) i kommentarer og lignende. Den bruger 
   så funktioner fra Msp til den relevante formatering af de forskellige items: *)

fun convWhitespaces("")  = Empty
  | convWhitespaces(str) =
     ( case String.sub(str,0) of
	      #" "  => fromString("&nbsp;")
		| #"\n" => fromString("<br/>")
		| #"\t" => fromString("&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;")
		|   _   => fromString(String.substring(str,0,1)) )
	 && convWhitespaces(String.substring(str,1,(size str)-1));
   
fun displayItem(WHITESPACE x)     = convWhitespaces(x)
  | displayItem(COMMENT x)        = fromString("(*" ^ htmlencode(x) ^ "*)")
  | displayItem(STRINGCONSTANT x) = fromString("\"" ^ htmlencode(x) ^ "\"")
  | displayItem(DECLARATOR x)     = strong(fromString(x))
  | displayItem(KEYWORD x)        = strong(fromString(x))
  | displayItem(IDENTIFIER x)     = em(fromString(x))
  | displayItem(ASTERISK)         = fromString("*")
  | displayItem(PARENOPEN)        = fromString("(")
  | displayItem(PARENCLOSE)       = fromString(")")
  | displayItem(CHARS x)          = fromString(htmlencode(x));


(* Vores displayProg bruger så displayItem på en liste og sætter <pre>/</pre> hhv. 
   foran og bagved vores "oversatte" items: *)

local
  fun displayProg' []     = fromString("")
    | displayProg'(x::xs) = displayItem(x)  && displayProg'(xs)
in
  fun displayProg(x) = pre( displayProg'(x) )
end;


(* Til sidst er der displayDecls-funktionen, som igen anvender funktioner fra Msp 
   til at generere vores HTML-tabel: *)

local
  fun displayDecls' []     = fromString("")
    | displayDecls'(xs as {declarator=x,identifier=y,comment=z}::xr) = 
        tr( td( strong(fromString(x)) ) && td( em(fromString(y)) )
        && td( fromString(z) ) ) && displayDecls'(xr)
in
  fun displayDecls(x) = pre( table( displayDecls'(x) ) )
end;


end


(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)


(* Implementering af testmodulet for IO: *)

(* Jeg har her haft svært ved at se nødvendigheden af flere testtilfælde. Både 
   readFrom og writeTo testes, ligesom beskyttede filer testes.*)

structure TestIO =
struct

local
fun remove fileName = FileSys.remove fileName handle SysErr _ => ()
fun setup test = 
     let val fileName = FileSys.tmpName ()
     in test fileName before remove fileName
     end handle _ => false
val unwritableFile = "beskyt.sml" (* Set to file name that cannot be written to *)
open IO
in
val testIO00 = setup (fn fileName => (writeTo fileName ""; readFrom fileName = ""))
val testIO01 = setup (fn fileName => (writeTo fileName "foobar"; readFrom fileName = "foobar"))
val testIO02 = setup (fn fileName => 
                         (remove fileName; readFrom fileName; false) 
                         handle IOError str => fileName = str)
val testIO03 = (writeTo unwritableFile "foobar"; false) 
               handle IOError str => unwritableFile = str
                    | _ => false
end

end


(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)


(* Implementering af testmodulet for Scan: *)

structure TestScan =
struct

(* Test of conversion property between text and string *)

local
fun testConversion txt = Scan.toString (Scan.fromString txt) = txt
in
val testScan00 = testConversion "" handle _ => false
val testScan01 = testConversion "\tfoo\t\rbar\n" handle _ => false
end

local
open Item
val items = Scan.items o Scan.fromString
val getItem = Scan.getItem o Scan.fromString
in

(* Af uvisse grunde giver denne test false, selvom getItem er defineret 
   til at være NONE, hvis den køres på den tomme streng: *)

val testComment00 = (case getItem "" of NONE => true | _ => false)
                    handle _ => false
val testComment01 = (case getItem "(*foo=0" of NONE => true | _ => false)
                    handle _ => false
val testComment02 = (case getItem "(*foobar*)" of 
                         SOME (COMMENT "foobar", rest) => Scan.toString rest = ""
                       | _ => false)
                    handle _ => false
val testStringConstant00 = (case getItem "\"blablablabla\"" of
                                SOME (STRINGCONSTANT "blablablabla", rest) => Scan.toString rest = ""
                              | _ => false)
                           handle _ => false
val testStringConstant01 = (case getItem "\"blabla\"bloblo\"" of
                                SOME (STRINGCONSTANT "blabla", rest) => Scan.toString rest = "bloblo\""
                               | _ => false)
                           handle _ => false
(* Denne test udelukker vi, da vi ikke tager højde for indlejrede anførselstegn: 
val testStringConstant02 = (case getItem "\"blablabla\\\"" of NONE => true | _ => false)
                           handle _ => false *)

val testItems00 = (items ("") = [] handle _ => false) handle _ => false
val testItems01 = (items ("   \n   ") = [WHITESPACE "   \n   "]) handle _ => false
val testItems02 = (items ("print \"Hello, World\"") =
                  [IDENTIFIER "print", WHITESPACE " ", STRINGCONSTANT "Hello, World"])
                  handle _ => false
val testItems03 = (items ("foo=0") =
                  [IDENTIFIER "foo", CHARS "=0"])
                  handle _ => false
val testItems04 = (items ("foo : int = 0") =
                  [IDENTIFIER "foo", WHITESPACE " ", CHARS ":", WHITESPACE " ",
                   IDENTIFIER "int", WHITESPACE " ", CHARS "=", WHITESPACE " ",
                   CHARS "0"])
                  handle _ => false
val testItems05 = (items ("(*foo(*bar*)*)0") =
                  [COMMENT "foo(*bar", ASTERISK, PARENCLOSE, CHARS "0"])
                  handle _ => false
(* I nedenstående tilfælde bemærker vi, at den indlejrede kommentar ikke opfanges, 
   men at der i stedet "løbes hen over" den: *)
val testItems06 = (items ("(* dkjdf \n (* ... djf *) kjdff\t") = 
                  [COMMENT " dkjdf \n (* ... djf ", WHITESPACE " ", IDENTIFIER "kjdff", WHITESPACE "\t"])
                  handle _ => false
end

end


(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)


(* Implementering af testmodulet for Decl:.*)

structure TestDecl =
struct

open Decl

val testDecl01 = decls([WHITESPACE " ",COMMENT "En kommentar...",COMMENT "En exception:",
DECLARATOR "exception",IDENTIFIER "IOError",WHITESPACE "\n",DECLARATOR "fun",IDENTIFIER "records"])
 = [{comment = "En exception:", declarator = "exception",identifier = "IOError"},
     {comment = "", declarator = "fun", identifier = "records"}];

val testDecl02 = decls([WHITESPACE " ",COMMENT "En kommentar...",COMMENT "En funktion:",
DECLARATOR "fun",IDENTIFIER "records",WHITESPACE "\n",DECLARATOR "exception",IDENTIFIER "IOError"])
 = [{comment = "", declarator = "exception", identifier = "IOError"},
     {comment = "En funktion:", declarator = "fun", identifier = "records"}];

val testDecl03 = decls([WHITESPACE " ",COMMENT "En funktion, der laver...",COMMENT "En funktion 2:",
DECLARATOR "fun",IDENTIFIER "records2",WHITESPACE "\n",DECLARATOR "fun",IDENTIFIER "records1"])
 = [{comment = "", declarator = "fun", identifier = "records1"},
     {comment = "En funktion 2:", declarator = "fun", identifier = "records2"}];

end


(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)


(* Implementering af testmodulet for Display *)

structure TestDisplay =
struct

local
(* Test of conversion property between display and string *)
fun testConversion txt = Display.toString (Display.fromString txt) = txt
in

val testConversion00 = testConversion "" handle _ => false
val testConversion01 = testConversion "\tfoo\t\rbar\n" handle _ => false

end

local
(* Replace tabs by 8 blanks each *)
val untabify = String.translate (fn #"\t" => "        " | c => str c)

(* Split off input until first occurrence of a particular character *)
fun splitUntil c = StringCvt.splitl (fn c' => c <> c') List.getItem

(* Replace HTML entities (w/o leading '&' and trailing ';' by character denoted *)
fun unescape "amp" = #"&"
  | unescape "lt" = #"<"
  | unescape "gt" = #">"
  | unescape "nbsp" = #" "
  | unescape escSeq = raise Fail ("Unexpected HTML-entity: &" ^ escSeq ^ ";")

(* Remove HTML tags and entities from input character list *)
fun removeMarkup' (cs as #"<" :: cs') = (case splitUntil #">" cs' of
                                       ("br/", _ :: cs'') => #"\n" :: removeMarkup' cs''
                                     | (_, _ :: cs'') => removeMarkup' cs''
                                     | _ => raise Fail ("End of tag character not found: " ^ implode cs))
  | removeMarkup' (cs as #"&" :: cs') = (case splitUntil #";" cs' of
                                       (escSeq, _ :: cs'') => unescape escSeq :: removeMarkup' cs''
                                     | _ => raise Fail ("Missing ';' at end of HTML-entity: " ^ implode cs))
  | removeMarkup' (c :: cs) = c :: removeMarkup' cs
  | removeMarkup' nil = nil

(* Remove HTML tags and entities from input string *)
val removeMarkup = implode o removeMarkup' o explode

(* Give list of file names to be checked; here it is assumed that the exam structures
   and signatures are stored in the current catalogue under the following names. *)
val MLDocFiles = [
         "IO.sig", "IO.sml", 
	 "Item.sml",
	 "Scan.sig", "Scan.sml", 
	 "Decl.sig", "Decl.sml", 
         "Display.sig", "Display.sml", 
	 "MLDoc.sml",
         "TestIO.sml",
         "TestScan.sml",
         "TestDecl.sml",
         "TestDisplay.sml"
];

(* Checks whether output of displayProg, with markup removed, is identical to input src after
   replacing tabs by 8 blanks each.  This function can be used to test if the output of
   displayProg retains the source code (including whitespace), if displayProg
   only inserts HTML-tags and escapes '<', '>', '&', ' ' and the newline character, but
   does nothing else. If displayProg adds HTML-comments, processing instructions, adds Javascript or similar,
   this test function must be adapted to be usable for testing visual correctness of the
   output of displayProg *) 
   
fun testDisplayProg fileName = 
    let val str = IO.readFrom fileName
    in removeMarkup (Display.toString (Display.displayProg (Scan.items (Scan.fromString str)))) =
       untabify str
    end handle _ => false

val display = removeMarkup o Display.toString o Display.displayItem

open Item

in

val testDisplay01 = (display (STRINGCONSTANT "dkjfdf\\\"df\\\"\\\"\n") = "\"dkjfdf\\\"df\\\"\\\"\n\"")
                    handle _ => false					
val testDisplay02 = (display (COMMENT "**\n\td(*dk\nf**)kd\njf") = "(***\n\td(*dk\nf**)kd\njf*)")
                    handle _ => false
val testDisplay03 = (display (WHITESPACE " \n\t\r \n  \n") = untabify " \n\t\r \n  \n")
                    handle _ => false
val testDisplay04 = (display (DECLARATOR "abstype") = "abstype")
                    handle _ => false
val testDisplay05 = (display (KEYWORD "open") = "open")
                    handle _ => false
val testDisplay06 = (display (IDENTIFIER "xX_'...YY561._") = "xX_'...YY561._")
                    handle _ => false
val testDisplay07 = (display ASTERISK = "*") handle _ => false
val testDisplay08 = (display PARENOPEN = "(") handle _ => false
val testDisplay09 = (display PARENCLOSE = ")") handle _ => false
val testDisplay10 = (display (CHARS "=}@£${[]}+´´``|~¨^'--_.:,;\\<>1234567890!#¤%&/=?") =
                     "=}@£${[]}+´´``|~¨^'--_.:,;\\<>1234567890!#¤%&/=?")
                    handle _ => false
val testDisplay11 = Display.toString(Display.displayProg([(WHITESPACE "    "),
COMMENT "blablablabla",WHITESPACE " \r\n    ",DECLARATOR "fun",WHITESPACE " ",
IDENTIFIER "testDisplayProg"])) =
  "<PRE>&nbsp;&nbsp;&nbsp;&nbsp;(*blablablabla*)&nbsp;\r<br/>&nbsp;&nbsp;&nbsp;&nbsp;"
  ^ "<STRONG>fun</STRONG>&nbsp;<EM>testDisplayProg</EM></PRE>";

(* Nedenstående test fejler, men jeg kan ikke umiddelbart se hvorfor: *)

val testDisplayProgMLDocFiles = List.all testDisplayProg MLDocFiles
end


end

(*----------------------------------------------------------------------*)
(*----------------------------------------------------------------------*)


open TestIO;
open TestScan; 
open TestDecl;
open TestDisplay;