cmdlang.grm

(* $Id$
 *
 * Copyright (c) 2008 Timothy Bourke (University of NSW and NICTA)
 * All rights reserved.
 *
 * This program is free software; you can redistribute it and/or modify it
 * under the terms of the "BSD License" which is distributed with the
 * software in the file LICENSE.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the BSD
 * License for more details.
 *)

structure CE   = CmdEnv
      and PNta = ParsedNta
      and NtaU = NtaUtil
      and Gviz = Graphviz

(* shortcuts over Atom and AtomSet *)
infix <+ <- ++ <\ \ =:= ; open Symbol

fun graphvizEngine () = Option.getOpt (Graphviz.stringToGraph
                                         (Settings.graphvizEngine ()),
                                       Graphviz.Fdp)
type actionsubst = (Atom.atom * CE.direction) * (Atom.atom * CE.direction)

fun outln os xs = (TextIO.output (os, concat xs);
                   TextIO.output (os, "\n"))
val (pr, pre) = (outln TextIO.stdOut, outln TextIO.stdErr)

fun listTemplates e =
  (app (fn t=>pr [PNta.Template.selName t]) (CE.listTemplates e); (e, false))

fun showVals e = let
    fun show (nm, v) = pr [Atom.toString nm, "=", CE.toString v]
  in app show (CE.listItems e); (e, false) end

fun showVal id e = let
    val () = case CE.getValue e id of
               NONE   => pr ["unknown name ", Atom.toString id]
             | SOME v => pr [CE.toString v]
  in (e, false) end

fun insert (e, id, CE.Fail s) = (pre ["fail: ", s]; (e, true))
  | insert (e, id, v)         = (CE.insert ((id, v), e), false)

fun drop (e, id) = CE.remove (e, id)

fun addCoords layoutengine locIdPred
              (template as PNta.Template {name=(n,_), ...}) =
  let
    fun p (PNta.Transition {source=s, target=t, ...}) = (locIdPred s orelse
                                                         locIdPred t)
    val withIds = NtaU.addTransitionIds p template
    val dot     = Layout.toDot true withIds
  in
    case Gviz.makePlain layoutengine dot of
      NONE       => (Util.warn ["could not lay out "^n]; template)
    | SOME plain => (NtaU.stripTransitionIds
                      (Layout.addCoordsFromPlain (withIds, plain)))
  end

fun doMakeMCS51 (path, maxrows, showinstrs) = let
    val ins = TextIO.getInstream (TextIO.openIn path)
    val prog = MCS51.parse TextIO.StreamIO.inputLine ins
    val t = MCS51.toTemplate (prog, {showinstrs=showinstrs,
                                     position=true,
                                     maxrows=maxrows})
  in CE.Template t end
    handle IO.Io {cause, ...} => (CE.Fail
                                  (concat ["unable to open: ",
                                           path, "(", 
                                           General.exnMessage cause, ")"]));

fun doMakeTest (CE.Template t, CE.Symbols chanset, CE.Symbols varset) = (let
        val chans = AtomSet.listItems chanset
        val _ = NtaU.warnIfCommitted t
        val _ = NtaU.warnOnChannels t
        val t = NtaU.expandUrgentLocs t
        val (t, checkVarTransFun) = MakeTest.makeVarCheckTrans
                                      (AtomSet.listItems varset) t
        val (errl, t) = MakeTest.maketest (chans, t)
        val t = MakeTest.addReadyChecks chans (errl, t)
        val t = NtaU.addTransitions (t, checkVarTransFun errl)
        val t = addCoords (graphvizEngine ()) (NtaU.locsWithoutPositions t) t
      in CE.Template t end
      handle MakeTest.InvalidChannelId c => CE.Fail ("invalid channel id "
                                                     ^Atom.toString c)
           | MakeTest.NoChannels => CE.Fail "empty channel list"
           | MakeTest.BadBroadcastChannel c => CE.Fail (
                                    "input on broadcast channel "
                                    ^Atom.toString c^" cannot be inverted"))

  | doMakeTest (f as CE.Fail _, _, _)        = f
  | doMakeTest (_, f as CE.Fail _, _)        = f
  | doMakeTest (_, _, f as CE.Fail _)        = f
  | doMakeTest _ = CE.Fail
                     "bad args: maketest(<template> [, <nameset>, <nameset>])"

