Frank-0.3: keylog.fk

sig ReadLine
  = peek [] Char
  | nom

sig Abort
  = aborting [] {}

abort [Abort] X
abort = aborting ! {}

default {[] X} [Abort ? X] [] X
default d [x] = x
default d [aborting ? k] = d!

{[Abort] X} / {[] X} [] {[] X}
e / d = {default d ? e!}

if Bool then {[] X} else {[] X} [] X
if tt then t else f = t!
if ff then t else f = f!

see Char [ReadLine, Abort] ()
see c = if (peek! =Char= c) then {()} else {abort!}

eat Char [ReadLine, Abort] ()
eat c = see c >> nom!



() >> Y [] Y
_ >> y = y

X << () [] X
x << _ = x

data List X
  = nil
  | X :: (List X)

data SExp
  = atom (List Char)
  | SExp & SExp

sexp [ReadLine, Abort] SExp
sexp =
  ({see '.' >> abort!} /
   ({eat '(' >> open!} /
    ({see ')' >> abort!} /
     ({eat ' ' >> sexp!} /
      {atom (name!)}
  ))))!

open [ReadLine, Abort] SExp
open =
  ({see '.' >> abort!} /
   ({eat ' ' >> open!} /
    ({eat ')' >> atom nil} /
     {sexp! & cdr!}
  )))!

cdr [ReadLine, Abort] SExp
cdr =
  ({eat ' ' >> cdr!} /
   ({eat '.' >> (sexp! << close!)} /
    {open!}
  ))!

close [ReadLine, Abort] ()
close =
  ({eat ' ' >> close!} /
   ({eat ')'} /
    {abort!}
  ))!

elem Char (List Char) [] Bool
elem c nil = ff
elem c (c' :: cs) = if (c =Char= c') then {tt} else {elem c cs}

nameChar [ReadLine, Abort] Char
nameChar = if (elem (peek!) ('\n' :: (' ' :: ('(' :: (')' :: ('.' :: nil))))))
  then {abort!}
  else {(peek! << nom!)}

some {[ReadLine, Abort] X} [ReadLine, Abort] List X
some p = (p!) :: many p

many {[ReadLine, Abort] X} [ReadLine] List X
many p = ({some p} / {nil})!

name [ReadLine, Abort] List Char
name = some nameChar

data Maybe X = no | yes X

let X in {X -> [] Y} [] Y
let x in f = f x

noBS (Maybe Char) [ReadLine ? X] [Console] X
noBS _ [x] = x
noBS no [peek ? k] = let inch! in {c -> noBS (yes c) ? k c}
noBS (yes c) [peek ? k] = noBS (yes c) ? k c
noBS _ [nom ? k] = noBS no ? k ()

data Stk X
  = (Stk X) -peek {Char -> [ReadLine, Abort] X}
  | (Stk X) -nom
  | root {[ReadLine, Abort] X}

withBS (Stk X) (Maybe Char) [ReadLine, Abort, {} ? X] [Console] X
withBS stk _ [x] = x
withBS stk no [peek ? k] = let inch! in
  { '\b' -> pop stk
  | c -> withBS (stk -peek k) (yes c) ? k c
  }
withBS stk (yes c) [peek ? k] = withBS stk (yes c) ? k c
withBS stk (yes c) [nom ? k] = ouch c >> withBS (stk -nom) no ? k ()
withBS stk _ [aborting ? l] = pop stk

note There's a need for indexing here, to prevent nom! before peek!

pop (Stk X) [Console] X
pop (stk -peek k) = withBS stk no ? k (peek!)
pop (stk -nom) = ouch '\b' >> (ouch ' ' >> (ouch '\b' >> pop stk))
pop (root r) = withBS (root r) no ? r!

main [Console] SExp
main = withBS (root {sexp!}) no ? sexp!

note
  main [Console, Abort] SExp
  main = noBS no ? sexp!