packages feed

cake 0.1.1 → 0.3.0

raw patch · 4 files changed

+676/−75 lines, 4 filesdep −Encodedep ~containersdep ~directorydep ~filepath

Dependencies removed: Encode

Dependency ranges changed: containers, directory, filepath

Files

Cake/Core.hs view
@@ -9,14 +9,15 @@   Act,                cake,   need,           +  list,   -- * Mid-level interface   produce,   use,   -- * Low-level interface-  shielded,   debug,-  query,+  distill,   cut,+  shielded,   Question(..),   Answer(..),   -- * Re-exports@@ -43,18 +44,25 @@  import Data.DeriveTH import Data.Binary+import System.IO -data Question = Stamp FilePath +data Question = FileContents FilePath                | Listing FilePath String+              | Custom [String] --              | Option [String]-              deriving (Eq, Ord, Show)+              deriving (Eq, Ord) $( derive makeBinary ''Question )                                       -data Answer = Stamp' (Maybe MD5Digest) +data Answer = Stamp (Maybe MD5Digest)              | Text [String]             deriving (Eq, Show) $( derive makeBinary ''Answer )             -  ++instance Show Question where+    show (FileContents f) = "{"++f++"}"+    show (Listing f ext) = "("++f++"/*"++ext++")"+    show (Custom c) = show c+ type DB = M.Map Question Answer type Produced = S.Set FilePath       @@ -64,7 +72,7 @@ type Rule = P (Act ())  type State = (Produced,Status) type Written = Dual DB -- take the dual so the writer overwrites old entries in the DB.-data Context = Context {ctxRule :: Rule, ctxDB :: DB, ctxProducing :: [FilePath]}+data Context = Context {ctxHandle :: Handle, ctxRule :: Rule, ctxDB :: DB, ctxProducing :: [Question]} newtype Act a = Act (RWST Context Written State IO a)   deriving (Functor, Applicative, Monad, MonadIO, MonadState State, MonadWriter Written, MonadReader Context) -- Take the dual here so that new info overwrites old.@@ -86,7 +94,9 @@   databaseFile = ".cake"+logFile = ".cake.log" + -- | Run an action in the context of a set of rules. cake :: Rule -> Act () -> IO () cake rule action = do@@ -106,43 +116,72 @@   (ps,_) <- RWS.get   return $ f `S.member` ps +distill :: Question -> Act Answer -> Act Answer+distill q act = local modCx $ do+  debug $ "Starting to answer"+  db <- ctxDB <$> ask+  let a0 = M.lookup q db+  a1 <- shielded act+  tell (Dual $ M.singleton q a1)+  when (Just a1 /= a0) $ do+    clobber+    debug $ "Question has not the same answer"+  return a1+ where modCx (Context {..}) = Context {ctxProducing = q:ctxProducing,..}    ++ produce :: FilePath -> Act () -> Act ()-produce f a = local modCx $ do-  p <- produced f-  -- Do nothing if the file is already produced.-  when (not p) $ do debug $ "starting production"-                    shielded $ do e <- liftIO $ doesFileExist f-                                  when (not e) clobber -                                  a-                                  -- when (not e) $ fail $ "Action failed to create " ++ f-                                  -                    use f        -- If the new file has changed, then set dirty flag. -                    modify $ first $ S.insert f   -- remember that the file has been produced already- where modCx (Context {..}) = Context {ctxProducing = f:ctxProducing,..}+produce f a = do+  p <- produced f -- Do nothing if the file is already produced.+  when (not p) $ do+     distill (FileContents f) $ +       do e <- liftIO $ doesFileExist f+          when (not e) clobber +          a+          modify $ first $ S.insert f +          -- remember that the file has been produced already+          fileStamp f+     return () --- | Mark that a file is used. No dependency is created on this file+-- | List directory contents by extension+list directory extension = do +  Text x <- distill (Listing directory extension) $ do+   files <- filter (filt . takeExtension) <$> liftIO (getDirectoryContents directory)+   return $ Text (map (directory </>) files)+  return x+ where filt = if null extension then const True else (== '.':extension)+++-- | Mark that a file is used. Do not chase dependencies on this file -- though.-use f = query (Stamp f)+use f = do+  distill (FileContents f) (fileStamp f)   --- | Assume that the context is clean; that is, the construction of the--- argument actually does not depend on the previous questions asked.++-- | Run the argument in a clean context, and do not clobber the state+-- even if the argument does that.  To use when the construction of+-- the argument actually does not depend on the previous questions+-- asked, and the constructed thing is "atomic" for the environment.+ -- NOTE: This can be used only when the purpose of the argument (why -- we call it) is known -- for example we already have determined that -- another goal depends on what we're going to perform. The dirty flag -- must be set independently in the context if the produced object is -- not present.-shielded :: Act () -> Act ()+shielded :: Act a -> Act a shielded a = do    (ps,s) <- RWS.get   RWS.put (ps,Clean)-  a+  x <- a   (ps',_) <- RWS.get   RWS.put (ps',s)-+  return x  runAct :: Rule -> DB -> Act () -> IO DB runAct r db (Act act) = do -  (_a,Dual db) <- evalRWST act (Context r db []) (S.empty,Clean)+  h <- openFile logFile WriteMode+  (_a,Dual db) <- evalRWST act (Context h r db []) (S.empty,Clean)+  hClose h   return db      findRule :: FilePath -> Act (Maybe (Act ()))@@ -157,35 +196,32 @@       -- debug $ "Parser says: " ++ show e       return Nothing      -           +debug :: String -> Act ()            debug x = do +  h <- ctxHandle <$> ask   ps <- ctxProducing <$> ask-  liftIO $ putStrLn $ "cake: " ++ concat (map (++": ") $ reverse ps) ++ x -  +  (_,s) <- RWS.get+  let st = case s of+              Clean -> "O"+              Dirty -> "X"+  liftIO $ hPutStrLn h $ "cake: " ++ st ++ " "++ concat (map (++": ") $ reverse $ map show ps) ++ x ++{- runQuery :: Question -> IO Answer           runQuery (Listing directory extension) = do   files <- filter (filt . takeExtension) <$> getDirectoryContents directory   return $ Text (map (directory </>) files)  where filt = if null extension then const True else (== '.':extension)   -runQuery (Stamp f) = do+runQuery (Stamp f) = fileStamp f+-}++fileStamp f = liftIO $ do   e <- doesFileExist f-  Stamp' <$> if e +  Stamp <$> if e      then Just <$> md5 <$> B.readFile f     else return Nothing -query :: Question -> Act Answer-query q = do-  a <- liftIO $ runQuery q-  tell (Dual $ M.singleton q a)-  db <- ctxDB <$> ask-  let a0 = M.lookup q db-  when (a0 /= Just a) $ do-    debug $ "Question has not the same answer: " ++ show q-    clobber-  return $ a-  -   clobber = RWS.modify $ second $ const Dirty  cut x = do@@ -203,7 +239,7 @@     Nothing -> do        e <- liftIO $ doesFileExist f       when (not e) $ fail $ "No rule to create " ++ f+      debug $ "using existing file"       use f-      debug $ "File exists: " ++ f+      return ()     Just a -> a-  return ()
Cake/Rules.hs view
@@ -25,10 +25,6 @@  --------------------------------------------------------- -- Actions-list :: FilePath -> String -> Act [String]-list dir ext = do-  Text xs <- query (Listing dir ext)-  return xs  copy :: FilePath -> FilePath -> Act() copy from to = produce to $ needing [from] $ do@@ -100,52 +96,64 @@ pdf_tex = simple ".pdf" ".tex" $ \o i ->    system ["latexmk","-pdf",i] +getBibFiles input = distill (Custom ["bibfiles",input]) $ do+    +    ls <- map (drop 14) . filter ("\\bibliography{" `isPrefixOf`) . lines <$> Cake.Rules.readFile input+    let bibs = map (++".bib") $ case ls of+            [] -> []+            (l:_) -> splitOn "," $ reverse . dropWhile (== '}') . reverse $ l+    return $ Text bibs++chaseDeps input = do+    ls <- map (drop 7) . filter ("\\input{" `isPrefixOf`) . lines <$> Cake.Rules.readFile input+    let inputs = map (++".tex") $ case ls of+            [] -> []+            (l:_) -> splitOn "," $ reverse . dropWhile (== '}') . reverse $ l+    return $ input:inputs++ pdflatexBibtex c = do   let input = c ++ ".tex"       aux1 = c ++ ".aux1"       aux = c ++ ".aux"       pdf = c ++ ".pdf"   produce pdf $ do -    produce aux1 $ needing [input] $ do _pdflatex c-                                        liftIO $ copyFile aux aux1-      -    ls <- map (drop 14) . filter ("\\bibliography{" `isPrefixOf`) . lines <$> Cake.Rules.readFile input-    let bibs = map (++".bib") $ case ls of-            [] -> []-            (l:_) -> splitOn "," $ reverse . dropWhile (== '}') . reverse $ l-    +    inputs <- chaseDeps input+    produce aux1 $ needing inputs $ do _pdflatex c+                                       liftIO $ copyFile aux aux1     produce aux $ do       produce (c ++ ".bbl") $ do+        Text bibs <- getBibFiles input         -- Note that this does not depend on the actual tex file; only the list of bibs. (aux1)         mapM_ need bibs         use aux1-        cut $ _bibtex c+        when (not $ null bibs) $+          cut $ _bibtex c       cut $ _pdflatex c          cut $ _pdflatex c  pdf_tex_bibtex = extension ".pdf" ==> \(_,c) -> pdflatexBibtex c --pdf_tex_biblatex = anyExtension [".pdf",".aux"] ==> \(_,c) -> do  +pdflatexBiblatex c = do   let input = c ++ ".tex"       aux = c ++ ".aux"       pdf = c ++ ".pdf"-  produce pdf $ do +  produce pdf $ do     produce aux $ needing [input] $ _pdflatex c-      -    ls <- map (drop 14) . filter ("\\bibliography{" `isPrefixOf`) . lines <$> Cake.Rules.readFile input-    let bibs = map (++".bib") $ case ls of-            [] -> []-            (l:_) -> splitOn "," $ reverse . dropWhile (== '}') . reverse $ l          produce (c ++ ".bbl") $ do       -- Note that this does not depend on the actual tex file; only the list of bibs.+      Text bibs <- getBibFiles input       mapM_ need bibs       use aux-      cut $ _bibtex c+      when (not $ null bibs) $+        cut $ _bibtex c      cut $ _pdflatex c     ++pdf_tex_biblatex = anyExtension [".pdf",".aux"] ==> \(_,c) -> +  pdflatexBibtex c  allRules = tex_markdown_standalone <|> pdf_tex_biblatex
+ Parsek.hs view
@@ -0,0 +1,558 @@+-- |+--+-- Module      :  Parsek+-- Copyright   :  Koen Claessen 2003+-- License     :  GPL+--+-- Maintainer  :  otakar.smrz mff.cuni.cz+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides the /Parsek/ library developed by Koen Claessen in his+-- functional pearl article /Parallel Parsing Processes/, Journal of Functional+-- Programming, 14(6), 741&#150;757, Cambridge University Press, 2004:+--+-- <http://www.cs.chalmers.se/~koen/pubs/entry-jfp04-parser.html>+--+-- <http://www.cs.chalmers.se/Cs/Grundutb/Kurser/afp/>+--+-- <http://www.cs.chalmers.se/Cs/Grundutb/Kurser/afp/code/week3/Parsek.hs>+--+--+--   Copyright (C) 2003  Koen Claessen+--+--   This program is free software; you can redistribute it and\/or modify+--   it under the terms of the GNU General Public License as published by+--   the Free Software Foundation; either version 2 of the License, or+--   (at your option) any later version.+--+--   This program is distributed in the hope that it will be useful,+--   but WITHOUT ANY WARRANTY; without even the implied warranty of+--   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--   GNU General Public License for more details.+--+--   You should have received a copy of the GNU General Public License along+--   with this program; if not, write to the Free Software Foundation, Inc.,+--   51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.+--+--+-- "PureFP.Parsers.Stream"++------------------------------------------------------------------+-- Parsek, a Parser Combinator Library                          --+-- Copyright (c) 2003 Koen Claessen                             --+-- koen@cs.chalmers.se                                          --+--                                                              --+-- This file is part of Parsek.                                 --+--                                                              --+-- Parsek is free software; you can redistribute it and/or      --+-- modify it under the terms of the GNU General Public License  --+-- as published by the Free Software Foundation; either version --+{-# LANGUAGE RankNTypes #-}+-- 2 of the License, or (at your option) any later version.     --+--                                                              --+-- Parsek is distributed in the hope that it will be useful,    --+-- but WITHOUT ANY WARRANTY; without even the implied warranty  --+-- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See  --+-- the GNU General Public License for more details.             --+--                                                              --+-- You should have received a copy of the GNU General Public    --+-- License along with Parsek; if not, write to the Free         --+-- Software Foundation, Inc., 59 Temple Place, Suite 330,       --+-- Boston, MA 02111-1307 USA.                                   --+------------------------------------------------------------------++module Parsek+  -- basic parser type+  ( Parser         -- :: * -> * -> *; Functor, Monad, MonadPlus+  , Expect         -- :: *; = [String]+  , Unexpect       -- :: *; = [String]++  -- parsers+  , satisfy        -- :: Show s => (s -> Bool) -> Parser s s+  , look           -- :: Parser s [s]+  , succeeds       -- :: Parser s a -> Parser s (Maybe a)+  , string         -- :: (Eq s, Show s) => [s] -> Parser s [s]++  , char           -- :: Eq s => s -> Parser s s+  , noneOf         -- :: Eq s => [s] -> Parser s s+  , oneOf          -- :: Eq s => [s] -> Parser s s++  , spaces         -- :: Parser Char ()+  , space          -- :: Parser Char Char+  , newline        -- :: Parser Char Char+  , tab            -- :: Parser Char Char+  , upper          -- :: Parser Char Char+  , lower          -- :: Parser Char Char+  , alphaNum       -- :: Parser Char Char+  , letter         -- :: Parser Char Char+  , digit          -- :: Parser Char Char+  , hexDigit       -- :: Parser Char Char+  , octDigit       -- :: Parser Char Char+  , anyChar        -- :: Parser s s+  , anySymbol      -- :: Parser s s+  , munch, munch1  -- :: (s -> Bool) -> Parser s [s]++  -- parser combinators+  , label          -- :: String -> Parser s a -> Parser s a+  , (<?>)          -- :: Parser s a -> String -> Parser s a+  , pzero          -- :: Parser s a+  , (<|>)          -- :: Parser s a -> Parser s a -> Parser s a+  , (<<|>)         -- :: Parser s a -> Parser s a -> Parser s a+  , try            -- :: Parser s a -> Parser s a; = id+  , choice         -- :: [Parser s a] -> Parser s a+  , option         -- :: a -> Parser s a -> Parser s a+  , optional       -- :: Parser s a -> Parser s ()+  , between        -- :: Parser s open -> Parser s close -> Parser s a -> Parser s a+  , count          -- :: Int -> Parser s a -> Parser s [a]++  , chainl1        -- :: Parser s a -> Parser s (a -> a -> a) -> Parser s a+  , chainl         -- :: Parser s a -> Parser s (a -> a -> a) -> a -> Parser s a+  , chainr1        -- :: Parser s a -> Parser s (a -> a -> a) -> Parser s a+  , chainr         -- :: Parser s a -> Parser s (a -> a -> a) -> a -> Parser s a++  , skipMany1      -- :: Parser s a -> Parser s ()+  , skipMany       -- :: Parser s a -> Parser s ()+  , many1          -- :: Parser s a -> Parser s [a]+  , many           -- :: Parser s a -> Parser s [a]+  , sepBy1         -- :: Parser s a -> Parser s sep -> Parser s [a]+  , sepBy          -- :: Parser s a -> Parser s sep -> Parser s [a]++  -- parsing & parse methods+  , ParseMethod    -- :: * -> * -> * -> * -> *+  , ParseResult    -- :: * -> * -> *; = Either (e, Expect, Unexpect) r+  , parseFromFile  -- :: Parser Char a -> ParseMethod Char a e r -> FilePath -> IO (ParseResult e r)+  , parse          -- :: Parser s a -> ParseMethod s a e r -> [s] -> ParseResult e r++  , shortestResult             -- :: ParseMethod s a (Maybe s) a+  , longestResult              -- :: ParseMethod s a (Maybe s) a+  , longestResults             -- :: ParseMethod s a (Maybe s) [a]+  , allResults                 -- :: ParseMethod s a (Maybe s) [a]+  , allResultsStaged           -- :: ParseMethod s a (Maybe s) [[a]]+  , completeResults            -- :: ParseMethod s a (Maybe s) [a]++  , shortestResultWithLeftover -- :: ParseMethod s a (Maybe s) (a,[s])+  , longestResultWithLeftover  -- :: ParseMethod s a (Maybe s) (a,[s])+  , longestResultsWithLeftover -- :: ParseMethod s a (Maybe s) ([a],[s])+  , allResultsWithLeftover     -- :: ParseMethod s a (Maybe s) [(a,[s])]++  , completeResultsWithLine    -- :: ParseMethod Char a Int [a]+  )+ where++import Control.Monad+  ( MonadPlus(..)+  , guard+  )++import Data.List+  ( union+  , intersperse+  )++import Data.Char++infix  0 <?>+infixr 1 <|>, <<|>++-------------------------------------------------------------------------+-- type Parser++newtype Parser s a+  = Parser (forall res . (a -> Expect -> P s res) -> Expect -> P s res)++-- type P; parsing processes++data P s res+  = Symbol (s -> P s res)+  | Look ([s] -> P s res)+  | Fail Expect Unexpect+  | Result res (P s res)++-- type Expect, Unexpect++type Expect+  = [String]++type Unexpect+  = [String]++-------------------------------------------------------------------------+-- instances: Functor, Monad, MonadPlus++instance Functor (Parser s) where+  fmap p (Parser f) =+    Parser (\fut -> f (fut . p))++instance Monad (Parser s) where+  return a =+    Parser (\fut -> fut a)++  Parser f >>= k =+    Parser (\fut -> f (\a -> let Parser g = k a in g fut))++  fail s =+    Parser (\fut exp -> Fail exp [s])++instance MonadPlus (Parser s) where+  mzero =+    Parser (\fut exp -> Fail exp [])++  mplus (Parser f) (Parser g) =+    Parser (\fut exp -> f fut exp `plus` g fut exp)++plus :: P s res -> P s res -> P s res+Symbol fut1    `plus` Symbol fut2    = Symbol (\s -> fut1 s `plus` fut2 s)+Fail exp1 err1 `plus` Fail exp2 err2 = Fail (exp1 `union` exp2) (err1 `union` err2)+p              `plus` Result res q   = Result res (p `plus` q)+Result res p   `plus` q              = Result res (p `plus` q)+Look fut1      `plus` Look fut2      = Look (\s -> fut1 s `plus` fut2 s)+Look fut1      `plus` q              = Look (\s -> fut1 s `plus` q)+p              `plus` Look fut2      = Look (\s -> p `plus` fut2 s)+p@(Symbol _)   `plus` _              = p+_              `plus` q@(Symbol _)   = q++-------------------------------------------------------------------------+-- primitive parsers++anySymbol :: Parser s s+anySymbol =+  Parser (\fut exp -> Symbol (\c ->+    fut c []+  ))++satisfy :: Show s => (s -> Bool) -> Parser s s+satisfy pred =+  Parser (\fut exp -> Symbol (\c ->+    if pred c+      then fut c []+      else Fail exp [show [c]]+  ))++label :: Parser s a -> String -> Parser s a+label (Parser f) s =+  Parser (\fut exp ->+    if null exp+      then f (\a _ -> fut a []) [s]+      else f fut exp+  )++look :: Parser s [s]+look =+  Parser (\fut exp ->+    Look (\s -> fut s exp)+  )++succeeds :: Parser s a -> Parser s (Maybe a)+succeeds (Parser f) =+  Parser (\fut exp ->+    Look (\xs ->+      let sim (Symbol f)     q (x:xs) = sim (f x) (\k -> Symbol (\_ -> q k)) xs+          sim (Look f)       q xs     = sim (f xs) q xs+          sim p@(Result _ _) q xs     = q (cont p)+          sim _              _ _      = fut Nothing []++          cont (Symbol f)       = Symbol (\x -> cont (f x))+          cont (Look f)         = Look (\s -> cont (f s))+          cont (Result a p)     = fut (Just a) [] `plus` cont p+          cont (Fail exp unexp) = Fail exp unexp++       in sim (f (\a _ -> Result a (Fail [] [])) exp) id xs+    )+  )++-- specialized++string :: (Eq s, Show s) => [s] -> Parser s [s]+string s =+  Parser (\fut exp ->+    let inputs []     = fut s []+        inputs (x:xs) =+          Symbol (\c ->+            if c == x+              then inputs xs+              else Fail (if null exp then [show s] else exp) [show [c]]+          )++     in inputs s+  )++-------------------------------------------------------------------------+-- derived parsers++char c    = satisfy (==c)         <?> show [c]+noneOf cs = satisfy (\c -> not (c `elem` cs))+oneOf cs  = satisfy (\c -> c `elem` cs)++spaces    = skipMany space        <?> "white space"+space     = satisfy (isSpace)     <?> "space"+newline   = char '\n'             <?> "new-line"+tab       = char '\t'             <?> "tab"+upper     = satisfy (isUpper)     <?> "uppercase letter"+lower     = satisfy (isLower)     <?> "lowercase letter"+alphaNum  = satisfy (isAlphaNum)  <?> "letter or digit"+letter    = satisfy (isAlpha)     <?> "letter"+digit     = satisfy (isDigit)     <?> "digit"+hexDigit  = satisfy (isHexDigit)  <?> "hexadecimal digit"+octDigit  = satisfy (isOctDigit)  <?> "octal digit"+anyChar   = anySymbol++munch :: (s -> Bool) -> Parser s [s]+munch p =+  do cs <- look+     scan cs+ where+  scan (c:cs) | p c = do anySymbol; as <- scan cs; return (c:as)+  scan _            = do return []++munch1 :: Show s => (s -> Bool) -> Parser s [s]+munch1 p =+  do c  <- satisfy p+     cs <- munch p+     return (c:cs)++-----------------------------------------------------------+-- parser combinators++(<?>) :: Parser s a -> String -> Parser s a+p <?> s = label p s++pzero :: Parser s a+pzero = mzero++(<|>) :: Parser s a -> Parser s a -> Parser s a+p <|> q = p `mplus` q++(<<|>) :: Parser s a -> Parser s a -> Parser s a+p <<|> q =+  do ma <- succeeds p+     case ma of+       Nothing -> q+       Just a  -> return a++try :: Parser s a -> Parser s a+try p = p -- backwards compatibility with Parsec++choice :: [Parser s a] -> Parser s a+choice ps = foldr (<|>) mzero ps++option :: a -> Parser s a -> Parser s a+option x p = p <|> return x++optional :: Parser s a -> Parser s ()+optional p = (do p; return ()) <|> return ()++between :: Parser s open -> Parser s close -> Parser s a -> Parser s a+between open close p = do open; x <- p; close; return x++-- repetition++skipMany1,skipMany :: Parser s a -> Parser s ()+skipMany1 p = do p; skipMany p+skipMany  p = let scan = (do p; scan) <|> return () in scan++many1,many :: Parser s a -> Parser s [a]+many1 p = do x <- p; xs <- many p; return (x:xs)+many  p = let scan f = (do x <- p; scan (f.(x:))) <|> return (f []) in scan id++sepBy1,sepBy :: Parser s a -> Parser s sep -> Parser s [a]+sepBy  p sep = sepBy1 p sep <|> return []+sepBy1 p sep = do x <- p; xs <- many (do sep; p); return (x:xs)++count :: Int -> Parser s a -> Parser s [a]+count n p = sequence (replicate n p)++chainr,chainl :: Parser s a -> Parser s (a -> a -> a) -> a -> Parser s a+chainr p op x = chainr1 p op <|> return x+chainl p op x = chainl1 p op <|> return x++chainr1,chainl1 :: Parser s a -> Parser s (a -> a -> a) -> Parser s a+chainr1 p op = scan+ where+  scan   = do x <- p; rest x+  rest x = (do f <- op; y <- scan; return (f x y)) <|> return x++chainl1 p op = scan+ where+  scan   = do x <- p; rest x+  rest x = (do f <- op; y <- p; rest (f x y)) <|> return x++-------------------------------------------------------------------------+-- type ParseMethod, ParseResult++type ParseMethod s a e r+  = P s a -> [s] -> ParseResult e r++type ParseResult e r+  = Either (e, Expect, Unexpect) r++-- parse functions++parseFromFile :: Parser Char a -> ParseMethod Char a e r -> FilePath -> IO (ParseResult e r)+parseFromFile p method file =+  do s <- readFile file+     return (parse p method s)++parse :: Parser s a -> ParseMethod s a e r -> [s] -> ParseResult e r+parse (Parser f) method xs =+  case method (f (\a exp -> Result a (Fail exp [])) []) xs of+    Left (err, exp, unexp) -> Left (err, [ s | s@(_:_) <- exp ], unexp)+    Right x                -> Right x++-- parse methods++shortestResult :: ParseMethod s a (Maybe s) a+shortestResult p xs = scan p xs+ where+  scan (Symbol sym)   (x:xs) = scan (sym x) xs+  scan (Symbol _)     []     = scan (Fail [] []) []+  scan (Result res _) _      = Right res+  scan (Fail exp err) (x:xs) = failSym x exp err+  scan (Fail exp err) []     = failEof exp err+  scan (Look f)       xs     = scan (f xs) xs++longestResult :: ParseMethod s a (Maybe s) a+longestResult p xs = scan p Nothing xs+ where+  scan (Symbol sym)   mres       (x:xs) = scan (sym x) mres xs+  scan (Symbol _)     mres       []     = scan (Fail [] []) mres []+  scan (Result res p) _          xs     = scan p (Just res) xs+  scan (Fail exp err) Nothing    (x:xs) = failSym x exp err+  scan (Fail exp err) Nothing    []     = failEof exp err+  scan (Fail _ _)     (Just res) _      = Right res+  scan (Look f)       mres       xs     = scan (f xs) mres xs++longestResults :: ParseMethod s a (Maybe s) [a]+longestResults p xs = scan p [] [] xs+ where+  scan (Symbol sym)   []  old (x:xs) = scan (sym x) [] old xs+  scan (Symbol sym)   new old (x:xs) = scan (sym x) [] new xs+  scan (Symbol _)     new old []     = scan (Fail [] []) new old []+  scan (Result res p) new old xs     = scan p (res:new) [] xs+  scan (Fail exp err) []  []  (x:xs) = failSym x exp err+  scan (Fail exp err) []  []  []     = failEof exp err+  scan (Fail _ _)     []  old _      = Right old+  scan (Fail _ _)     new _   _      = Right new+  scan (Look f)       new old xs     = scan (f xs) new old xs++allResultsStaged :: ParseMethod s a (Maybe s) [[a]]+allResultsStaged p xs = Right (scan p [] xs)+ where+  scan (Symbol sym)   ys (x:xs) = ys : scan (sym x) [] xs+  scan (Symbol _)     ys []     = [ys]+  scan (Result res p) ys xs     = scan p (res:ys) xs+  scan (Fail _ _)     ys _      = [ys]+  scan (Look f)       ys xs     = scan (f xs) ys xs++allResults :: ParseMethod s a (Maybe s) [a]+allResults p xs = scan p xs+ where+  scan (Symbol sym)   (x:xs) = scan (sym x) xs+  scan (Symbol _)     []     = scan (Fail [] []) []+  scan (Result res p) xs     = Right (res : scan' p xs)+  scan (Fail exp err) (x:xs) = failSym x exp err+  scan (Fail exp err) []     = failEof exp err+  scan (Look f)       xs     = scan (f xs) xs++  scan' p xs =+    case scan p xs of+      Left  _    -> []+      Right ress -> ress++completeResults :: ParseMethod s a (Maybe s) [a]+completeResults p xs = scan p xs+ where+  scan (Symbol sym)   (x:xs) = scan (sym x) xs+  scan (Symbol _)     []     = scan (Fail [] []) []+  scan (Result res p) []     = Right (res : scan' p [])+  scan (Result _ p)   xs     = scan p xs+  scan (Fail exp err) (x:xs) = failSym x exp err+  scan (Fail exp err) []     = failEof exp err+  scan (Look f)       xs     = scan (f xs) xs++  scan' p xs =+    case scan p xs of+      Left  _    -> []+      Right ress -> ress++-- with left overs++shortestResultWithLeftover :: ParseMethod s a (Maybe s) (a,[s])+shortestResultWithLeftover p xs = scan p xs+ where+  scan (Symbol sym)   (x:xs) = scan (sym x) xs+  scan (Symbol _)     []     = scan (Fail [] []) []+  scan (Result res _) xs     = Right (res,xs)+  scan (Fail exp err) (x:xs) = failSym x exp err+  scan (Fail exp err) []     = failEof exp err+  scan (Look f)       xs     = scan (f xs) xs++longestResultWithLeftover :: ParseMethod s a (Maybe s) (a,[s])+longestResultWithLeftover p xs = scan p Nothing xs+ where+  scan (Symbol sym)   mres         (x:xs) = scan (sym x) mres xs+  scan (Symbol _)     mres         []     = scan (Fail [] []) mres []+  scan (Result res p) _            xs     = scan p (Just (res,xs)) xs+  scan (Fail exp err) Nothing      (x:xs) = failSym x exp err+  scan (Fail exp err) Nothing      []     = failEof exp err+  scan (Fail _ _)     (Just resxs) _      = Right resxs+  scan (Look f)       mres         xs     = scan (f xs) mres xs++longestResultsWithLeftover :: ParseMethod s a (Maybe s) ([a],Maybe [s])+longestResultsWithLeftover p xs = scan p empty empty xs+ where+  scan (Symbol sym)   ([],_) old    (x:xs) = scan (sym x) empty old xs+  scan (Symbol sym)   new    old    (x:xs) = scan (sym x) empty new xs+  scan (Symbol _)     new    old    []     = scan (Fail [] []) new old []+  scan (Result res p) (as,_) old    xs     = scan p (res:as,Just xs) empty xs+  scan (Fail exp err) ([],_) ([],_) (x:xs) = failSym x exp err+  scan (Fail exp err) ([],_) ([],_) []     = failEof exp err+  scan (Fail _ _)     ([],_)  old _        = Right old+  scan (Fail _ _)     new _   _            = Right new+  scan (Look f)       new    old    xs     = scan (f xs) new old xs++  empty = ([],Nothing)++allResultsWithLeftover :: ParseMethod s a (Maybe s) [(a,[s])]+allResultsWithLeftover p xs = scan p xs+ where+  scan (Symbol sym)   (x:xs) = scan (sym x) xs+  scan (Symbol _)     []     = scan (Fail [] []) []+  scan (Result res p) xs     = Right ((res,xs) : scan' p xs)+  scan (Fail exp err) (x:xs) = failSym x exp err+  scan (Fail exp err) []     = failEof exp err+  scan (Look f)       xs     = scan (f xs) xs++  scan' p xs =+    case scan p xs of+      Left  _    -> []+      Right ress -> ress++completeResultsWithLine :: ParseMethod Char a Int [a]+completeResultsWithLine p xs = scan p 1 xs+ where+  scan (Symbol sym)   n (x:xs) = let n' = x |> n in n' `seq` scan (sym x) n' xs+  scan (Symbol _)     n []     = scan (Fail [] ["end of file"]) n []+  scan (Result res p) n []     = Right (res : scan' p n [])+  scan (Result _ p)   n xs     = scan p n xs+  scan (Fail exp err) n xs     = Left (n, exp, err)+  scan (Look f)       n xs     = scan (f xs) n xs++  scan' p n xs =+    case scan p n xs of+      Left  _    -> []+      Right ress -> ress++  '\n' |> n = n+1+  _    |> n = n++-- failing++failSym :: s -> Expect -> Unexpect -> ParseResult (Maybe s) r+failSym s exp err = Left (Just s, exp, err)++failEof :: Expect -> Unexpect -> ParseResult (Maybe s) r+failEof exp err = Left (Nothing, exp, err ++ ["end of file"])++-------------------------------------------------------------------------+-- the end.
cake.cabal view
@@ -1,5 +1,5 @@ name:           cake-version:        0.1.1+version:        0.3.0 category:       Development synopsis:       A build-system library and driver description:@@ -17,18 +17,17 @@   build-depends: base==4.*   build-depends: derive==2.5.*   build-depends: mtl==2.0.*-  build-depends: filepath==1.1.*  +  build-depends: filepath==1.2.*     build-depends: process==1.0.*   build-depends: binary==0.5.*-  build-depends: containers==0.3.*-  build-depends: directory==1.0.*-  build-depends: Encode==1.3.* -  -- Encode contains a copy of parsek+  build-depends: containers==0.4.*+  build-depends: directory==1.1.*   build-depends: bytestring==0.9.*   build-depends: pureMD5==2.1.*   build-depends: split==0.1.*    exposed-modules: Cake, Cake.Core, Cake.Rules, Cake.Process+  other-modules: Parsek  executable cake   build-depends: base==4.*@@ -36,7 +35,7 @@   build-depends: cmdargs==0.7.*   build-depends: regex-tdfa==1.1.*   build-depends: array==0.3.*-  build-depends: filepath==1.1.*  +  build-depends: filepath==1.2.*      main-is: Main.hs