fun doMakeTest' (v, env) = case CE.getValue env (Atom.atom "channels") of
     NONE => CE.Fail "channels is not present"
   | SOME chans => (case CE.getValue env (Atom.atom "globals") of
                      NONE => CE.Fail "globals is not present"
                    | SOME globals => doMakeTest (v, chans, globals))

fun multisectTime (CE.Template t, expr) = CE.Template (NtaU.scaleClocks
                                                         (t, expr))
  | multisectTime (f as CE.Fail _, _)   = f
  | multisectTime _ = CE.Fail "bad args: multisecttime(<template>, <int|var>)"

fun doSetInitial (CE.Template t, nm)  =
      (case PNta.Location.nameToId t (Atom.toString nm) of
         SOME lid => CE.Template (PNta.Template.updInitial t (SOME lid))
       | NONE     => CE.Fail "location not found")
  | doSetInitial (f as CE.Fail _, _) = f
  | doSetInitial _ = CE.Fail "bad args: setinitial(<template>, <name>)"

fun doChannels (CE.Template t)  = CE.Symbols (NtaU.channelSet t)
  | doChannels (f as CE.Fail _) = f
  | doChannels _ = CE.Fail "bad args: channels(<template>)"

fun doRestriction (CE.Symbols s1, CE.Symbols s2) = CE.Symbols
                                                (AtomSet.difference (s1, s2))
  | doRestriction (tplate as CE.Template t, CE.Symbols s) =
        doRestriction (tplate, CE.Actions (CE.symbolsToActions s))

  | doRestriction (CE.Template t, CE.Actions s) = let
        fun p (PNta.Transition {sync=(NONE, _),...}) = true
          | p (PNta.Transition{sync=(SOME (nm,dir,_),_),...}) =
                        not (ActionSet.member (s, (nm, dir)))
        val ts = PNta.Template.selTransitions t
      in
        CE.Template (PNta.Template.prune
          (PNta.Template.updTransitions t (List.filter p ts)))
      end

  | doRestriction (f as CE.Fail _, _) = f
  | doRestriction (_, f as CE.Fail _) = f
  | doRestriction _ = CE.Fail "bad type combination for restriction"

fun doRenameTrans (CE.Template tplate, CE.SymbolMap m) = let
        fun ren (tr as PNta.Transition {sync=(NONE, _), ...}) = tr
          | ren (tr as PNta.Transition {sync=(SOME (nm,dir,subs), _),...}) =
              case AtomMap.find (m, nm) of
                NONE     => tr
              | SOME nm' => PNta.Transition.updSync tr (SOME (nm',dir,subs))
      in CE.Template (PNta.Transition.map ren tplate) end

  | doRenameTrans (CE.Template tplate, CE.ActionMap m) = let
        fun ren (tr as PNta.Transition {sync=(NONE, _), ...}) = tr
          | ren (tr as PNta.Transition {sync=(SOME (nm,dir,subs), _),...}) =
              case ActionMap.find (m, (nm, dir)) of
                NONE             => tr
              | SOME (nm', dir') => PNta.Transition.updSync tr
                                         (SOME (nm', dir', subs))
      in CE.Template (PNta.Transition.map ren tplate) end
  | doRenameTrans (f as CE.Fail _, _) = f
  | doRenameTrans (_, f as CE.Fail _) = f
  | doRenameTrans _ = CE.Fail "bad args: renametrans(<template>, <map>)"

