The tasq programming language

tasq is a macro-expansion language with a single task queue and a small set of operations.

Syntax

A tasq program is a sequence of declarations or comments, optionally separated by whitespace.

A comment starts with a dot (.) and continues to the end of the line.

A declaration is an identifier followed by zero or more operations, and ending with a dot (.). Whitespace may separate identifiers and operations, but is otherwise ignored.

An operation is an identifier or one of +, -, ~, or ?.

An identifier is an uninterrupted sequence of non-whitespace characters not including +, -, ~, and ?.

A declaration of an identifier with zero following operations adds the identifier to the end of the task queue.

A declaration of an identifier followed by one or more operations defines the identifier's expansion as those operations.

It is illegal to use undefined identifiers. It is illegal to have more than one definition for an identifier.

Execution

Execution consists of dequeuing and executing the top item of the task queue repeatedly while the task queue is not empty.

Operations

+ Write 1 to the output.
- Write 0 to the output.
~ Discard the next item in the task queue.
? Read one bit from the input. If 1 is read, do nothing. If 0 is read, discard the next item in the task queue. If at EOF, discard the next two items in the task queue.
identifier Append the identifier's expansion to the end of the task queue.

Examples

Hello world:

w-+--+----++--+-+-++-++---++-++---++-++++--+------+++-
+++-++-++++-+++--+--++-++---++--+----+----+----+-+-.w.

cat:

bit? 1 0. .Read a bit
0 -bit.   .Write 0, handle next bit
1 +~.     .Write 1, discard the ensuing -
bit.      .Initial task queue

Self-printing program (formatted as multiple lines, but should be a 1-liner):

d.0-z.1+o.z--+-------++----.o--+-------++---+.q p.p--+------+++---+--+-+++--
 ---+-+-.d 0 1 1 0 0 1 0 0 0 0 1 0 1 1 1 0 0 0 1 1 0 0 0 0 0 0 1 0 1 1 0 1 0
 1 1 1 1 0 1 0 0 0 1 0 1 1 1 0 0 0 1 1 0 0 0 1 0 0 1 0 1 0 1 1 0 1 1 0 1 1 1
 1 0 0 1 0 1 1 1 0 0 1 1 1 1 0 1 0 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1
 0 1 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1
 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 0 1 1 0 0 1 0 1 0 1 1 0
 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 1
 0 0 1 1 0 1 1 1 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 0 1 1 0 0 1 0 1
 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1
 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 0 1 1 0 0 1 0 1 0 1 1 0 0 1 0 1 1 0 1 0
 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 0 1 1 0 0 1 0 1 1 1 0 0 1 1 1 0 0 0
 1 0 0 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 0 1 1 1 0 0 1 1 1 0 0 0 0 0 0 1 0 1
 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 0 1 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1
 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 0 1 1 0
 0 1 0 1 0 1 1 0 0 1 0 1 0 1 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0
 1 0 0 1 0 1 0 1 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 0 1 1 0 0 1 0 1
 1 0 1 0 0 1 0 1 0 1 1 0 0 1 0 1 0 1 1 0 0 1 0 1 0 1 1 0 0 1 0 1 1 0 1 0 0 1
 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 0 1 0 0 1 0 1 0 1 1 0
 0 1 0 1 1 0 1 0 0 1 0 1 0 1 1 0 0 1 0 1 1 0 1 0 0 1 0 1 1 1 0 0 1 1 0 0 1 0
 0 q.

Interpreter

module Main(main) where

import Data.Map(Map,empty,insert,(!))
import Data.Bits(testBit)
import Data.Char(chr,ord)
import System.Environment(getArgs)
import Text.ParserCombinators.Parsec(CharParser,anyChar,char,getState,many,many1,manyTill,newline,noneOf,runParser,setState,space,spaces,(<|>),(<?>))

data Task = Out0 | Out1 | In | Discard | Task String

parse :: String -> String -> (String -> [Task],[Task])
parse file src =
    either (error . show) id (runParser program (empty,[]) file src)

type Parser a = CharParser (Map String [Task],[Task]) a

program :: Parser (String -> [Task],[Task])
program = do
    many (space <|> comment)
    many statement
    (map,queue) <- getState
    return ((map !),reverse queue)

comment :: Parser Char
comment = do
    char '.'
    manyTill anyChar newline
    return ' '

statement :: Parser ()
statement = do
    id <- name
    body <- many task
    char '.'
    many (space <|> comment)
    (map,queue) <- getState
    setState (if null body then (map,Task id:queue)
                           else (insert id body map,queue))

task :: Parser Task
task = do
    t <-    (char '-' >> return Out0)
        <|> (char '+' >> return Out1)
        <|> (char '?' >> return In)
        <|> (char '~' >> return Discard)
        <|> fmap Task name
    spaces
    return t

name :: Parser String
name = do
    str <- many1 (noneOf "+-?~. \r\n\t\f\v")
    spaces
    return str

run :: (String -> [Task]) -> [Task] -> [Bool] -> [Bool]
run _ [] _ = []
run defs (Out0:tasks) input = False : run defs tasks input
run defs (Out1:tasks) input = True : run defs tasks input
run defs (In:[]) _ = []
run defs (In:_:[]) [] = []
run defs (In:_:_:tasks) [] = run defs tasks []
run defs (In:_:tasks) (False:input) = run defs tasks input
run defs (In:tasks) (True:input) = run defs tasks input
run defs (Discard:[]) _ = []
run defs (Discard:_:tasks) input = run defs tasks input
run defs (Task name:tasks) input = run defs (tasks ++ (defs name)) input

main :: IO ()
main = do
    (file:_) <- getArgs
    src <- readFile file
    interact (fromBits . uncurry run (parse file src) . toBits)

toBits = concatMap (flip map [7,6..0] . testBit . ord)

fromBits (b7:b6:b5:b4:b3:b2:b1:b0:rest) =
    chr ((if b7 then 128 else 0) + (if b6 then 64 else 0)
       + (if b5 then 32  else 0) + (if b4 then 16 else 0)
       + (if b3 then 8   else 0) + (if b2 then 4  else 0)
       + (if b1 then 2   else 0) + (if b0 then 1  else 0)) : fromBits rest
fromBits _ = []