path: root/cpp.fun

functor Cpp(T: TOKENIZER): CPP = struct

  structure T = T

  type tkPos = T.S.pos
  type t =
    { streams: T.S.t list, fileInfo: T.S.fileInfo list,
      lastPos: tkPos option, firstId: T.S.fileId,
      incDirs: string list }

  datatype tkExp =
    Tk of T.token |
    Id |
    NumConst |
    StrLiteral |
    UnOp |
    BinOp |
    Op

  type tkExpectedVal = string * tkExp list

  exception StreamTooOld
  exception TkExpected of tkExpectedVal

  type tkErrorVal = string * string
  exception TkError of tkErrorVal

  fun create fname incDirs =
  let
    val stream = T.S.create fname
    val info = T.S.convert stream
  in
   { streams = [stream] , fileInfo = [info], lastPos = NONE,
      firstId = #1 info, incDirs }
  end

  fun getLastPos ({ lastPos = NONE, ... }: t) = raise Unreachable
    | getLastPos { lastPos = SOME p, ... } = p

  fun getTopFileInfo ({ streams = top :: _, ... }: t) = T.S.convert top
    | getTopFileInfo _ = raise Unreachable

  val tkExp2str = fn
      (Tk tk) => T.token2str tk
    | Id: tkExp => "identifier"
    | NumConst => "numeric constant"
    | StrLiteral => "string literal"
    | UnOp => "unary operator"
    | BinOp => "binary operator"
    | Op => "operator"

  fun tkPos2str stream (id, pos) =
  let
    val fileInfo =
      case List.find (fn (id', _, _) => id' = id) $ #fileInfo stream of
        NONE => raise StreamTooOld
      | SOME fileInfo => fileInfo
  in
    T.S.ppos2str $ T.S.pos2pposWithFI (id, pos) fileInfo
  end

  fun prepTkError stream pos msg = raise TkError (tkPos2str stream pos, msg)
  fun prepLastTkError stream = prepTkError stream (getLastPos stream)

  fun prepTkExpected (stream: t) pos expList =
    raise TkExpected (tkPos2str stream pos, expList)
  fun prepLastTkExpected stream = prepTkExpected stream
    (getLastPos stream)

  fun tkExpectedPrint (pos, expList) =
  let
    fun tkExps2str [e] [] = tkExp2str e
      | tkExps2str [e] acc =
        (String.concatWith ", " acc ^ " or ") ^ tkExp2str e
      | tkExps2str (e :: ec) acc =
        tkExps2str ec (tkExp2str e :: acc)
      | tkExps2str [] _ = raise Unreachable
  in
    print pos;
    print ":expected ";
    printLn $ tkExps2str expList []
  end

  fun tkErrorPrint (pos, msg) = printLn $ pos ^ ": " ^ msg

  exception EmptyPath

  fun getDirOfCurFile ({ streams = top :: _, ... }: t) =
    OS.Path.getParent $ T.S.getFname top
    | getDirOfCurFile _ = raise Unreachable


  (* TODO: properly handle Size and Path exceptions from concat *)
  fun findPath _ "" _ = raise EmptyPath
    | findPath stream fname true =
    let
      val path = OS.Path.concat (getDirOfCurFile stream, fname)
    in
      (path, TextIO.openIn path)
    end
    | findPath stream fname false =
    let
      fun try (dir :: tail) =
      let
        val fname = OS.Path.concat (dir, fname)
      in
        SOME (fname, TextIO.openIn fname) handle _ => try tail
      end
        | try [] = NONE

      val instream = try (#incDirs stream)
    in
      case instream of
        NONE => findPath stream fname true
      | SOME pair => pair
    end

  fun predSkip stream pred =
  let
    val (c, stream) = T.S.getchar stream
  in
    case c of
      NONE => (NONE, stream)
    | SOME c =>
      if c = #"\n" then
        (NONE, stream)
      else if pred c then
        (SOME $ #2 $ T.S.getPosAfterCharRead stream, stream)
      else
        predSkip stream pred
  end

  fun tryCollect stream =
  let
    val top = hd $ #streams stream

    fun x f = f stream

    fun returnBack top = {
      streams = top :: tl (#streams stream),
      fileInfo = x#fileInfo,
      lastPos = x#lastPos,
      firstId = x#firstId,
      incDirs = x#incDirs
    }

    val (start, s) =
      case predSkip top (fn c => c = #"<") of
        (NONE, _) => raise Unreachable
      | (SOME p, s) => (p, s)

    val (res, s) = predSkip s (fn c => c = #">")
  in
    case res of
      NONE => (NONE, stream)
    | SOME endOff =>
        (SOME $ T.S.getSubstr (start + 1) endOff s, returnBack s)
  end

  fun getToken
    ({ streams = stream :: tail, fileInfo, lastPos, firstId, incDirs }: t) =
  let
    val (tk, stream) = T.getToken stream
  in
    case tk of
      NONE => getToken { streams = tail, fileInfo, lastPos, firstId, incDirs }
    | SOME (pos, tk) =>
        if tk = T.CppInclude then
          handleInclude { streams = stream :: tail, fileInfo,
            lastPos, firstId, incDirs }
        else
          (tk, { streams = stream :: tail, fileInfo,
              lastPos = SOME pos, firstId, incDirs })
  end
    | getToken
        { streams = [], fileInfo, lastPos = SOME lastPos, firstId, incDirs } =
    let
      val pos = SOME (#1 lastPos, ~1) (* EOF *)
    in
      (T.EOS, {streams = [], fileInfo, lastPos = pos, firstId, incDirs })
    end
    | getToken { streams = [], fileInfo, lastPos = NONE, firstId, incDirs } =
        (T.EOS, { streams = [], fileInfo,
            lastPos = SOME (firstId, ~1), firstId, incDirs })

  and handleInclude (stream: t) =
  let
    val (tk, streamNew) = getToken stream

    fun die () =
      prepLastTkError streamNew
        "#include with macro argument is not implemented"
  in
    case tk of
      T.StringConst path => includeFile streamNew path true
    | T.EOS => die ()
    | tk =>
        if String.sub (T.token2str tk, 0) = #"<" then
          let
            val (path, stream) = tryCollect stream
          in
            case path of
              SOME path => includeFile stream path false
            | NONE => die ()
          end
        else
          die ()
  end

  and includeFile stream fname localhdr =
  let
    val (fname, instream) = findPath stream fname localhdr
        handle EmptyPath =>
            prepLastTkError stream "#include path can not be empty"
    val newStream = T.S.createFromInstream fname instream
    val newFileInfo = T.S.convert newStream
  in
    getToken {
      streams = newStream :: #streams stream,
      fileInfo = newFileInfo :: #fileInfo stream,
      lastPos = #lastPos stream,
      firstId = #firstId stream,
      incDirs = #incDirs stream
    }
  end


  fun debugPrintToken cache tk (line, col) printLineRegardless =
  let
    val ` = Int.toString
  in
    if printLineRegardless orelse T.S.pposCacheGetLine cache <> line then
      print $ "\n" ^ T.S.pposCacheGetFname cache ^ ":" ^ `line ^ "\n\t"
    else
      ();
    print $ `col ^ ":" ^ T.token2str tk ^ "  "
  end

  fun adjustCacheStack (s as (top :: rest)) pos stream =
  let
    fun idMatches cache = T.S.pposCacheGetId cache = #1 pos
    fun metBefore [] = NONE
      | metBefore (c :: cs) =
        if idMatches c then
          SOME (c :: cs)
        else
          metBefore cs
  in
    if idMatches top then
      (false, s)
    else
      (true, case metBefore rest of
        NONE => T.S.pposCacheInit (getTopFileInfo stream) :: s
      | SOME stack => stack)
  end
    | adjustCacheStack _ _ _ = raise Unreachable

  fun debugPrint' cacheStack stream first =
    let
      val (tk, stream) = getToken stream
    in
      case tk of
        T.NewLine => debugPrint' cacheStack stream first
      | T.EOS => ()
      | tk =>
        let
          val pos = getLastPos stream
          val (stackChanged, cacheStack) =
                adjustCacheStack cacheStack pos stream

          val oldTop = hd cacheStack
          val (pair, top) = T.S.pposCacheAdvance pos oldTop
        in
          debugPrintToken oldTop tk pair (first orelse stackChanged);
          debugPrint' (top :: tl cacheStack) stream false
        end
    end

  fun debugPrint stream =
  let
    val cache = T.S.pposCacheInit $ hd $ #fileInfo stream
  in
    debugPrint' [cache] stream true;
    print "\n"
  end
end