fun doRenameLocs (CE.Template tplate, CE.SymbolMap m) = let
        fun f (loc as PNta.Location {name=(NONE, _), ...}) = loc
          | f (loc as PNta.Location {name=(SOME nm, _), ...}) =
              case AtomMap.find (m, Atom.atom nm) of
                NONE => loc
              | SOME nm' =>PNta.Location.updName loc (SOME (Atom.toString nm'))
      in
        CE.Template (PNta.Location.map f tplate)
      end
  | doRenameLocs (f as CE.Fail _, _) = f
  | doRenameLocs (_, f as CE.Fail _) = f
  | doRenameLocs _ = CE.Fail "bad args: renamelocs(<template>, <namemap>)"

fun doDropLoc (CE.Template tplate, CE.Symbols m) = let
        fun d (loc as PNta.Location {name=(NONE, _), ...}) = SOME loc
          | d (loc as PNta.Location {name=(SOME nm, _), ...}) =
              if Atom.atom nm <- m then NONE else SOME loc
      in
        CE.Template (PNta.Template.prune ((PNta.Location.mapPartial d tplate)))
      end
  | doDropLoc (f as CE.Fail _, _) = f
  | doDropLoc (_, f as CE.Fail _) = f
  | doDropLoc _ = CE.Fail "bad args: drop (<template>, <names>)"

