% Hampp
% version 0.2
% Public domain

\input birdstyle

\birdleftrule=1pt
\emergencystretch=1em

\def\hugebreak{\penalty-600\vskip 30pt plus 8pt minus 4pt\relax}
\newcount\chapno
\def\: #1.{\advance\chapno by 1\relax\hugebreak{\bf\S\the\chapno. #1. }}

\: Introduction. This is preprocessor for Haskell programming, supporting
macros, named chunks, include files, and a few other features. (I intend
to include more features in future.)

> module Main (main) where {

Imports:

> import Control.Applicative;
> import Control.Monad;
> import Data.List;
> import Data.Map (Map);
> import qualified Data.Map as M;
> import Data.Monoid;
> import Debug.Trace;
> import Language.Haskell.Preprocessor;
> import Language.Haskell.Preprocessor.Error (Error);
> import Language.Haskell.Preprocessor.Loc;
> import System.Directory;
> import System.Environment;
> import System.FilePath;
> import System.IO;
> import System.IO.Error;

\: Utility Functions.

> instance Alternative IO where {
>   empty = fail [];
>   x <|> y = catch x $ \e -> modifyIOError
>    (\z -> if z == userError [] then e else z) y;
> };

> bool :: x -> x -> Bool -> x;
> bool x _ False = x;
> bool _ x True = x;

> choice :: Alternative f => [f x] -> f x;
> choice = foldr (<|>) empty;

> (<>>=) :: (Functor m, Monad m) => m a -> (a -> m b) -> m a;
> x <>>= f = x >>= ap (<$) f;
> infixl 1 <>>=;

> transEnum :: (Enum x, Enum y) => x -> y;
> transEnum = toEnum . fromEnum;

> whenMaybe :: Applicative f => Maybe x -> (x -> f ()) -> f ();
> whenMaybe x f = maybe (pure ()) f x;

> mvAppend :: (Ord x, Monoid y) => x -> y -> Map x y -> Map x y;
> mvAppend = M.insertWith mappend;

> mvChange :: (Ord x, Monoid y) => x -> (y -> y) -> Map x y -> Map x y;
> mvChange k f = M.insertWith (flip $ const . f) k (f mempty);

> dropWhileEnd :: (a -> Bool) -> [a] -> [a];
> dropWhileEnd p = foldr
>  (\x xs -> if p x && null xs then [] else x : xs) [];

> ltrim :: String -> String;
> ltrim = dropWhile (' ' >=);

> rtrim :: String -> String;
> rtrim = dropWhileEnd (' ' >=);

\: Include Files. First step is replacing include files.

> theSearchPath :: IO [FilePath];
> theSearchPath = (splitSearchPath <$> getEnv "HAMPPPATH") <|> pure ["."];

> includeFiles :: [FilePath] -> [Ast] -> IO [Ast];
> includeFiles _ [] = return [];
> includeFiles p (Single (Token { val = '#':'I':' ':v }) : t) =
>  liftA2 (++) (includeOne p $ rtrim v) (includeFiles p t);
> includeFiles p (Single (Token { val = '#':'J':' ':v }) : t) =
>  liftA2 (++) (includeMany $ rtrim v) (includeFiles p t);
> includeFiles p (x @ Block { body = v } : t) = liftA2
>  (\y -> (x { body = y } :)) (includeFiles p v) (includeFiles p t);
> includeFiles p (h : t) = (h :) <$> includeFiles p t;

> runIncludeFiles :: [Ast] -> IO [Ast];
> runIncludeFiles a = theSearchPath >>= \p -> includeFiles p a;

> includeOne :: [FilePath] -> FilePath -> IO [Ast];
> includeOne p f = choice ((fileLoadX mySpec f . (</> f)) <$> p)
>  >>= either (fail . show) (includeFiles p);

To look for wildcard files, it will use only the current directory, or a
different directory if that is specified in the filename to include. Note
that on Windows, it must match case insensitive, and on UNIX, it has to be
case sensitive.

> includeMany :: FilePath -> IO [Ast];
> includeMany f = error "Wildcard includes not currently implemented";

Some files are literate Haskell, or other formats, so it must know how to
load them differently.

> data FileType = Haskell | LiterateHaskell;

> fileType :: String -> FileType;
> fileType ".hs" = Haskell;
> fileType ".inc" = Haskell;
> fileType ".lhs" = LiterateHaskell;
> fileType ".linc" = LiterateHaskell;
> fileType ".tex" = LiterateHaskell;
> fileType x = error ("Unknown file extension: " ++ x);

> fileLoadX :: SynSpec -> String -> FilePath -> IO (Either Error [Ast]);
> fileLoadX sp nm fp = case fileType (takeExtension fp) of {
>   Haskell -> fileLoad sp nm fp;
>   LiterateHaskell -> parseBy sp nm . unliterate <$> readFile fp;
> };

Currently this function is only for bird-style program.

> unliterate :: String -> String;
> unliterate = unlines . fmap (\x -> case x of {
>   '>' : t -> ' ' : t;
>   _ -> [];
> }) . lines;

\: Parsing Corrections. A few things from the preprocessor package have
some mistakes, which can be corrected here. Some functions are also
missing, which I can correct in this way.

This function {\tt adjacent} to check if two tokens are adjacent, without
any spaces in between.

> adjacent :: Token -> Token -> Bool;
> adjacent xt yt = let { x = getLoc xt; y = getLoc yt; } in
>  not (isBogus x) && file x == file y && line x == line y &&
>  col y >= col x && col y - col x <= length (val xt);

Fixes include qualified names/operators, octal/hexadecimal literals, and
template haskell name quotations (syntax is changed to {\tt.} instead of
{\tt'} in front of names). The feature to use binary integer literals has
been added. In addition, trailing spaces are removed from C-like
directives, and words with {\tt8} at the start are special commands for
the macro processor in this program.

> fixAst :: [Ast] -> [Ast];
> fixAst [] = [];
> fixAst (Single (x @ Token { tag = Variable, val = n }) :
>  Single (y @ Token { tag = Operator, val = '.' : o @ (_ : _) }) : t)
>  | adjacent x y = Single (x { tag = Operator, val = n ++ ('.' : o) })
>  : fixAst t;
> fixAst (Single (x @ Token { tag = Variable, val = n }) :
>  Single (y @ Token { tag = Operator, val = "." }) :
>  Single (z @ Token { tag = Variable, val = v }) : t) | adjacent x y &&
>  adjacent y z = fixAst
>  (Single (z { tag = Variable, val = n ++ "." ++ v }) : t);
> fixAst (Single (x @ Token { val = "0" }) :
>  Single (y @ Token { tag = Variable, val = v }) : t) | adjacent x y =
>  case (head v) of {
>    'x' -> Single (x { val = '0' : v }) : fixAst t;
>    'o' -> Single (x { val = '0' : v }) : fixAst t;
>    'b' -> Single (x { val = show $ readBinaryInt (tail v) }) : fixAst t;
>    _ -> Single x : Single y : fixAst t;
>  };
> fixAst (Single (x @ Token { val = "0" }) :
>  Single (y @ Token { tag = CharLit, val = v }) : t) | adjacent x y =
>  Single (x { val = show $ fromEnum (read v :: Char) }) : fixAst t;
> fixAst (Single (x @ Token { val = "8" }) :
>  Single (y @ Token { tag = Variable, val = v }) : t) | adjacent x y =
>  Single (x { tag = Variable, val = '8' : v }) : fixAst t;
> fixAst (Single (x @ Token { val = "." }) :
>  Single (y @ Token { tag = Variable, val = v }) : t) | adjacent x y =
>  Single (x { tag = Variable, val = '\'' : v }) : fixAst t;
> fixAst (Single (x @ Token { val = ".." }) :
>  Single (y @ Token { tag = Variable, val = v }) : t) | adjacent x y =
>  Single (x { tag = Variable, val = '\'' : '\'' : v }) : fixAst t;
> fixAst (x @ Block { body = v } : t) = x { body = fixAst v } : fixAst t;
> fixAst (Single (x @ Token { tag = CPragma, val = v }) : t) =
>  Single (x { val = rtrim v }) : fixAst t;
> fixAst (h : t) = h : fixAst t;

> readBinaryInt :: String -> Integer;
> readBinaryInt = f . reverse where {
>   f [] = 0;
>   f ('0' : x) = 2 * f x;
>   f ('1' : x) = succ (2 * f x);
> };

The default spec is changed.

> mySpec :: SynSpec;
> mySpec = SynSpec {
>   unboxed = True,
>   pragmas = False,
>   levelnest = False,
>   blocks = [
>     pair "(" ")",
>     pair "[" "]",
>     pair "{" "}"
>   ]
> };

\: Reordering. After {\tt fixAst}, reordering of sections is done, in a
similar way to WEB.

First split.

> splitToSections :: String -> Int -> String -> [Ast] -> Map String [Ast];
> splitToSections _ _ _ [] = M.empty;
> splitToSections q i _ (Single (Token { val = '#':'P':_ }) : t) =
>  splitToSections q i q t;
> splitToSections _ i cur (Single (Token { val = '#':'\SO':v }) : t) =
>  splitToSections v i v t;
> splitToSections q i _ (Single (Token { val = '#':'{':v }) : t) =
>  splitToSections q i (init v) t;
> splitToSections q i cur ((x @ Block { body = b @ (_ : _ : _) }) : t) =
>  mvAppend cur [x { body = [Single $
>  newToken { val = '\SI' : show i }] }] $
>  splitToSections (show i) (succ i) (show i)
>  (b ++ (Single (newToken { val = '#':'\SO':cur }) : t));
> splitToSections q i cur (h : t) = mvAppend cur [h]
>  $ splitToSections q i cur t;

And then, recombine.

> recombineSections :: Map String [Ast] -> [Ast] -> [Ast];
> recombineSections _ [] = [];
> recombineSections m (Block { item = Token { val = "{" },
>  body = [Single (Token { tag = StringLit, val = v })] } : t) =
>  recombineSections m ((m M.! v) ++ t);
> recombineSections m (Single (Token { val = '\SI' : v }) : t) =
>  recombineSections m ((m M.! v) ++ t);
> recombineSections m (h @ Block { body = b } : t) =
>  h { body = recombineSections m b } : recombineSections m t;
> recombineSections m (h : t) = h : recombineSections m t;

Do together.

> reorderProg :: [Ast] -> [Ast];
> reorderProg = (recombineSections <*> (M.! [])) . splitToSections []0[];

\: Macro Processing.

> type MacroState x = (Map String [Ast], x);

> macroProc :: MacroState [Ast] -> [Ast];
> macroProc (_, []) = [];
> macroProc (mac, Single(x @ Token { tag = CPragma, val = '#':'D':' ':v })
>  : t) = let { (a, b) = break (' ' >=) v; } in macroProc (M.insert a
>  (either (error . show) fixAst $ parseBy mySpec "<macro>" b) mac, t);
> macroProc (mac, Single (x @ Token { tag = Variable, val = v }) : t)
>  | M.member v mac = macroProc (mac, (mac M.! v) ++ t);
> macroProc (mac, Single (x @ Token { tag = Variable, val = '8':v }) : t)
>  = macroProc $ macroCmd v (mac, t);
> macroProc (mac, Single (x @ Token { val = '\DLE' : v }) : t)
>  = Single (x { val = v }) : macroProc (mac, t);
> macroProc (mac, h @ Block { body = b } : t) =
>  h { body = macroProc (mac, b) } : macroProc (mac, t);
> macroProc (mac, h : t) = h : macroProc (mac, t);

> macroCmd :: String -> MacroState [Ast] -> MacroState [Ast];

{\tt8append}: Append token to macro.

> macroCmd "append" (mac, Single (Token { val = v }) : h : t) =
>  (mvAppend v [h] mac, t);

{\tt8appendblock}: Append many tokens to macro.

> macroCmd "appendblock" (mac, Single (Token { val = v })
>  : Block { body = b } : t) = (mvAppend v b mac, t);

{\tt8appendcopy}: Append copy of another macro to a macro.

> macroCmd "appendcopy" (mac, Single (Token { val = v1 }) :
>  Single (Token { val = v2 }) : t) = (mvAppend v1 (mac M.! v2) mac, t);

{\tt8calculate}: Perform calculation block (see next chapter).

> macroCmd "calculate" (mac, Block { body = b } : t) =
>  (mac, calcAst [] (macroProc (mac, b)) ++ t);

{\tt8close}: Close a block.

> macroCmd "close" (mac, t) = (mac, Single (newToken { val = "}" }) : t);

{\tt8copy}: Copy macro.

> macroCmd "copy" (mac, Single (Token { val = v1 }) :
>  Single (Token { val = v2 }) : t) = (M.insert v1 (mac M.! v2) mac, t);

{\tt8data}: Make list of constructors to data constructor declarations.

> macroCmd "data" (mac, Single (Token { val = v }) : t) =
>  (mac, case (macDeclareData [] (mac M.! v)) of {
>  [] -> []; _ : x -> Single (newToken { val = "=" }) : x; } ++ t);

{\tt8debug\char`_macros}: Show all macros for debugging.

> macroCmd "debug_macros" (mac, t) = (mac, traceShow mac t);

{\tt8debug\char`_show}: Show a message for debugging.

> macroCmd "debug_show" (mac, h : t) = (mac, traceShow h t);

{\tt8decrement}: Decrement numeric tokens in macro.

> macroCmd "decrement" (mac, Single (Token { val = v }) : t) =
>  (mvChange v decrAst mac, t);

{\tt8define}: Define a macro to a single token.

> macroCmd "define" (mac, Single (Token { val = v }) : h : t) =
>  (M.insert v [h] mac, t);

{\tt8defineblock}: Define a macro to many tokens.

> macroCmd "defineblock" (mac, Single (Token { val = v })
>  : Block { body = b } : t) = (M.insert v b mac, t);

{\tt8delete}: Delete macro.

> macroCmd "delete" (mac, Single (Token { val = v }) : t) =
>  (M.delete v mac, t);

{\tt8expand}: Expand token and create macro.

> macroCmd "expand" (mac, Single (Token { val = v }) : h : t) =
>  (M.insert v (macroProc (mac, [h])) mac, t);

{\tt8fieldlist}: Make list of fields with commas instead of semicolons,
hiding anything other than the one with type signature.

> macroCmd "fieldlist" (mac, Single (Token { val = v }) : t) =
>  (mac, (macFieldList $ splitSemis (mac M.! v)) ++ t);

{\tt8fieldval}: Make list of fields with commas instead of semicolons,
keeping only value equations rather than type signatures.

> macroCmd "fieldval" (mac, Single (Token { val = v }) : t) =
>  (mac, (macFieldVal "," $ splitSemis (mac M.! v)) ++ t);

{\tt8fieldvalues}: Similar to above but keep semicolons.

> macroCmd "fieldvalues" (mac, Single (Token { val = v }) : t) =
>  (mac, (macFieldVal ";" $ splitSemis (mac M.! v)) ++ t);

{\tt8global}: Cause macros in block to affect global state.

> macroCmd "global" (mac, Block { item = i, body = b, next = n } : t) =
>  (mac, Single i : b ++ (n : t));

{\tt8ifdef}: True if macro is defined.

> macroCmd "ifdef" (mac, Single (Token { val = v }) : h : t) =
>  (mac, bool t (h : t) (M.member v mac));

{\tt8ifeq}: True if macros are equivalent.

> macroCmd "ifeq" (mac, Single (Token { val = v1 }) :
>  Single (Token { val = v2 }) : h : t) =
>  (mac, bool t (h : t) (M.lookup v1 mac == M.lookup v2 mac));

{\tt8ifndef}: True if macro is not defined.

> macroCmd "ifndef" (mac, Single (Token { val = v }) : h : t) =
>  (mac, bool (h : t) t (M.member v mac));

{\tt8ifeq}: True if macros are not equivalent.

> macroCmd "ifneq" (mac, Single (Token { val = v1 }) :
>  Single (Token { val = v2 }) : h : t) =
>  (mac, bool t (h : t) (M.lookup v1 mac /= M.lookup v2 mac));

{\tt8increment}: Increment numeric tokens in macro.

> macroCmd "increment" (mac, Single (Token { val = v }) : t) =
>  (mvChange v incrAst mac, t);

{\tt8local}: Remove delimiters from block while keeping macro effects
local.

> macroCmd "local" (mac, h : t) =
>  (mac, h { item = Token Comment [] bogus [], next = Empty } : t);

{\tt8localvar}: Call a macro locally with a parameter.

> macroCmd "localvar" (mac, Single (Token { val = n }) : x : y : t) =
>  (mac, macroProc (M.insert n [y] mac, [x]) ++ t);

{\tt8open}: Open a block.

> macroCmd "open" (mac, t) = (mac, Single (newToken { val = "{" }) : t);

{\tt8quote}: Turn off expansion.

> macroCmd "quote" (mac, Single (x @ Token { val = v }) : t) =
>  (mac, Single (x { val = '\DLE' : v }) : t);

{\tt8quotestring}: Change a string into a token without expansion.

> macroCmd "quotestring" (mac, Single (x @ Token { val = v }) : t) =
>  (mac, Single (x { val = '\DLE' : read v }) : t);

{\tt8readstring}: Change a string into a token with expansion.

> macroCmd "readstring" (mac, Single (x @ Token { val = v }) : t) =
>  (mac, Single (x { val = read v }) : t);

{\tt8string}: Convert token to string literal.

> macroCmd "string" (mac, Single (x @ Token { val = v }) : t) =
>  (mac, Single (x { tag = StringLit, val = show v }) : t);

Everything else is error.

> macroCmd x _ = error $ "Unknown macro 8" ++ x;

Others:

> incrAst :: [Ast] -> [Ast];
> incrAst [] = [];
> incrAst (Single (x @ Token { tag = IntLit, val = v }) : t) =
>  Single (x { val = show (succ (read v :: Integer)) }) : incrAst t;
> incrAst (h : t) = h : incrAst t;

> decrAst :: [Ast] -> [Ast];
> decrAst [] = [];
> decrAst (Single (x @ Token { tag = IntLit, val = v }) : t) =
>  Single (x { val = show (pred (read v :: Integer)) }) : decrAst t;
> decrAst (h : t) = h : decrAst t;

> macDeclareData :: [String] -> [Ast] -> [Ast];
> macDeclareData _ [] = [];
> macDeclareData s (Single x : t) = bool [Single $ newToken { val = "|" },
>  Single x] [] (elem (val x) s) ++ macDeclareData (val x : s) t;
> macDeclareData s (Block { body = b } : t) =
>  let { Single x : _ = b; } in bool (Single
>  (newToken { val = "|" }) : b) [] (elem (val x) s)
>  ++ macDeclareData (val x : s) t;
> macDeclareData s (Empty : t) = macDeclareData s t;

> macFieldList :: [[Ast]] -> [Ast];
> macFieldList [] = [];
> macFieldList ([] : t) = macFieldList t;
> macFieldList (h : t) = bool [] (h ++ [Single $ newToken { val = "," }])
>  (any (valIs "::") h && not (any (valIs "=") h))
>  ++ macFieldList t;

> macFieldVal :: String -> [[Ast]] -> [Ast];
> macFieldVal _ [] = [];
> macFieldVal s ([] : t) = macFieldVal s t;
> macFieldVal s (h : t) = bool [] (h ++ [Single $ newToken { val = s }])
>  (any (valIs "=") h) ++ macFieldVal s t;

\: Calculation.

> type Calc = Either Integer String;

> calcAst :: [Calc] -> [Ast] -> [Ast];
> calcAst _ [] = [];

Integer literals.

> calcAst c (Single (Token { tag = IntLit, val = v }) : t) =
>  calcAst (Left (read v) : c) t;

String literals.

> calcAst c (Single (Token { tag = StringLit, val = v }) : t) =
>  calcAst (Right (read v) : c) t;

{\tt+} Addition or string concatenation.

> calcAst (Left x : Left y : z) (Single (Token { val = "+" }) : t) =
>  calcAst (Left (y + x) : z) t;
> calcAst (Right x : Right y : z) (Single (Token { val = "+" }) : t) =
>  calcAst (Right (y ++ x) : z) t;

{\tt-} Subtraction or remove characters from string.

> calcAst (Left x : Left y : z) (Single (Token { val = "-" }) : t) =
>  calcAst (Left (y - x) : z) t;
> calcAst (Right x : Right y : z) (Single (Token { val = "-" }) : t) =
>  calcAst (Right (filter (flip notElem x) y) : z) t;

{\tt*} Multiplication, string repetition, or keep only certain characters
in the string.

> calcAst (Left x : Left y : z) (Single (Token { val = "*" }) : t) =
>  calcAst (Left (y * x) : z) t;
> calcAst (Left x : Right y : z) (Single (Token { val = "*" }) : t) =
>  calcAst (Right (join $ genericReplicate x y) : z) t;
> calcAst (Right x : Right y : z) (Single (Token { val = "*" }) : t) =
>  calcAst (Right (filter (flip elem x) y) : z) t;

{\tt/} Division.

> calcAst (Left x : Left y : z) (Single (Token { val = "/" }) : t) =
>  calcAst (Left (div y x) : z) t;

{\tt\%} Modulo.

> calcAst (Left x : Left y : z) (Single (Token { val = "%" }) : t) =
>  calcAst (Left (mod y x) : z) t;

{\tt<} Less.

> calcAst (Left x : Left y : z) (Single (Token { val = "<" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y < x)) : z) t;
> calcAst (Right x : Right y : z) (Single (Token { val = "<" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y < x)) : z) t;

{\tt>} Greater.

> calcAst (Left x : Left y : z) (Single (Token { val = ">" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y > x)) : z) t;
> calcAst (Right x : Right y : z) (Single (Token { val = ">" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y > x)) : z) t;

{\tt=} Equal.

> calcAst (Left x : Left y : z) (Single (Token { val = "=" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y == x)) : z) t;
> calcAst (Right x : Right y : z) (Single (Token { val = "=" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y == x)) : z) t;

{\tt<>} Unequal.

> calcAst (Left x : Left y : z) (Single (Token { val = "<>" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y /= x)) : z) t;
> calcAst (Right x : Right y : z) (Single (Token { val = "<>" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y /= x)) : z) t;

{\tt<=} Less or equal.

> calcAst (Left x : Left y : z) (Single (Token { val = "<=" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y <= x)) : z) t;
> calcAst (Right x : Right y : z) (Single (Token { val = "<=" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y <= x)) : z) t;

{\tt>=} Greater or equal.

> calcAst (Left x : Left y : z) (Single (Token { val = ">=" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y >= x)) : z) t;
> calcAst (Right x : Right y : z) (Single (Token { val = ">=" }) : t) =
>  calcAst (Left (toInteger $ fromEnum (y >= x)) : z) t;

{\tt;} Drop from stack.

> calcAst (_ : y) (Single (Token { val = ";" }) : t) =
>  calcAst y t;

{\tt\$} Swap values on stack.

> calcAst (x : y : z) (Single (Token { val = "$" }) : t) =
>  calcAst (y : x : z) t;

{\tt@} Convert to showable form.

> calcAst (x : y) (Single (Token { val = "@" }) : t) =
>  calcAst (Right (either show show x) : y) t;

{\tt?} Convert ASCII value to string.

> calcAst (Left x : y) (Single (Token { val = "?" }) : t) =
>  calcAst (Right [toEnum $ fromInteger x] : y) t;

{\tt,} Enter tokens into program.

> calcAst (Left x : y) (Single (Token { val = "," }) : t) =
>  Single (newToken { tag = IntLit, val = show x }) : calcAst y t;
> calcAst (Right x : y) (Single (Token { val = "," }) : t) =
>  either (error . show) id (parseBy mySpec "<macro>" x) ++ calcAst y t;

{\tt:} Take first character of string.

> calcAst (Right [] : z) (Single (Token { val = ":" }) : t) =
>  calcAst (Left 0 : Right [] : z) t;
> calcAst (Right (x : y) : z) (Single (Token { val = ":" }) : t) =
>  calcAst (Left (toInteger $ fromEnum x) : Right y : z) t;

{\tt()} Conditional block.

> calcAst (Left x : y) (Block { item = Token { val = "(" },
>  body = b } : t) | x /= 0 = calcAst y (b ++ t);
> calcAst (Right (_ : _) : y) (Block { item = Token { val = "(" },
>  body = b } : t) = calcAst y (b ++ t);
> calcAst (_ : y) (Block { item = Token { val = "(" }, body = b } : t) =
>  calcAst y t;

{\tt[]} Looping block.

> calcAst c (h @ Block { item = Token { val = "[" }, body = b } : t) =
>  calcAst c (h { item = newToken { val = "(" }, body = b ++ [h] } : t);

{\tt\char`\{\char`\}} For/foreach loop.

> calcAst (Left x : y) (Block { item = Token { val = "{" },
>  body = b } : t) = calcAst y (join (genericReplicate x b) ++ t);
> calcAst (Right x : y) (Block { item = Token { val = "{" },
>  body = b } : t) = calcAst y ((x >>= \z -> Single
>  (newToken { tag = IntLit, val = show $ fromEnum z }) : b) ++ t);

Everything else is ignored.

> calcAst c (_ : t) = calcAst c t;

\: Comma Elimination. In blocks with curly braces and with square
brackets, consecutive commas with nothing in between can be eliminated and
final comma removed. So that you can write a comma after every line in a
field list of a record or a list data. (For parentheses, it should not
eliminate commas in this way since that is type for tuples)

First parameter will be true if inside a block to eliminate commas.

This also changes {\tt(\#} and {\tt\#)} to {\tt(} and {\tt)} so that you
can use those to override blocking and macros.

> commaElim :: Bool -> [Ast] -> [Ast];
> commaElim _ [] = [];
> commaElim True [Single (Token { val = "," })] = [];
> commaElim True (x @ (Single (Token { val = "," })) :
>  Single (Token { val = "," }) : t) = commaElim True (x : t);
> commaElim b (x @ Block { item = Token { val = v }, body = y } : t) =
>  x { body = commaElim (v == "[" || v == "{") y } : commaElim b t;
> commaElim b (Single (x @ Token { val = "(#" }) : t) =
>  Single (x { val = "(" }) : commaElim b t;
> commaElim b (Single (x @ Token { val = "#)" }) : t) =
>  Single (x { val = ")" }) : commaElim b t;
> commaElim b (h : t) = h : commaElim b t;

\: Output. The existing {\tt dump} function seems long to me, and doesn't
seems to work well anyways, so I wrote my own. (This one does not support
layout, though. Actually, this entire program does not support layout.)

> writeTokens :: Handle -> Loc -> [Token] -> IO ();
> writeTokens _ _ [] = pure ();
> writeTokens h l (x : t) = writeUpdateLoc h l (loc x) >>
>  hPutStr h (val x) >> writeTokens h (advance (loc x) (val x)) t;

> writeUpdateLoc :: Handle -> Loc -> Loc -> IO ();
> writeUpdateLoc h x y | isBogus y = unless (isBogus x) $ hPutChar h '\n';
> writeUpdateLoc h x y | (file x, line x) == (file y, line y)
>  && col x <= col y = hPutStr h $ replicate (col y - col x) ' ';
> writeUpdateLoc h x y | (file x, line x + 1) == (file y, line y) =
>  hPutStr h $ '\n' : replicate (col y - 1) ' ';
> writeUpdateLoc h x y = hPutStr h $ "\n# " ++ show (line y) ++ " "
>  ++ show (file y) ++ "\n" ++ replicate (col y - 1) ' ';

> myFileDump :: FilePath -> [Ast] -> IO ();
> myFileDump p a = withFile p WriteMode $ \h -> writeTokens h bogus $
>  flattenList a [];

\: Main Program. This is the main program as required by the {\tt-pgmF}
option for GHC.

> main :: IO ();
> main = getArgs >>= \(orig : cur : outf : _) -> fileLoad mySpec orig cur
>  >>= either (fail . show) (runIncludeFiles >=> myFileDump outf
>  . commaElim False . macroProc . (,) M.empty . reorderProg . fixAst);

There are a few for testing.

> testFile :: FilePath -> IO [Ast];
> testFile fp = fileLoad mySpec fp fp >>= either (fail . show)
>  (runIncludeFiles >=> return . commaElim False . macroProc
>  . (,) M.empty . reorderProg . fixAst);

% End of document (final "}" is suppressed from printout)
\toks0={{

> } -- }\bye