From 67b12f49b1cacf6641bf1880ecda45173f39ec1d Mon Sep 17 00:00:00 2001 From: Gabriel Gonzalez Date: Sat, 17 Jan 2015 18:52:18 -0800 Subject: [PATCH] Initial commit --- LICENSE | 24 ++ Setup.hs | 2 + src/Turtle.hs | 21 ++ src/Turtle/Parser.hs | 541 +++++++++++++++++++++++++++++++++++++++++++ src/Turtle/Shell.hs | 123 ++++++++++ src/Turtle/Util.hs | 20 ++ test/Main.hs | 6 + turtle.cabal | 51 ++++ 8 files changed, 788 insertions(+) create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 src/Turtle.hs create mode 100644 src/Turtle/Parser.hs create mode 100644 src/Turtle/Shell.hs create mode 100644 src/Turtle/Util.hs create mode 100644 test/Main.hs create mode 100644 turtle.cabal diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..18ad71b --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2015 Gabriel Gonzalez +All rights reserved. + +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 Gabriel Gonzalez nor the names of other 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Turtle.hs b/src/Turtle.hs new file mode 100644 index 0000000..3d3b2e5 --- /dev/null +++ b/src/Turtle.hs @@ -0,0 +1,21 @@ +module Turtle ( + -- * Shell + Shell + , fold + , runShell + + -- * Utilities + , select + , cat + , grep + + -- * Classes + , Applicative(..) + , Alternative(..) + , MonadIO(..) + ) where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Turtle.Shell (Shell, fold, runShell) +import Turtle.Util (select, cat, grep) diff --git a/src/Turtle/Parser.hs b/src/Turtle/Parser.hs new file mode 100644 index 0000000..0ed48cc --- /dev/null +++ b/src/Turtle/Parser.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +{-| The simplest possible parser implementation + + Example usage: + +>>> :set -XOverloadedStrings +>>> parse (text "cat" <|> text "dog") "cat" +["cat"] +>>> parse (some (notChar ',') <* char ',') "cat,dog" +["cat"] +>>> parse (count 3 anyChar) "cat,dog" +["cat"] + + This parser has unlimited backtracking, and will return as many solutions as + possible: + +>>> parse (some anyChar) "123" +["123","12","1"] +>>> parse (some anyChar <* eof) "123" +["123"] + + Use @do@ notation to structure more complex parsers: + +>>> :{ +let bit = (char '0' *> pure False) <|> (char '1' *> pure True); + portableBitMap = do + { text "P1" + ; width <- spaces1 *> decimal + ; height <- spaces1 *> decimal + ; count width (count height (spaces1 *> bit)) + }; +in parse portableBitMap "P1\n2 2\n0 0\n1 0\n" +:} +[[[False,False],[True,False]]] + +-} + +module Turtle.Parser ( + -- * Parser + Parser + , parse + + -- * Primitive parsers + , anyChar + , eof + + -- * Character parsers + , satisfy + , char + , notChar + , text + , oneOf + , noneOf + , space + , spaces + , spaces1 + , tab + , newline + , crlf + , upper + , lower + , alphaNum + , letter + , digit + , hexDigit + , octDigit + + -- * Numbers + , decimal + , signed + + -- * Combinators + , star + , plus + , choice + , count + , between + , skip + , within + , fixed + , sepBy + , sepBy1 + + -- * Re-exports + , Text + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.State +import Data.Char +import Data.List (foldl') +import Data.Monoid (Monoid(..), (<>)) +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text + +newtype Parser a = Parser { runParser :: StateT Text [] a } + deriving (Functor, Applicative, Monad, Alternative, MonadPlus) + +instance Monoid a => Monoid (Parser a) where + mempty = pure mempty + mappend = liftA2 mappend + +instance Num a => Num (Parser a) where + fromInteger n = pure (fromInteger n) + + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + + abs = fmap abs + signum = fmap signum + negate = fmap negate + +instance Fractional a => Fractional (Parser a) where + fromRational n = pure (fromRational n) + + recip = fmap recip + + (/) = liftA2 (/) + +instance Floating a => Floating (Parser a) where + pi = pure pi + + exp = fmap exp + sqrt = fmap sqrt + log = fmap log + sin = fmap sin + tan = fmap tan + cos = fmap cos + asin = fmap sin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + tanh = fmap tanh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + + (**) = liftA2 (**) + logBase = liftA2 logBase + +instance (a ~ Text) => IsString (Parser a) where + fromString str = text (Text.pack str) + +-- | Supply a `Parser` with a `Text` input, returning all possible solutions +parse :: Parser a -> Text -> [a] +parse p = evalStateT (runParser p) + +{-| Match any character + +>>> parse anyChar "123" +"1" +>>> parse anyChar "" +"" + +-} +anyChar :: Parser Char +anyChar = Parser (do + Just (c, cs) <- fmap Text.uncons get + put cs + return c ) + +{-| Matches the end of input + +>>> parse eof "123" +[] +>>> parse eof "" +[()] + +-} +eof :: Parser () +eof = Parser (do + True <- fmap Text.null get + return () ) + +{-| Match any character that satisfies the given predicate + +>>> parse (satisfy (== '1')) "123" +"1" +>>> parse (satisfy (== '2')) "123" +"" + +-} +satisfy :: (Char -> Bool) -> Parser Char +satisfy predicate = do + c <- anyChar + guard (predicate c) + return c + +{-| Match a specific character + +>>> parse (char '1') "123" +"1" +>>> parse (char '2') "123" +"" + +-} +char :: Char -> Parser Char +char c = satisfy (== c) + +{-| Match any character except the given one + +>>> parse (notChar '2') "123" +"1" +>>> parse (notChar '1') "123" +"" + +-} +notChar :: Char -> Parser Char +notChar c = satisfy (/= c) + +{-| Match a specific string + +>>> parse (text "12") "123" +["12"] + +-} +text :: Text -> Parser Text +text prefix' = Parser (do + txt <- get + let (prefix, suffix) = Text.splitAt (Text.length prefix') txt + guard (prefix == prefix') + put suffix + return prefix ) + +{-| Match any one of the given characters + +>>> parse (oneOf "1a") "123" +"1" +>>> parse (oneOf "2a") "123" +"" + +-} +oneOf :: [Char] -> Parser Char +oneOf cs = satisfy (`elem` cs) + +{-| Match anything other than the given characters + +>>> parse (noneOf "2a") "123" +"1" +>>> parse (noneOf "1a") "123" +"" + +-} +noneOf :: [Char] -> Parser Char +noneOf cs = satisfy (`notElem` cs) + +{-| Match a whitespace character + +>>> parse space " a" +" " +>>> parse space "a " +"" + +-} +space :: Parser Char +space = satisfy isSpace + +{-| Match zero or more whitespace characters + +>>> parse spaces " " +[" "," ",""] +>>> parse spaces "a " +[""] + +-} +spaces :: Parser Text +spaces = star space + +{-| Match one or more whitespace characters + +>>> parse spaces1 " " +[" "," "] +>>> parse spaces1 "a " +[] + +-} +spaces1 :: Parser Text +spaces1 = plus space + +{-| Match the tab character (@\'\t\'@) + +>>> parse tab "\t" +"\t" +>>> parse tab " " +"" +-} +tab :: Parser Char +tab = char '\t' + +{-| Match the newline character (@\'\n\'@) + +>>> parse newline "\n" +"\n" +>>> parse newline " " +"" +-} +newline :: Parser Char +newline = char '\n' + +{-| Matches a carriage return (@\'\r\'@) followed by a newline (@\'\n\'@) + +>>> parse crlf "\r\n" +["\r\n"] +>>> parse crlf "\n\r" +[] +-} +crlf :: Parser Text +crlf = text "\r\n" + +{-| Match an uppercase letter + +>>> parse upper "ABC" +"A" +>>> parse upper "abc" +"" +-} +upper :: Parser Char +upper = satisfy isUpper + +{-| Match a lowercase letter + +>>> parse lower "abc" +"a" +>>> parse lower "ABC" +"" +-} +lower :: Parser Char +lower = satisfy isLower + +{-| Match a letter or digit + +>>> parse alphaNum "123" +"1" +>>> parse alphaNum "abc" +"a" +>>> parse alphaNum "ABC" +"A" +>>> parse alphaNum "..." +"" +-} +alphaNum :: Parser Char +alphaNum = satisfy isAlphaNum + +{-| Match a letter + +>>> parse letter "ABC" +"A" +>>> parse letter "abc" +"a" +>>> parse letter "123" +"" +-} +letter :: Parser Char +letter = satisfy isLetter + +{-| Match a digit + +>>> parse digit "123" +"1" +>>> parse digit "abc" +"" +-} +digit :: Parser Char +digit = satisfy isDigit + +{-| Match a hexadecimal digit + +>>> parse hexDigit "123" +"1" +>>> parse hexDigit "ABC" +"A" +>>> parse hexDigit "abc" +"a" +>>> parse hexDigit "ghi" +"" +-} +hexDigit :: Parser Char +hexDigit = satisfy isHexDigit + +{-| Match an octal digit + +>>> parse octDigit "123" +"1" +>>> parse octDigit "9" +"" +-} +octDigit :: Parser Char +octDigit = satisfy isOctDigit + +{-| Match an unsigned decimal number + +>>> parse (decimal <* eof) "123" +[123] +>>> parse (decimal <* eof) "-123" +[] +-} +decimal :: Num n => Parser n +decimal = do + ds <- some digit + return (foldl' step 0 ds) + where + step n d = n * 10 + fromIntegral (ord d - ord '0') + +{-| Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign + +>>> parse (signed decimal <* eof) "+123" +[123] +>>> parse (signed decimal <* eof) "-123" +[-123] +>>> parse (signed decimal <* eof) "123" +[123] +-} +signed :: Num a => Parser a -> Parser a +signed p = do + sign <- (char '+' *> pure id) <|> (char '-' *> pure negate) <|> (pure id) + fmap sign p + +{-| Parser 0 or more occurrecnes of the given character + +>>> parse (star anyChar) "123" +["123","12","1",""] +>>> parse (star anyChar <* eof) "123" +["123"] +>>> parse (star anyChar) "" +[""] +-} +star :: Parser Char -> Parser Text +star p = fmap Text.pack (many p) + +{-| Parse 1 or more occurrences of the given character + +>>> parse (some anyChar) "123" +["123","12","1"] +>>> parse (some anyChar <* eof) "123" +["123"] +>>> parse (some anyChar) "" +[] +-} +plus :: Parser Char -> Parser Text +plus p = fmap Text.pack (some p) + +{-| Apply the parsers in the list in order, until one of them succeeds + +>>> parse (choice [text "cat", text "dog", text "egg"]) "egg" +["egg"] +>>> parse (choice [text "cat", text "dog", text "egg"]) "cat" +["cat"] +>>> parse (choice [text "cat", text "dog", text "egg"]) "fan" +[] +-} +choice :: [Parser a] -> Parser a +choice = msum + +{-| Apply the given parser a fixed number of times, collecting the results + +>>> parse (count 2 anyChar) "123" +["12"] +>>> parse (count 4 anyChar) "123" +[] +-} +count :: Int -> Parser a -> Parser [a] +count = replicateM + +{-| @between open close p@ parses @p@ in between @open@ and @close@ + +>>> parse (between (char '(') (char ')') (star anyChar)) "(123)" +["123"] +>>> parse (between (char '(') (char ')') (star anyChar)) "(123))" +["123)","123"] +>>> parse (between (char '(') (char ')') (star anyChar)) "(123" +[] +-} +between :: Parser a -> Parser b -> Parser c -> Parser c +between open close p = open *> p <* close + +{-| Discard the parser's result + +>>> parse (skip anyChar) "123" +[()] +>>> parse (skip anyChar) "" +[] +-} +skip :: Parser a -> Parser () +skip = void + +{-| Restrict the parser to consume no more than the given number of characters + +>>> parse (within 2 decimal) "123" +[12,1] +>>> parse (within 2 decimal) "1a3" +[1] +-} +within :: Int -> Parser a -> Parser a +within n p = Parser (do + txt <- get + let (prefix, suffix) = Text.splitAt n txt + put prefix + a <- runParser p + modify (<> suffix) + return a ) + +{-| Require the parser to consume exactly the given number of characters + +>>> parse (fixed 2 decimal) "123" +[12] +>>> parse (fixed 2 decimal) "1a3" +[] +-} +fixed :: Int -> Parser a -> Parser a +fixed n p = within n (p <* eof) + +{-| @p `sepBy` sep@ parses zero or more occurrences of @p@ separated by @sep@ + +>>> parse (decimal `sepBy` char ',') "1,2,3" +[[1,2,3],[1,2],[1],[]] +>>> parse (decimal `sepBy` char ',' <* eof) "1,2,3" +[[1,2,3]] +>>> parse (decimal `sepBy` char ',') "" +[[]] +-} +sepBy :: Parser a -> Parser b -> Parser [a] +p `sepBy` sep = (p `sepBy1` sep) <|> pure [] + +{-| @p `sepBy1` sep@ parses one or more occurrences of @p@ separated by @sep@ + +>>> parse (decimal `sepBy1` char ',') "1,2,3" +[[1,2,3],[1,2],[1]] +>>> parse (decimal `sepBy1` char ',' <* eof) "1,2,3" +[[1,2,3]] +>>> parse (decimal `sepBy1` char ',') "" +[] +-} +sepBy1 :: Parser a -> Parser b -> Parser [a] +p `sepBy1` sep = (:) <$> p <*> many (sep *> p) diff --git a/src/Turtle/Shell.hs b/src/Turtle/Shell.hs new file mode 100644 index 0000000..4fa5919 --- /dev/null +++ b/src/Turtle/Shell.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE RankNTypes #-} + +{- All `Shell`s must satisfy this law: + +> foldM_ s step begin done = do +> x <- step +> x' <- foldM_ s step (return x) return +> done x' + +-} + +module Turtle.Shell ( + Shell(..) + , fold + , runShell + ) where + +import Control.Applicative (Applicative(..), Alternative(..), liftA2) +import Control.Monad (MonadPlus(..), ap) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Foldl (Fold) +import qualified Control.Foldl as Foldl +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) + +-- | A @(`Shell` a)@ is a stream of @a@'s +newtype Shell a = Shell + { foldM_ :: forall r x . (x -> a -> IO x) -> IO x -> (x -> IO r) -> IO r } + +fold :: Fold a b -> Shell a -> IO b +fold f s = Foldl.impurely (foldM_ s) (Foldl.generalize f) + +runShell :: Shell a -> IO () +runShell = fold (pure ()) + +instance Functor Shell where + fmap f s = Shell (\step begin done -> + let step' x a = step x (f a) + in foldM_ s step' begin done ) + +instance Applicative Shell where + pure = return + (<*>) = ap + +instance Monad Shell where + return a = Shell (\step begin done -> do + x <- begin + x' <- step x a + done x' ) + + m >>= f = Shell (\step0 begin0 done0 -> do + let step1 x a = foldM_ (f a) step0 (return x) return + foldM_ m step1 begin0 done0 ) + + fail _ = mzero + +instance Alternative Shell where + empty = Shell (\_ begin done -> do + x <- begin + done x ) + + s1 <|> s2 = Shell (\step begin done -> do + x <- foldM_ s1 step begin return + foldM_ s2 step (return x) done ) + +instance MonadPlus Shell where + mzero = empty + + mplus = (<|>) + +instance MonadIO Shell where + liftIO io = Shell (\step begin done -> do + x <- begin + a <- io + x' <- step x a + done x' ) + +instance Monoid a => Monoid (Shell a) where + mempty = pure mempty + mappend = liftA2 mappend + +instance Num a => Num (Shell a) where + fromInteger n = pure (fromInteger n) + + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + + abs = fmap abs + signum = fmap signum + negate = fmap negate + +instance Fractional a => Fractional (Shell a) where + fromRational n = pure (fromRational n) + + recip = fmap recip + + (/) = liftA2 (/) + +instance Floating a => Floating (Shell a) where + pi = pure pi + + exp = fmap exp + sqrt = fmap sqrt + log = fmap log + sin = fmap sin + tan = fmap tan + cos = fmap cos + asin = fmap sin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + tanh = fmap tanh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + + (**) = liftA2 (**) + logBase = liftA2 logBase + +instance IsString a => IsString (Shell a) where + fromString str = pure (fromString str) diff --git a/src/Turtle/Util.hs b/src/Turtle/Util.hs new file mode 100644 index 0000000..f4b42b1 --- /dev/null +++ b/src/Turtle/Util.hs @@ -0,0 +1,20 @@ +module Turtle.Util where + +import Control.Applicative (Alternative(..)) + +import Control.Monad (guard) +import Turtle.Parser +import Turtle.Shell + +select :: [a] -> Shell a +select [] = empty +select (a:as) = return a <|> select as + +cat :: [Shell a] -> Shell a +cat = foldr (<|>) empty + +grep :: Parser a -> Shell Text -> Shell Text +grep p s = do + str <- s + guard (not (null (parse p str))) + return str diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..c1f4b0a --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest ["src/Turtle/Parser.hs"] diff --git a/turtle.cabal b/turtle.cabal new file mode 100644 index 0000000..99f161c --- /dev/null +++ b/turtle.cabal @@ -0,0 +1,51 @@ +Name: turtle +Version: 1.0.0 +Cabal-Version: >=1.10 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Copyright: 2015 Gabriel Gonzalez +Author: Gabriel Gonzalez +Maintainer: Gabriel439@gmail.com +Bug-Reports: https://github.com/Gabriel439/Haskell-Turtle-Library/issues +Synopsis: Shell programming, Haskell-style +Description: This package provides utilities for shell programming. + . + Features include: + . + * Support for @text@ and @system-filepath@ + . + * Streaming + . + * Exception-safety (including asynchronous exceptions) + . + * Fully-backtracking parsing +Category: Control, Pipes +Source-Repository head + Type: git + Location: https://github.com/Gabriel439/Haskell-Pipes-Extras-Library + +Library + HS-Source-Dirs: src + Build-Depends: + base >= 4 && < 5 , + foldl < 1.1, + text < 1.3, + transformers >= 0.2.0.0 && < 0.5 + Exposed-Modules: + Turtle, + Turtle.Parser, + Turtle.Shell, + Turtle.Util + GHC-Options: -O2 -Wall + Default-Language: Haskell2010 + +test-suite tests + Type: exitcode-stdio-1.0 + HS-Source-Dirs: test + Main-Is: Main.hs + GHC-Options: -O2 -Wall + Default-Language: Haskell2010 + Build-Depends: + base >= 4 && < 5 , + doctest >= 0.9.12 && < 0.10