fun doConflate (CE.Template tplate, CE.SymbolMap m) = let
        fun nameToId (PNta.Location {name=(NONE, _),...}, f) = f
          | nameToId (PNta.Location {id=PNta.LocId i,name=(SOME nm, _),...},f)=
                                        AtomMap.insert (f, Atom.atom nm, i)

        val nmToId = foldl nameToId AtomMap.empty
                                    (PNta.Template.selLocations tplate)

        fun nmMapToIdMap ((nm, nm'), m) =
            case (AtomMap.find (nmToId, nm), AtomMap.find (nmToId, nm')) of
              (SOME i, SOME j) => IntBinaryMap.insert (m, i, j)
            | _ => m

        val mId = foldl nmMapToIdMap IntBinaryMap.empty (AtomMap.listItemsi m)

        fun f (tr as PNta.Transition {source=PNta.LocId s,
                                      target=PNta.LocId t,...}) = let
              val (s', t') = (IntBinaryMap.find (mId, s),
                              IntBinaryMap.find (mId, t))
            in case (s', t') of
                 (NONE, NONE) => tr
               | _            => PNta.Transition.updEndPoints tr
                                     (PNta.LocId (Option.getOpt (s', s)),
                                      PNta.LocId (Option.getOpt (t', t)))
            end

        fun d (loc as PNta.Location {id=PNta.LocId i, ...}) =
              if isSome (IntBinaryMap.find (mId, i)) then NONE else SOME loc
          
      in
        CE.Template (PNta.Location.mapPartial d (PNta.Transition.map f tplate))
      end
  | doConflate (f as CE.Fail _, _) = f
  | doConflate (_, f as CE.Fail _) = f
  | doConflate _ = CE.Fail "bad args: conflate(<template>, <namemap>)"

fun doUnion (CE.Symbols s1, CE.Symbols s2) = CE.Symbols (AtomSet.union (s1,s2))
  (*| doUnion (CE.Template t, CE.Symbols s)*)
  | doUnion (f as CE.Fail _, _) = f
  | doUnion (_, f as CE.Fail _) = f
  | doUnion _ = CE.Fail "bad type combination for union"

fun doParameters (CE.Template t)  = CE.Symbols (
        foldl AtomSet.add' AtomSet.empty
          (Environment.writableVariables (PNta.Template.selDeclaration t,
                                          Environment.ParameterScope)))
  | doParameters (f as CE.Fail _) = f
  | doParameters _ = CE.Fail "bad args: parameters(<template>)"

fun doScale (CE.Template t, s)  = CE.Template (
        PNta.Template.transform {m11=s,m12=0.0,m21=0.0,m22=s,tx=0.0,ty=0.0} t)
  | doScale (f as CE.Fail _, _) = f
  | doScale (_, _) = CE.Fail "bad args: scale(<template>, <real>)"

fun doActions (CE.Template t) = CE.Actions (
        foldl ActionSet.add' ActionSet.empty (NtaU.actions t))
  | doActions (f as CE.Fail _) = f
  | doActions _ = CE.Fail "bad args: actions(<template>)"

fun doTabulate (CE.Template t, CE.Symbols lset) = let
    val locs = NtaU.namesetToLocset (lset, t)
    fun dstP (PNta.LocId i) = IntBinarySet.member (locs, i)
  in CE.Template (Layout.tabulateAll (dstP, t)) end
  | doTabulate (f as CE.Fail _, _) = f
  | doTabulate (_, f as CE.Fail _) = f
  | doTabulate _ = CE.Fail "bad args: tabulate(<template>, <locnames>)"

fun doSplit (CE.Template t,CE.ActionMap am) = CE.Template(NtaU.split (t,am))
  | doSplit (f as CE.Fail _, _) = f
  | doSplit (_, f as CE.Fail _) = f
  | doSplit _ = CE.Fail "bad args: split(<template>, <actionmap>)"

fun doAcceptAll (env, CE.Symbols chanset) =
      doAcceptAll (env, CE.Actions (CE.symbolsToActions chanset))
  | doAcceptAll (env, CE.Actions actionset) = let
      val actions = ActionSet.listItems actionset
      val iet =NtaU.makeInputEnabler (actions, CE.globalDecl env)
      val iet'=addCoords (graphvizEngine ()) (fn _=>true) iet
      val iet''=Layout.tabulateTransLabels ((0,0), (fn _=>true), iet')
    in CE.Template iet'' end

  | doAcceptAll (_, f as CE.Fail _) = f
  | doAcceptAll (_, _) = CE.Fail "bad args: acceptall(<channelset>)"

fun doWriteGraphics (CE.Template t, path, outty) = (let
    val out = TextIO.openOut path
    val dot = Layout.toDot false t
  in
    (case Atom.toString outty of
       "PS"  => (Gviz.makeFile (graphvizEngine (),Gviz.PS) (out,dot);
                 CE.Success)
     | "Dot" => (TypedDotIO.output (out, dot); CE.Success)
     | "SVG" => (Gviz.makeFile (graphvizEngine (),Gviz.SVG) (out,dot);
                 CE.Success)
     | _ => CE.Fail "bad output type, must be one of PS, Dot, or SVG.")
    before TextIO.closeOut out
  end
  handle IO.Io {cause, ...} => (CE.Fail (concat ["cannot write to '", path,
                                            "': ", General.exnMessage cause])))

  | doWriteGraphics (f as CE.Fail _, _, _) = f
  | doWriteGraphics _ = CE.Fail
        "bad args: writegraphics(<template>, <path>, <PS|Dot|SVG>)"

fun echo (f as CE.Fail s) = ((pr [s]); true)
  | echo v                = false

fun help () = app (fn t=>pr [t]) [
      "--commands--",
      "drop <template>",
      "list",
      "show [<id>]",
      "<id> = <expression>",
      "writegraphics (<template>, <path>, <PS|Dot|SVG>)",
      "--expressions--",
      "acceptall(<actionset>)",
      "actions(<template>)",
      "channels(<template>)",
      "conflate(<template>, <namemap>)",
      "makemcs51(<filepath>, [maxrows, [showinstrs]])",
      "maketest(<template>)",
      "maketest(<template>, <nameset>, <nameset>)",
      "multisecttime(<template>, <int|var>)",
      "parameters(<template>)",
      "renamelocs(<template>, <namemap>)",
      "renametrans(<template>, <actionmap>)",
      "scale(<template>, <real>)",
      "setinitial(<template>, <name>)",
      "split(<template>, <actionmap>)",
      "tabulate(<template>, <nameset>)",
      "<template> \\ <actionset>",
      "<nameset> \\ <nameset>",
      "<nameset> ++ <nameset>"
    ]

%%
%name CmdLang
%arg (initialEnv) : CE.t
%eop EOF SEMICOLON
%noshift EOF SEMICOLON
%pos FilePos.pos
%verbose

%header (functor CmdLangLrValsFn (structure Token   : TOKEN
                                  structure FilePos : FILE_POS
                                  structure CmdEnv  : CMD_ENV))

%term ID of Atom.atom | INTEGER of int | REAL of real | STRING of string |
      BOOL of bool | QUIT | LIST | SHOW | WRITEGRAPHICS | DROP |
      MAKEMCS51 | MAKETEST | RENAMELOCS | RENAMETRANS | SCALE | ACTIONS |
      ACCEPTALL | TABULATE | CHANNELS | SPLIT | PARAMETERS | HELP | CONFLATE |
      SETINITIAL | MULTISECTTIME |
      LPAR | RPAR | LSQPAR | RSQPAR | LBARBRACE | RBARBRACE | LBRACE | RBRACE |
      QUESTION | EXCLAM | SLASH | BACKSLASH | UNION | ASSIGN | COMMA |
      DBLARROW | RARROW | LARROW |
      SEMICOLON | UNKNOWN | EOF

%left  UNION
%left  BACKSLASH
                            
%nonterm cmd             of CmdLoop.t * CE.t
       | stmt            of CE.t -> (CE.t * bool)
       | expr            of CE.t -> CE.value
       | idlist          of Atom.atom list
       | idsubstlist     of (Atom.atom * Atom.atom) list
       | subst           of (Atom.atom * Atom.atom) list
       | action          of Atom.atom * CE.direction
       | actionlist      of (Atom.atom * CE.direction) list
       | actionsubst     of actionsubst list
       | actionsubstlist of actionsubst list

%keyword QUIT LIST SHOW HELP ASSIGN DROP WRITEGRAPHICS
%value ID  (Atom.atom "dummy")
%value INTEGER (0)

%%

cmd: stmt                             (let val (env, failed) = stmt initialEnv
                                       in (if failed then CmdLoop.Fail
                                           else CmdLoop.Continue, env) end)
   | QUIT                             ((CmdLoop.Stop, initialEnv))

stmt: LIST                            (listTemplates)
    | SHOW                            (showVals)
    | SHOW ID                         (showVal ID)
    | HELP                            (fn e=>(help(); (e, false)))
    | ID ASSIGN expr                  (fn e=>insert (e, ID, expr e))
    | expr                            (fn e=>(let val r = expr e in
                                                pr [CmdEnv.toString r];
                                                (e, CE.isFail r)
                                              end))
    | DROP ID                         (fn e=>(fn(e,v)=>(e, echo v))
                                             (drop (e, ID)))
    | WRITEGRAPHICS LPAR expr COMMA STRING COMMA ID RPAR
                                      (fn e=>(e, echo (doWriteGraphics
                                                         (expr e, STRING, ID))))

expr: ACCEPTALL expr RPAR             (fn e=>doAcceptAll (e, expr e))
    | ACTIONS expr RPAR               (fn e=>doActions (expr e))
    | CHANNELS expr RPAR              (fn e=>doChannels (expr e))
    | CONFLATE expr COMMA expr RPAR   (fn e=>doConflate (expr1 e, expr2 e))
    | DROP expr COMMA expr RPAR       (fn e=>doDropLoc (expr1 e, expr2 e))

    | MAKEMCS51 STRING RPAR           (fn e=>doMakeMCS51 (STRING, 10, false))
    | MAKEMCS51 STRING COMMA INTEGER RPAR
                                      (fn e=>doMakeMCS51 (STRING,INTEGER,false))
    | MAKEMCS51 STRING COMMA BOOL RPAR
                                      (fn e=>doMakeMCS51 (STRING, 10, BOOL))
    | MAKEMCS51 STRING COMMA INTEGER COMMA BOOL RPAR
                                      (fn e=>doMakeMCS51 (STRING,INTEGER,BOOL))

    | MAKETEST expr RPAR              (fn e=>doMakeTest' (expr e, e))
    | MAKETEST expr COMMA expr COMMA expr RPAR
                                      (fn e=>doMakeTest (expr1 e,
                                                             expr2 e, expr3 e))
    | MULTISECTTIME expr COMMA INTEGER RPAR(fn e=>multisectTime (expr e,
                                               Expression.IntCExpr INTEGER))
    | MULTISECTTIME expr COMMA ID RPAR    (fn e=>multisectTime (expr e,
                                               Expression.VarExpr (
                                                 Expression.SimpleVar ID)))
    | PARAMETERS expr RPAR            (fn e=>doParameters (expr e))
    | RENAMELOCS expr COMMA expr RPAR (fn e=>doRenameLocs (expr1 e, expr2 e))
    | RENAMETRANS expr COMMA expr RPAR(fn e=>doRenameTrans (expr1 e,
                                                                expr2 e))
    | SCALE expr COMMA REAL RPAR      (fn e=>doScale (expr1 e, REAL))
    | SETINITIAL expr COMMA ID RPAR   (fn e=>doSetInitial (expr e, ID))
    | SPLIT expr COMMA expr RPAR      (fn e=>doSplit (expr1 e, expr2 e))
    | TABULATE expr COMMA expr RPAR   (fn e=>doTabulate (expr1 e, expr2 e))
    | expr BACKSLASH expr             (fn e=>doRestriction (expr1 e, expr2 e))
    | expr UNION expr                 (fn e=>doUnion (expr1 e, expr2 e))
    | LBRACE idlist RBRACE            (fn e=>CE.Symbols (foldl AtomSet.add'
                                                             emptyset idlist))
    | LBRACE idsubstlist RBRACE       (fn e=>CE.SymbolMap
                                             (foldl AtomMap.insert'
                                                AtomMap.empty idsubstlist))
    | LBRACE RBRACE                   (fn e=>CE.Symbols AtomSet.empty)
    | LBARBRACE actionlist RBARBRACE  (fn e=>CE.Actions (foldl ActionSet.add'
                                                  ActionSet.empty actionlist))
    | LBARBRACE actionsubstlist RBARBRACE
                                      (fn e=>CE.ActionMap
                                               (foldl ActionMap.insert'
                                                  ActionMap.empty
                                                  actionsubstlist))
    | LBARBRACE RBARBRACE             (fn e=>CE.Actions ActionSet.empty)
    | ID                              (fn e=>case CE.getValue e ID of
                                               NONE  => CE.Fail ("unknown id "
                                                          ^ Atom.toString ID)
                                             | SOME v=> v)

idlist: ID                            ([ID])
      | ID COMMA idlist               (ID::idlist)

idsubstlist: subst                    (subst)
           | subst COMMA idsubstlist  (subst @ idsubstlist)

subst: ID RARROW ID                   ([(ID1, ID2)])
     | ID DBLARROW ID                 ([(ID1, ID2), (ID1, ID2)])

action: ID QUESTION                   ((ID, CE.Input))
      | ID EXCLAM                     ((ID, CE.Output))

actionlist: ID                        ([(ID, CE.Input),(ID, CE.Output)])
          | action                    ([action])
          | ID COMMA actionlist       ([(ID, CE.Input),(ID, CE.Output)]
                                       @ actionlist)
          | action COMMA actionlist   (action::actionlist)

actionsubstlist: actionsubst          (actionsubst)
               | actionsubst COMMA actionsubstlist
                                      (actionsubst @ actionsubstlist)

actionsubst: ID RARROW action         ([((ID1, CE.Input), action),
                                        ((ID1, CE.Output),action)])
           | ID RARROW ID             ( [((ID1, CE.Input),
                                          (ID2, CE.Input)),
                                         ((ID1, CE.Output),
                                          (ID2, CE.Output))])
           | ID DBLARROW ID           ( [((ID1, CE.Input),
                                          (ID2, CE.Input)),
                                         ((ID1, CE.Output),
                                          (ID2, CE.Output)),
                                         ((ID2, CE.Input),
                                          (ID1, CE.Input)),
                                         ((ID2, CE.Output),
                                          (ID1, CE.Output))])
           | action RARROW action     ([(action1, action2)])
           | action DBLARROW action   ([(action1, action2),
                                        (action2, action1)])