hampp (empty) → 0.2

raw patch · 3 files changed

+723/−0 lines, 3 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, directory, filepath, preprocessor-tools

Files

Main.lhs +682/−0
Setup.hs +2/−0
hampp.cabal +39/−0

+ Main.lhs view

@@ -0,0 +1,682 @@+% 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

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ hampp.cabal view

@@ -0,0 +1,39 @@+Name:                hampp
+-- The package version. See the Haskell package versioning policy
+-- http://www.haskell.org/haskellwiki/Package_versioning_policy for
+-- standards guiding when and how versions should be incremented.
+Version:             0.2
+Synopsis:            Haskell macro preprocessor
+License:             PublicDomain
+Category:            Preprocessor
+Build-type:          Simple
+Cabal-version:       >=1.6
+Tested-with:         GHC == 7.0.3
+
+X-Printout-Mode:     PlainTeX
+X-Printout-Main:     Main.lhs
+X-Printout-Require:  birdstyle.tex
+
+Executable hampp
+  Main-is:             Main.lhs
+  Build-depends:
+    base == 4.*,
+    bytestring >= 0.9.1.10 && < 0.10,
+    containers >= 0.4.0.0 && < 0.5,
+    directory >= 1.1 && < 1.2,
+    filepath >= 1.2.0.0 && < 1.4,
+    preprocessor-tools >= 0.1.2 && < 0.2
+
+---- Features:
+-- Named chunk rearrangement (as in WEB)
+-- Built-in macros
+-- User defined macros
+-- Binary and ASCII integer literals
+-- Include files (Haskell and literate Haskell)
+-- Remove commas at end of {a,b,c,} and [a,b,c,]
+
+---- To-do:
+-- Other file formats (C header, CSV, XML, etc)
+-- Layout mode
+-- Pool strings
+-- Any other feature that you might want; please ask