preprocessor-tools (empty) → 0.1
raw patch · 14 files changed
+985/−0 lines, 14 filesdep +basedep +haskell98dep +mtlsetup-changed
Dependencies added: base, haskell98, mtl, parsec
Files
- LICENSE +26/−0
- Language/Haskell/Preprocessor.hs +122/−0
- Language/Haskell/Preprocessor/Ast.hs +55/−0
- Language/Haskell/Preprocessor/Error.hs +33/−0
- Language/Haskell/Preprocessor/Lexer.hs +210/−0
- Language/Haskell/Preprocessor/Loc.hs +120/−0
- Language/Haskell/Preprocessor/Parser.hs +164/−0
- Language/Haskell/Preprocessor/Printer.hs +53/−0
- Language/Haskell/Preprocessor/SynSpec.hs +55/−0
- Language/Haskell/Preprocessor/Token.hs +47/−0
- Language/Haskell/Preprocessor/Util.hs +56/−0
- Setup.hs +4/−0
- TODO +1/−0
- preprocessor-tools.cabal +39/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++Neither the name of the Northeastern University; nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED+TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/Haskell/Preprocessor.hs view
@@ -0,0 +1,122 @@+module Language.Haskell.Preprocessor (+ module Language.Haskell.Preprocessor.Ast,+ module Language.Haskell.Preprocessor.Parser,+ module Language.Haskell.Preprocessor.Printer,+ module Language.Haskell.Preprocessor.SynSpec,+ module Language.Haskell.Preprocessor.Util,+ module Data.Monoid,+ Loc.Locatable(..), Loc.cloneLoc, Loc.scrub,+ Extension(..), base, transform,+ hLoad, fileLoad, stdinLoad,+ hDump, fileDump, stdoutDump, stringDump+) where++import IO+import System++import Data.Monoid (Monoid(..))+import qualified Control.Monad.Writer as W++import qualified Language.Haskell.Preprocessor.Loc as Loc+import qualified Language.Haskell.Preprocessor.Error as E+import Language.Haskell.Preprocessor.Ast+import Language.Haskell.Preprocessor.Parser+import Language.Haskell.Preprocessor.Printer+import Language.Haskell.Preprocessor.SynSpec+import Language.Haskell.Preprocessor.Util++data Extension = Extension {+ keywords :: [[Keyword]],+ transformer :: [Ast] -> [Ast],+ synspec :: SynSpec,+ usage :: Maybe (IO ()),+ syntaxerror :: Maybe (E.Error -> IO ())+ }++instance Monoid Extension where+ mempty = Extension {+ keywords = [],+ transformer = id,+ synspec = mempty,+ usage = Nothing,+ syntaxerror = Nothing+ }+ e1 `mappend` e2 = Extension {+ keywords = keywords e1 ++ keywords e2,+ transformer = transformer e1 . transformer e2,+ synspec = synspec e1 `mappend` synspec e2,+ usage = usage e1 <+ usage e2,+ syntaxerror = syntaxerror e1 <+ syntaxerror e2+ }+ where Just a <+ _ = Just a+ Nothing <+ b = b++base :: Extension+base = Extension {+ keywords = [],+ transformer = id,+ synspec = defaultSpec,+ usage = Just (do+ prog <- getProgName+ hPutStrLn stderr $+ "Usage: "++prog++" [ INFILE | SOURCE INFILE OUTFILE ]"),+ syntaxerror = Just (hPutStrLn stderr . show)+ }++transform :: Extension -> [String] -> IO ()+transform extension files = do+ easts <- case files of+ [] -> stdinLoad spec+ [file] -> fileLoad spec file file+ [source, file, _]+ -> fileLoad spec source file+ _ -> do case usage extension of+ Just m -> m+ Nothing -> return ()+ exitFailure+ asts <- case easts of+ Left e -> do case syntaxerror extension of+ Just m -> m e+ Nothing -> return ()+ exitFailure+ Right r -> return r+ let result = transformer extension asts+ case files of+ [_, _, file] -> fileDump spec file result+ _ -> stdoutDump spec result+ where+ spec = (synspec extension) {+ blocks = keywords extension ++ blocks (synspec extension)+ }++-- Loading++hLoad :: SynSpec -> String -> Handle -> IO (Either E.Error [Ast])+hLoad spec source handle = do+ input <- hGetContents handle+ return (parseBy spec source input)++fileLoad :: SynSpec -> String -> FilePath -> IO (Either E.Error [Ast])+fileLoad spec source filename = do+ input <- readFile filename+ return (parseBy spec source input)++stdinLoad :: SynSpec -> IO (Either E.Error [Ast])+stdinLoad spec = hLoad spec "-" stdin++-- Dumping++hDump :: SynSpec -> Handle -> [Ast] -> IO ()+hDump _ = dump . hPutStr++stringDump :: SynSpec -> [Ast] -> String+stringDump _ = W.execWriter . dump W.tell++fileDump :: SynSpec -> String -> [Ast] -> IO ()+fileDump spec filename ast =+ bracket (openFile filename WriteMode) hClose $ \handle ->+ hDump spec handle ast++stdoutDump :: SynSpec -> [Ast] -> IO ()+stdoutDump _ = dump putStr+
+ Language/Haskell/Preprocessor/Ast.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Language.Haskell.Preprocessor.Ast (+ Ast(..), flatten, flattenList, format, cons,+ module Language.Haskell.Preprocessor.Token+) where++import Data.Typeable (Typeable)+import Data.Generics (Data, mkT, everywhere)+import Char (isDigit)++import Language.Haskell.Preprocessor.Loc (Locatable(..), bogus)+import Language.Haskell.Preprocessor.Token++data Ast =+ Single { item :: Token }+ | Block { item :: Token,+ lbrace :: Maybe Token,+ body :: [Ast],+ rbrace :: Maybe Token,+ next :: Ast }+ | Empty+ deriving (Eq, Show, Typeable, Data)++flatten :: Ast -> [Token] -> [Token]+flatten (Single item) = (com item ++) . (item { com = [] }:)+flatten Empty = id+flatten (Block item lbrace body rbrace next)+ = (item :) .+ maybe id (:) lbrace .+ flattenList body .+ maybe id (:) rbrace .+ flatten next++flattenList :: [Ast] -> [Token] -> [Token]+flattenList lst = foldr (.) id (map flatten lst)++format :: Data a => a -> [Ast] -> a+format a subs = everywhere (mkT replace) a where+ replace (Single Token { tag = CharLit,+ val = '\'':'#':rest@(_:_) })+ | all isDigit num && index < length subs+ = subs !! index where+ num = init rest+ index = read num - 1+ replace t = t++cons :: Token -> Ast -> Ast+cons a b = Block a Nothing [b] Nothing Empty++instance Locatable Ast where+ getLoc Empty = bogus+ getLoc ast = loc (item ast)++ setLoc Empty _ = Empty+ setLoc ast l = ast { item = setLoc (item ast) l }
+ Language/Haskell/Preprocessor/Error.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Language.Haskell.Preprocessor.Error (+ Error(..), fromParseError, errorAt+) where++import Text.ParserCombinators.Parsec.Error+import Data.Typeable (Typeable)+import Data.Generics (Data)++import Language.Haskell.Preprocessor.Loc++data Error = Error { loc :: Loc,+ msg :: String }+ deriving (Typeable, Data)++errorAt :: Locatable a => a -> String -> b+errorAt a m = error (show (Error (getLoc a) m))++fromParseError :: ParseError -> Error+fromParseError pe =+ Error { loc = fromSourcePos (errorPos pe),+ msg = indent 4 $+ showErrorMessages+ "or" "Unknown" "Expecting"+ "Unexpected" "end-of-input"+ (errorMessages pe) }+ where indent n = unlines . map (replicate n ' ' ++) . lines++instance Show Error where+ showsPrec _ (Error loc msg)+ | isBogus loc = ("Error: "++) . (msg++)+ | otherwise = ("At "++) . shows loc . (": "++) . (msg ++)+
+ Language/Haskell/Preprocessor/Lexer.hs view
@@ -0,0 +1,210 @@+module Language.Haskell.Preprocessor.Lexer (+ scan, dscan, module T+) where++import Char++import Language.Haskell.Preprocessor.Token as T+import Language.Haskell.Preprocessor.Loc+import qualified Language.Haskell.Preprocessor.SynSpec as SS++scan :: SS.SynSpec -> String -> String -> [Token]+scan spec file = pass3 spec . pass2 spec . pass1 spec file++dscan :: String -> String -> [Token]+dscan = scan SS.defaultSpec++lexerr :: Loc -> String -> [Token]+lexerr loc msg = [newToken { tag = Error, T.loc = loc, val = msg }]++pass1 :: SS.SynSpec -> String -> String -> [Token]+pass1 spec file str = bol (initial file) str where+ unboxed = SS.unboxed spec+ pragmas = SS.pragmas spec++ varinit c = isLower c || c == '_'+ coninit c = isUpper c+ opinit c = c `elem` ":!$%&*+./<=>?@\\^|-~"++ varcont c = isAlphaNum c || c `elem` "'_"+ concont = varcont+ opcont c = opinit c || c == '#'++ rawnext tag loc inp val = loc' `seq` new : token loc' inp where+ new = newToken { T.tag = tag, T.loc = loc, T.val = val }+ loc' = advance loc val++ next tag loc inp val = rawnext tag loc inp val+ rnext tag loc inp val = next tag loc inp (reverse val)++ bol loc inp = case inp of+ '#':r -> let (acc, inp) = eatWhile (/= '\n') r "#"+ val = reverse acc in+ case fromDirective val of+ Nothing -> next CPragma loc inp val+ Just loc ->+ case inp of+ '\n':r -> bol loc r+ _ -> []+ c:inp | isSpace c -> bol (advance loc c) inp+ _ -> token loc inp++ token loc inp = case inp of+ '(':'#':r | unboxed -> next Other loc r "(#"+ '#':')':r | unboxed -> next Other loc r "#)"+ '{':'-':'#':r | pragmas -> next Other loc r "{-#"+ '#':'-':'}':r | pragmas -> next Other loc r "#-}"+ '{':'-':r -> lexComment loc r "-{" 1+ '(':r -> next Other loc r "("+ ')':r -> next Other loc r ")"+ '[':r -> next Other loc r "["+ ']':r -> next Other loc r "]"+ '{':r -> next Other loc r "{"+ '}':r -> next Other loc r "}"+ ';':r -> next Other loc r ";"+ ',':r -> next Other loc r ","+ '`':r -> next Other loc r "`"+ '\'':r -> lexChar loc r "'"+ '"':r -> lexString loc r "\""+ '-':'-':r -> lexHyphen loc r "--"+ '\n':r -> bol (advance loc '\n') r+ c:r | isSpace c -> token (advance loc c) r+ | coninit c -> lexCon loc r [c]+ | varinit c -> lexVar loc r [c]+ | opinit c -> lexOp loc r [c]+ | isDigit c -> lexNumber loc r [c]+ c:_ -> lexerr loc ("unexpected character " ++ show c)+ [] -> []++ lexChar loc inp acc = case inp of+ '\'':'#':r+ | unboxed -> rnext CharLit loc r ('#':'\'':acc)+ '\'':r -> rnext CharLit loc r ('\'':acc)+ '\\':'\'':r -> lexChar loc r ('\'':'\\':acc)+ '\\':'\\':r -> lexChar loc r ('\\':'\\':acc)+ c:r -> lexChar loc r (c:acc)+ [] -> lexerr loc "eof in character literal"++ lexString loc inp acc = case inp of+ '"':'#':r+ | unboxed -> rnext StringLit loc r ('#':'"':acc)+ '"':r -> rnext StringLit loc r ('"':acc)+ '\\':'"':r -> lexString loc r ('"':'\\':acc)+ '\\':'\\':r -> lexString loc r ('\\':'\\':acc)+ c:r -> lexString loc r (c:acc)+ [] -> lexerr loc "eof in string literal"++ lexNumber loc inp acc = case inp of+ c:r | isDigit c -> lexNumber loc r (c:acc)+ | c == '.' && not (null r) && isDigit (head r)+ -> lexFloat loc r (c:acc)+ | c `elem` "eE" -> lexMaybeExp IntLit loc inp acc+ '#':r | unboxed -> rnext IntLit loc r ('#':acc)+ _ -> rnext IntLit loc inp acc++ lexFloat loc inp acc = case eatWhile isDigit inp acc of+ (acc, r@(c:_)) | c `elem` "eE" -> lexMaybeExp FloatLit loc r acc+ (acc, '#':r) | unboxed -> rnext FloatLit loc r ('#':acc)+ (acc, r) -> rnext FloatLit loc r acc++ lexMaybeExp tag loc inp acc = case inp of+ e:'-':d:r | isDigit d -> lexExp loc r (d:'-':e:acc)+ e:'+':d:r | isDigit d -> lexExp loc r (d:'+':e:acc)+ e:d:r | isDigit d -> lexExp loc r (d:e:acc)+ _ -> rnext tag loc inp acc++ lexExp loc inp acc = case eatWhile isDigit inp acc of+ (acc, '#':r) -> rnext FloatLit loc r ('#':acc)+ (acc, r) -> rnext FloatLit loc r acc++ lexVar loc inp acc = case inp of+ c:r | varcont c -> lexVar loc r (c:acc)+ '#':r | unboxed -> rnext Variable loc r ('#':acc)+ _ -> rnext Variable loc inp acc++ lexOp loc inp acc = case inp of+ c:r | opcont c -> lexOp loc r (c:acc)+ _ -> rnext Operator loc inp acc++ lexCon loc inp acc = case inp of+ c:r | concont c -> lexVar loc r (c:acc)+ '#':r | unboxed -> rnext Constructor loc r ('#':acc)+ '.':r -> case r of+ c:s | coninit c -> lexCon loc s (c:'.':acc)+ | varinit c -> lexVar loc s (c:'.':acc)+ | opcont c -> lexOp loc s (c:'.':acc)+ _ -> rnext Constructor loc inp acc+ _ -> rnext Constructor loc inp acc++ lexHyphen loc inp acc = case inp of+ '-':r -> lexHyphen loc r ('-':acc)+ c:r | opcont c -> lexOp loc r (c:acc)+ _ -> case eatWhile (/= '\n') inp acc of+ (acc, r) -> rnext Comment loc r acc++ lexComment :: Loc -> String -> String -> Int -> [Token]+ lexComment loc inp acc 0 = rnext Comment loc inp acc+ lexComment loc inp acc n = case inp of+ '-':'}':r -> lexComment loc r ('}':'-':acc) (n - 1)+ '{':'-':r -> lexComment loc r ('-':'{':acc) (n + 1)+ c:r -> lexComment loc r (c:acc) n+ [] -> lexerr loc "eof in comment"++ eatWhile pred inp acc = case inp of+ c:r | pred c -> eatWhile pred r (c:acc)+ _ -> (acc, inp)++pass2 :: SS.SynSpec -> [Token] -> [Token]+pass2 _ = loop [] where+ loop acc toks = case toks of+ t@Token { tag = Comment } : rest+ -> loop (t:acc) rest+ t : rest+ -> t { com = reverse acc } : loop [] rest+ [] -> case acc of+ [] -> []+ t:_ -> [newToken { tag = Other,+ com = reverse acc,+ loc = loc t `advance` '\n'} ]++pass3 :: SS.SynSpec -> [Token] -> [Token]+pass3 spec = loop [] where+ levelnest = SS.levelnest spec+ indents = [ s | block <- SS.blocks spec, SS.I s <- block ]++ indent loc = Token VIndent [] loc ""+ semi loc = Token VSemi [] loc ""+ dedent loc = Token VDedent [] loc ""++ loop stk toks = case toks of+ [] -> []+ t:ts+ | val t `elem` indents ->+ case ts of+ [] -> t : indent _loc : dedent _loc : check _loc stk []+ where _loc = loc t+ t':_+ | val t' == "{" ->+ t : check (loc t') stk ts+ | otherwise ->+ t : indent (loc t') : begin (loc t') stk ts+ | otherwise -> t : check (loc t) stk ts++ begin _loc stk toks = case stk of+ [] -> loop [n] toks+ m:_ -> case n `compare` m of+ GT -> loop (n:stk) toks+ EQ | levelnest+ -> loop (n:stk) toks+ _ -> dedent _loc : check _loc stk toks+ where n = col _loc++ check _loc stk toks = case (stk, toks) of+ (ms, []) -> map (const (dedent _loc)) ms+ (m:ms, t:ts) ->+ case col (loc t) `compare` m of+ LT -> dedent (loc t) : check (loc t) ms (t:ts)+ EQ -> semi (loc t) : loop (m:ms) (t:ts)+ _ -> loop (m:ms) (t:ts)+ ([], ts) -> loop [] ts+
+ Language/Haskell/Preprocessor/Loc.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Language.Haskell.Preprocessor.Loc (+ Loc, file, line, col,+ initial, bogus, isBogus,+ Advance(..), scrub,+ Locatable(..), cloneLoc,+ toDirective, fromDirective,+ toSourcePos, fromSourcePos+) where++import Data.Typeable ()+import Data.Generics+import Text.ParserCombinators.Parsec.Pos++newtype Loc = Loc { toSourcePos :: SourcePos }+ deriving (Eq, Ord, Typeable)++fromSourcePos :: SourcePos -> Loc+fromSourcePos = Loc++new :: String -> Int -> Int -> Loc+new file line col = fromSourcePos (newPos file line col)++file :: Loc -> String+file = sourceName . toSourcePos++line :: Loc -> Int+line = sourceLine . toSourcePos++col :: Loc -> Int+col = sourceColumn . toSourcePos++initial :: String -> Loc+initial = fromSourcePos . initialPos++bogus :: Loc+bogus = new "<bogus>" (-1) (-1)++isBogus :: Loc -> Bool+isBogus loc = case (file loc, line loc, col loc) of+ ("<bogus>", -1, -1) -> True+ _ -> False++class Advance a where+ advance :: Loc -> a -> Loc++instance Advance Char where+ advance loc _+ | isBogus loc = loc+ advance loc c = fromSourcePos (updatePosChar (toSourcePos loc) c)++instance Advance a => Advance [a] where+ advance loc lst = foldl advance loc lst++class Locatable a where+ getLoc :: a -> Loc+ setLoc :: a -> Loc -> a++instance Locatable Loc where+ getLoc = id+ setLoc _ = id++instance Locatable a => Locatable (Maybe a) where+ getLoc Nothing = bogus+ getLoc (Just a) = getLoc a+ setLoc Nothing _ = Nothing+ setLoc (Just a) l = Just (setLoc a l)++instance Locatable a => Locatable [a] where+ getLoc [] = bogus+ getLoc (x:_) = getLoc x+ setLoc [] _ = []+ setLoc (x:xs) l = (setLoc x l:xs)++instance (Locatable a, Locatable b) => Locatable (Either a b) where+ getLoc (Left x) = getLoc x+ getLoc (Right x) = getLoc x+ setLoc (Left x) l = Left (setLoc x l)+ setLoc (Right x) l = Right (setLoc x l)++cloneLoc :: Locatable a => a -> a -> a+cloneLoc a b = setLoc a (getLoc b)++scrub :: Data a => a -> a+scrub a = everywhere (mkT bogosify) a where+ bogosify :: Loc -> Loc+ bogosify = const bogus++toDirective :: Loc -> String+toDirective loc = "# " ++ show (line loc) ++ " " ++ show (file loc)++fromDirective :: String -> Maybe Loc+fromDirective = toMaybe . parse where+ toMaybe [] = Nothing+ toMaybe (x:_) = Just x+ parse str = do+ r <- case str of+ '#':' ':s -> [s]+ '#':'l':'i':'n':'e':' ':s -> [s]+ _ -> []+ (n, r') <- reads r+ (f, "") <- reads r'+ return (new f n 1)++instance Show Loc where+ showsPrec p loc = showsPrec p (toSourcePos loc)++tyLoc :: DataType+tyLoc = mkDataType "Language.Haskell.Preprocessor.Loc.Loc" [conLoc]+conLoc :: Constr+conLoc = mkConstr tyLoc "Loc" [] Prefix++instance Data Loc where+ gfoldl f z loc = z new `f` file loc `f` line loc `f` col loc+ gunfold k z c = case constrIndex c of+ 1 -> k (k (k (z new)))+ _ -> error "gunfold"+ toConstr _ = conLoc+ dataTypeOf _ = tyLoc+
+ Language/Haskell/Preprocessor/Parser.hs view
@@ -0,0 +1,164 @@+module Language.Haskell.Preprocessor.Parser (+ quasi, quasiBy, parse, parseBy, parseTokens, parseTokensBy+) where++import List (delete, union)++import qualified Language.Haskell.Preprocessor.SynSpec as SS+import qualified Language.Haskell.Preprocessor.Error as E+import qualified Language.Haskell.Preprocessor.Loc as Loc+import qualified Language.Haskell.Preprocessor.Lexer as Lexer+import Language.Haskell.Preprocessor.Ast++import qualified Text.ParserCombinators.Parsec as P++quasiBy :: SS.SynSpec -> String -> [Ast] -> [Ast]+quasiBy spec input subs =+ case parseBy spec "<quasi>" input of+ Left e -> error (show e)+ Right r -> format (Loc.scrub r) subs++quasi :: String -> [Ast] -> [Ast]+quasi = quasiBy SS.defaultSpec++parse :: String -> String -> Either E.Error [Ast]+parse = parseBy SS.defaultSpec++parseBy :: SS.SynSpec -> String -> String -> Either E.Error [Ast]+parseBy spec file input = parseTokensBy spec tokens where+ tokens = Lexer.scan spec file input++parseTokens :: [Token] -> Either E.Error [Ast]+parseTokens = parseTokensBy SS.defaultSpec++type Grammar = [Rule]+data Rule = Branch SS.Keyword Grammar+ | Epsilon+ deriving (Eq, Show)++leftFactor :: [[SS.Keyword]] -> Grammar+leftFactor = foldr add [] where+ add :: [SS.Keyword] -> Grammar -> Grammar+ add [] gram = delete Epsilon gram ++ [Epsilon]+ add (kw:r) gram = case findSplit (headIs kw) gram of+ Just (a, Branch kw' r', c)+ -> Branch (max kw kw') (add r r') : a ++ c+ _ -> Branch kw (add r []) : gram++ max (SS.I kw) _ = SS.I kw+ max _ (SS.I kw) = SS.I kw+ max x _ = x++ headIs kw (Branch kw' _) = SS.getKey kw == SS.getKey kw'+ headIs _ _ = False++ findSplit _ [] = Nothing+ findSplit pred (x:xs)+ | pred x = Just ([], x, xs)+ | otherwise = do (a, b, c) <- findSplit pred xs+ Just (x:a, b, c)++parseTokensBy :: SS.SynSpec -> [Token] -> Either E.Error [Ast]+parseTokensBy spec input = case P.parse start source input of+ Left pe -> Left (E.fromParseError pe)+ Right asts -> Right asts+ where++ gram = leftFactor (SS.blocks spec)++ start = do+ res <- until []+ P.eof+ return res++ source = case input of+ t:_ -> Loc.file (loc t)+ _ -> "<bogus>"++ until stop = P.many (any stop)++ any stop = parseRules gram (single stop) stop++ single stop = do+ item <- tokenP (\i -> val i `notElem` stop && tag i /= VDedent)+ return (Single item)++ parseRules r orelse stop =+ foldr (<|>) orelse (map (flip parseRule stop) r)++ parseRule Epsilon _ = return Empty+ parseRule (Branch (SS.I key) r) stop = do+ item <- tokenV key+ curlyBraces item r stop <|> virtualBraces item r stop+ parseRule (Branch (SS.P key) [Epsilon]) _ = do+ item <- tokenV key+ return (Single item)+ parseRule (Branch (SS.P key) r) stop = do+ item <- tokenV key+ body <- until (follow stop r)+ next <- parseRules r P.pzero stop <??> r+ return (Block item Nothing body Nothing next)++ curlyBraces item r stop = do+ lbrace <- tokenV "{" <?> "{"+ body <- until ["}"]+ rbrace <- tokenV "}" <?> "}"+ next <- parseRules r P.pzero stop <??> r+ return (Block item (Just lbrace) body (Just rbrace) next)++ virtualBraces item r stop = do+ lbrace <- tokenT VIndent+ body <- until (follow stop r)+ rbrace <- do+ vbrace <- tokenT VDedent+ return (Just vbrace)+ <|> do+ killDedent+ return Nothing+ next <- parseRules r P.pzero stop <??> r+ return (Block item (Just lbrace) body rbrace next)++ follow oldStop r+ | Epsilon `elem` r = oldStop `union` newStop+ | otherwise = newStop+ where newStop = [ SS.getKey kw | Branch kw _ <- r ]++ killDedent = do+ inp <- P.getInput+ P.setInput (clean 0 inp)+ where+ clean :: Int -> [Token] -> [Token]+ clean _ [] = []+ clean 0 ( Token { tag = VDedent }:r) = r+ clean n (t@Token { tag = VIndent }:r) = t : clean (n + 1) r+ clean n (t@Token { tag = VDedent }:r) = t : clean (n - 1) r+ clean n (t :r) = t : clean n r++ tokenRaw :: (Token -> Maybe a) -> P.GenParser Token () a+ tokenRaw = P.token val (Loc.toSourcePos . loc)++ token :: (Token -> Maybe a) -> P.GenParser Token () a+ token pred = tokenRaw pred <|> errorToken++ tokenP :: (Token -> Bool) -> P.GenParser Token () Token+ tokenP pred = token (\i -> if pred i then Just i else Nothing)++ tokenV :: String -> P.GenParser Token () Token+ tokenV v = tokenP ((== v) . val)++ tokenT :: Tag -> P.GenParser Token () Token+ tokenT t = tokenP ((== t) . tag)++ errorToken :: P.GenParser Token () a+ errorToken = do+ tok <- tokenRaw (\i -> if tag i == Error then Just i else Nothing)+ P.setPosition (Loc.toSourcePos (loc tok))+ fail (val tok)++ (<|>) = (P.<|>)+ (<?>) = (P.<?>)++ p <??> [] = p+ p <??> (Epsilon:_) = p+ p <??> (Branch kw _:r) = (p <?> SS.getKey kw) <??> r+
+ Language/Haskell/Preprocessor/Printer.hs view
@@ -0,0 +1,53 @@+module Language.Haskell.Preprocessor.Printer ( dump ) where++import Language.Haskell.Preprocessor.Ast+import Language.Haskell.Preprocessor.Token+import Language.Haskell.Preprocessor.Loc++import Control.Monad (foldM)++dump :: Monad m => (String -> m ()) -> [Ast] -> m ()+dump write forest = start where+ start = do+ let items = flattenList forest []+ here = case items of+ [] -> bogus+ x:_ -> initial (file (loc x))+ write (toDirective here)+ write "\n"+ foldM sayToken here items+ write "\n"++ sayToken here item+ | null (val item) = do+ return here+ | isBogus (loc item) = do+ foldM sayString here [" ", val item, " "]+ | otherwise = do+ here <- goto here (loc item)+ sayString here (val item)++ goto here there+ | line here < line there = do+ let directive = toDirective there+ newlines = line there - line here+ if length directive < newlines+ then do+ write "\n"; write directive; write "\n"+ else do+ write (replicate (line there - line here) '\n')+ write (replicate (col there - 1) ' ')+ return there+ | line here == line there && col here <= col there = do+ write (replicate (col there - col here) ' ')+ return there+ | otherwise = do+ write "\n"+ write (toDirective there)+ write "\n"+ write (replicate (col there - 1) ' ')+ return there++ sayString here str = do+ write str+ return (here `advance` str)
+ Language/Haskell/Preprocessor/SynSpec.hs view
@@ -0,0 +1,55 @@+module Language.Haskell.Preprocessor.SynSpec (+ SynSpec(..), Keyword(..),+ pair, defaultSpec+) where++import Data.Monoid (Monoid(..))++data SynSpec = SynSpec {+ unboxed :: Bool,+ pragmas :: Bool,+ levelnest :: Bool,+ blocks :: [[Keyword]]+ }+ deriving (Eq, Show)++instance Monoid SynSpec where+ mempty = SynSpec {+ unboxed = False,+ pragmas = False,+ levelnest = False,+ blocks = []+ }+ s1 `mappend` s2 = SynSpec {+ unboxed = unboxed s1 || unboxed s2,+ pragmas = pragmas s1 || pragmas s2,+ levelnest = levelnest s1 || levelnest s2,+ blocks = blocks s1 ++ blocks s2+ }++data Keyword = I { getKey :: String }+ | P { getKey :: String }+ deriving (Eq, Show)++pair :: String -> String -> [Keyword]+pair l r = [P l, P r]++defaultSpec :: SynSpec+defaultSpec = SynSpec {+ unboxed = True,+ pragmas = False,+ levelnest = False,+ blocks = [+ pair "(#" "#)",+ pair "{-#" "#-}",+ pair "(" ")",+ pair "[" "]",+ pair "{" "}",+ [P "if", P "then", P "else"],+ [P "case", I "of"],+ [I "let", P "in"],+ [I "let"],+ [I "where"],+ [I "do"]+ ]+ }
+ Language/Haskell/Preprocessor/Token.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Language.Haskell.Preprocessor.Token (+ Token(..), Tag(..), newToken+) where++import Language.Haskell.Preprocessor.Loc+import Data.Typeable ()+import Data.Generics++data Token = Token { tag :: Tag,+ com :: [Token],+ loc :: Loc,+ val :: String }+ deriving (Eq, Typeable, Data)++newToken :: Token+newToken = Token {+ tag = Other,+ com = [],+ loc = bogus,+ val = ""+ }++data Tag =+ CPragma+ | Variable+ | Constructor+ | Operator+ | Other+ | CharLit+ | StringLit+ | IntLit+ | FloatLit+ | VIndent+ | VDedent+ | VSemi+ | Comment+ | Error+ deriving (Eq, Show, Typeable, Data)++instance Show Token where+ showsPrec _ t = shows (tag t) . ('(':) . shows (val t) . (')':)++instance Locatable Token where+ getLoc = loc+ setLoc t l = t { loc = l }+
+ Language/Haskell/Preprocessor/Util.hs view
@@ -0,0 +1,56 @@+module Language.Haskell.Preprocessor.Util (+ parens, noParens,+ splitVal, splitTag, splitSemis, splitAllBy, splitBy,+ valIs, tagIs+) where++import Language.Haskell.Preprocessor.Ast++parens, noParens :: [Ast] -> Ast+parens asts = Block {+ item = newToken { tag = Other, val = "(" },+ lbrace = Nothing,+ body = asts,+ rbrace = Nothing,+ next = Single newToken { tag = Other, val = ")" }+ }+noParens asts = Block {+ item = newToken { tag = Other, val = "" },+ lbrace = Nothing,+ body = asts,+ rbrace = Nothing,+ next = Single newToken { tag = Other, val = "" }+ }++splitVal :: String -> [Ast] -> Maybe ([Ast], Ast, [Ast])+splitVal = splitBy . valIs++splitTag :: Tag -> [Ast] -> Maybe ([Ast], Ast, [Ast])+splitTag = splitBy . tagIs++splitSemis :: [Ast] -> [[Ast]]+splitSemis = filter (not . null) . splitAllBy isSemi where+ isSemi t = valIs ";" t || tagIs VSemi t++splitAllBy :: (Ast -> Bool) -> [Ast] -> [[Ast]]+splitAllBy _ [] = []+splitAllBy pred lst = case splitBy pred lst of+ Nothing -> [lst]+ Just (f, _, b) -> f : splitAllBy pred b++splitBy :: (Ast -> Bool) -> [Ast] -> Maybe ([Ast], Ast, [Ast])+splitBy pred lst = case lst of+ [] -> Nothing+ x:xs | pred x -> Just ([], x, xs)+ | otherwise -> do+ (front, middle, back) <- splitBy pred xs+ return (x:front, middle, back)++valIs :: String -> Ast -> Bool+valIs v Single { item = t } = val t == v+valIs _ _ = False++tagIs :: Tag -> Ast -> Bool+tagIs v Single { item = t } = tag t == v+tagIs _ _ = False+
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain
+ TODO view
@@ -0,0 +1,1 @@+Haddock.
+ preprocessor-tools.cabal view
@@ -0,0 +1,39 @@+Name: preprocessor-tools+Version: 0.1+Cabal-Version: >= 1.2+License: BSD3+License-File: LICENSE+Stability: experimental+Author: Jesse A. Tov <tov@ccs.neu.edu>+Maintainer: tov@ccs.neu.edu+Homepage: http://www.ccs.neu.edu/~tov/session-types+Category: Source-tools, Language, Code Generation+Synopsis: A framework for extending Haskell's syntax via quick-and-dirty preprocessors+Build-type: Simple+Description:+ This library provides a quick-and-dirty (but often effective)+ method for extending Haskell's syntax using a custom+ preprocessor. It parses Haskell into a bare-bones AST with just+ enough knowledge of the syntax to preserve nesting, and then+ allows transformations on the AST.+ .+ See the package ixdopp for an example of how to do this.++Extra-Source-Files:+ TODO++Library+ Build-Depends: haskell98, base, mtl, parsec+ Extensions: DeriveDataTypeable+ Exposed-modules:+ Language.Haskell.Preprocessor,+ Language.Haskell.Preprocessor.Ast,+ Language.Haskell.Preprocessor.Error,+ Language.Haskell.Preprocessor.Loc,+ Language.Haskell.Preprocessor.Parser,+ Language.Haskell.Preprocessor.Printer,+ Language.Haskell.Preprocessor.SynSpec,+ Language.Haskell.Preprocessor.Token,+ Language.Haskell.Preprocessor.Util+ Other-modules:+ Language.Haskell.Preprocessor.Lexer