Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Updated build system. Started test suite. Aggressive inlining. Lenses…

… for Styles
  • Loading branch information...
commit 438cc40652c537a9f0d6e8ee48e5eb9e0e58f8b9 1 parent eeb744b
@ekmett authored
View
1  .ghci
@@ -0,0 +1 @@
+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
View
13 .gitignore
@@ -1,2 +1,13 @@
-_darcs
dist
+docs
+wiki
+TAGS
+tags
+wip
+.DS_Store
+.*.swp
+.*.swo
+*.o
+*.hi
+*~
+*#
View
27 .travis.yml
@@ -1 +1,28 @@
language: haskell
+before_install:
+ # Uncomment whenever hackage is down.
+ # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update
+
+ # Try installing some of the build-deps with apt-get for speed.
+ - travis/cabal-apt-install --only-dependencies --force-reinstall $mode
+
+ - sudo apt-get -q -y install hlint || cabal install hlint
+
+install:
+ - cabal configure -flib-Werror $mode
+ - cabal build
+
+script:
+ - $script
+ - hlint src --cpp-define HLINT
+
+notifications:
+ irc:
+ channels:
+ - "irc.freenode.org#haskell-lens"
+ skip_join: true
+ template:
+ - "\x0313parsers\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
+
+env:
+ - mode="--enable-tests" script="cabal test"
View
31 .vim.custom
@@ -0,0 +1,31 @@
+" Add the following to your .vimrc to automatically load this on startup
+
+" if filereadable(".vim.custom")
+" so .vim.custom
+" endif
+
+function StripTrailingWhitespace()
+ let myline=line(".")
+ let mycolumn = col(".")
+ silent %s/ *$//
+ call cursor(myline, mycolumn)
+endfunction
+
+" enable syntax highlighting
+syntax on
+
+" search for the tags file anywhere between here and /
+set tags=TAGS;/
+
+" highlight tabs and trailing spaces
+set listchars=tab:‗‗,trail:‗
+set list
+
+" f2 runs hasktags
+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>
+
+" strip trailing whitespace before saving
+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()
+
+" rebuild hasktags after saving
+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
View
6 CHANGELOG.markdown
@@ -0,0 +1,6 @@
+0.4
+-----
+* Updated build system
+* Converted various style accessors to lenses and traversals
+* More aggressive inlining
+* Added CHANGELOG
View
45 Setup.lhs
@@ -1,7 +1,44 @@
#!/usr/bin/runhaskell
-> module Main (main) where
+\begin{code}
+{-# OPTIONS_GHC -Wall #-}
+module Main (main) where
-> import Distribution.Simple
+import Data.List ( nub )
+import Data.Version ( showVersion )
+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )
+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )
+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )
+import Distribution.Simple.BuildPaths ( autogenModulesDir )
+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )
+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
+import Distribution.Verbosity ( Verbosity )
+import System.FilePath ( (</>) )
-> main :: IO ()
-> main = defaultMain
+main :: IO ()
+main = defaultMainWithHooks simpleUserHooks
+ { buildHook = \pkg lbi hooks flags -> do
+ generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi
+ buildHook simpleUserHooks pkg lbi hooks flags
+ }
+
+generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
+generateBuildModule verbosity pkg lbi = do
+ let dir = autogenModulesDir lbi
+ createDirectoryIfMissingVerbose verbosity True dir
+ withLibLBI pkg lbi $ \_ libcfg -> do
+ withTestLBI pkg lbi $ \suite suitecfg -> do
+ rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines
+ [ "module Build_" ++ testName suite ++ " where"
+ , "deps :: [String]"
+ , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))
+ ]
+ where
+ formatdeps = map (formatone . snd)
+ formatone p = case packageName p of
+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)
+
+testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
+
+\end{code}
View
39 parsers.cabal
@@ -1,6 +1,6 @@
name: parsers
category: Text, Parsing
-version: 0.3.2
+version: 0.4
license: BSD3
cabal-version: >= 1.6
license-file: LICENSE
@@ -12,7 +12,7 @@ bug-reports: http://github.com/ekmett/parsers/issues
copyright: Copyright (C) 2010-2012 Edward A. Kmett
synopsis: Parsing combinators
description: Parsing combinators
-build-type: Simple
+build-type: Custom
extra-source-files: .travis.yml
@@ -20,6 +20,10 @@ source-repository head
type: git
location: git://github.com/ekmett/parsers.git
+flag lib-Werror
+ manual: True
+ default: False
+
library
exposed-modules:
Text.Parser.Char
@@ -30,18 +34,33 @@ library
Text.Parser.Token.Style
Text.Parser.Token.Highlight
- ghc-options: -Wall
+ hs-source-dirs: src
+
+ if flag(lib-Werror)
+ ghc-options: -Wall
+ else
+ ghc-options: -Wall
+
+ ghc-options: -O2
build-depends:
base >= 4 && < 5,
- charset >= 0.3 && < 0.4,
+ charset >= 0.3,
containers >= 0.4 && < 0.6,
transformers >= 0.2 && < 0.4,
unordered-containers >= 0.2 && < 0.3
- other-extensions: CPP, ExistentialQuantification
-
- -- Cabal doesn't understand DefaultSignatures
-
- -- if impl(ghc >= 7.4)
- -- other-extensions: DefaultSignatures, TypeFamilies
+-- Verify the results of the examples
+test-suite doctests
+ type: exitcode-stdio-1.0
+ main-is: doctests.hs
+ build-depends:
+ base,
+ containers,
+ directory >= 1.0,
+ doctest >= 0.9.1,
+ filepath
+ ghc-options: -Wall -threaded
+ if impl(ghc<7.6.1)
+ ghc-options: -Werror
+ hs-source-dirs: tests
View
46 Text/Parser/Char.hs → src/Text/Parser/Char.hs
@@ -103,6 +103,7 @@ noneOfSet s = oneOfSet (CharSet.complement s)
-- 'whiteSpace'.
spaces :: CharParsing m => m ()
spaces = skipMany space <?> "white space"
+{-# INLINE spaces #-}
-- | Parses a white space character (any character which satisfies 'isSpace')
-- Returns the parsed character.
@@ -179,15 +180,18 @@ class Parsing m => CharParsing m where
-- @semiColon = 'char' ';'@
char :: CharParsing m => Char -> m Char
char c = satisfy (c ==) <?> show [c]
+ {-# INLINE char #-}
-- | @notChar c@ parses any single character other than @c@. Returns the parsed
-- character.
notChar :: CharParsing m => Char -> m Char
notChar c = satisfy (c /=)
+ {-# INLINE notChar #-}
-- | This parser succeeds for any character. Returns the parsed character.
anyChar :: CharParsing m => m Char
anyChar = satisfy (const True)
+ {-# INLINE anyChar #-}
-- | @string s@ parses a sequence of characters given by @s@. Returns
-- the parsed string (i.e. @s@).
@@ -196,61 +200,101 @@ class Parsing m => CharParsing m where
-- > <|> string "mod"
string :: CharParsing m => String -> m String
string s = s <$ try (traverse_ char s) <?> show s
+ {-# INLINE string #-}
instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where
satisfy = lift . satisfy
+ {-# INLINE satisfy #-}
char = lift . char
+ {-# INLINE char #-}
notChar = lift . notChar
+ {-# INLINE notChar #-}
anyChar = lift anyChar
+ {-# INLINE anyChar #-}
string = lift . string
+ {-# INLINE string #-}
instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where
satisfy = lift . satisfy
+ {-# INLINE satisfy #-}
char = lift . char
+ {-# INLINE char #-}
notChar = lift . notChar
+ {-# INLINE notChar #-}
anyChar = lift anyChar
+ {-# INLINE anyChar #-}
string = lift . string
+ {-# INLINE string #-}
instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where
satisfy = lift . satisfy
+ {-# INLINE satisfy #-}
char = lift . char
+ {-# INLINE char #-}
notChar = lift . notChar
+ {-# INLINE notChar #-}
anyChar = lift anyChar
+ {-# INLINE anyChar #-}
string = lift . string
+ {-# INLINE string #-}
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where
satisfy = lift . satisfy
+ {-# INLINE satisfy #-}
char = lift . char
+ {-# INLINE char #-}
notChar = lift . notChar
+ {-# INLINE notChar #-}
anyChar = lift anyChar
+ {-# INLINE anyChar #-}
string = lift . string
+ {-# INLINE string #-}
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where
satisfy = lift . satisfy
+ {-# INLINE satisfy #-}
char = lift . char
+ {-# INLINE char #-}
notChar = lift . notChar
+ {-# INLINE notChar #-}
anyChar = lift anyChar
+ {-# INLINE anyChar #-}
string = lift . string
+ {-# INLINE string #-}
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where
satisfy = lift . satisfy
+ {-# INLINE satisfy #-}
char = lift . char
+ {-# INLINE char #-}
notChar = lift . notChar
+ {-# INLINE notChar #-}
anyChar = lift anyChar
+ {-# INLINE anyChar #-}
string = lift . string
+ {-# INLINE string #-}
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where
satisfy = lift . satisfy
+ {-# INLINE satisfy #-}
char = lift . char
+ {-# INLINE char #-}
notChar = lift . notChar
+ {-# INLINE notChar #-}
anyChar = lift anyChar
+ {-# INLINE anyChar #-}
string = lift . string
+ {-# INLINE string #-}
instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where
satisfy = lift . satisfy
+ {-# INLINE satisfy #-}
char = lift . char
+ {-# INLINE char #-}
notChar = lift . notChar
+ {-# INLINE notChar #-}
anyChar = lift anyChar
+ {-# INLINE anyChar #-}
string = lift . string
-
+ {-# INLINE string #-}
View
47 Text/Parser/Combinators.hs → src/Text/Parser/Combinators.hs
@@ -221,11 +221,13 @@ class Alternative m => Parsing m where
-- can often be implemented more cheaply.
skipMany :: m a -> m ()
skipMany p = () <$ many p
+ {-# INLINE skipMany #-}
-- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping
-- its result. (aka skipMany1 in parsec)
skipSome :: m a -> m ()
skipSome p = p *> skipMany p
+ {-# INLINE skipSome #-}
-- | @lookAhead p@ parses @p@ without consuming any input.
lookAhead :: m a -> m a
@@ -236,6 +238,7 @@ class Alternative m => Parsing m where
default unexpected :: (MonadTrans t, Monad n, Parsing n, m ~ t n) =>
String -> t n a
unexpected = lift . unexpected
+ {-# INLINE unexpected #-}
#endif
-- | This parser only succeeds at the end of the input. This is not a
@@ -246,6 +249,7 @@ class Alternative m => Parsing m where
#ifdef USE_DEFAULT_SIGNATURES
default eof :: (MonadTrans t, Monad n, Parsing n, m ~ t n) => t n ()
eof = lift eof
+ {-# INLINE eof #-}
#endif
-- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser
@@ -259,61 +263,104 @@ class Alternative m => Parsing m where
-- > keywordLet = try $ string "let" <* notFollowedBy alphaNum
notFollowedBy :: (Monad m, Show a) => m a -> m ()
notFollowedBy p = try ((try p >>= unexpected . show) <|> pure ())
+ {-# INLINE notFollowedBy #-}
instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where
try (Lazy.StateT m) = Lazy.StateT $ try . m
+ {-# INLINE try #-}
Lazy.StateT m <?> l = Lazy.StateT $ \s -> m s <?> l
+ {-# INLINE (<?>) #-}
lookAhead (Lazy.StateT m) = Lazy.StateT $ lookAhead . m
+ {-# INLINE lookAhead #-}
unexpected = lift . unexpected
+ {-# INLINE unexpected #-}
eof = lift eof
+ {-# INLINE eof #-}
instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where
try (Strict.StateT m) = Strict.StateT $ try . m
+ {-# INLINE try #-}
Strict.StateT m <?> l = Strict.StateT $ \s -> m s <?> l
+ {-# INLINE (<?>) #-}
lookAhead (Strict.StateT m) = Strict.StateT $ lookAhead . m
+ {-# INLINE lookAhead #-}
unexpected = lift . unexpected
+ {-# INLINE unexpected #-}
eof = lift eof
+ {-# INLINE eof #-}
instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where
try (ReaderT m) = ReaderT $ try . m
+ {-# INLINE try #-}
ReaderT m <?> l = ReaderT $ \e -> m e <?> l
+ {-# INLINE (<?>) #-}
skipMany (ReaderT m) = ReaderT $ skipMany . m
+ {-# INLINE skipMany #-}
lookAhead (ReaderT m) = ReaderT $ lookAhead . m
+ {-# INLINE lookAhead #-}
unexpected = lift . unexpected
+ {-# INLINE unexpected #-}
eof = lift eof
+ {-# INLINE eof #-}
instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) where
try (Strict.WriterT m) = Strict.WriterT $ try m
+ {-# INLINE try #-}
Strict.WriterT m <?> l = Strict.WriterT (m <?> l)
+ {-# INLINE (<?>) #-}
lookAhead (Strict.WriterT m) = Strict.WriterT $ lookAhead m
+ {-# INLINE lookAhead #-}
unexpected = lift . unexpected
+ {-# INLINE unexpected #-}
eof = lift eof
+ {-# INLINE eof #-}
instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where
try (Lazy.WriterT m) = Lazy.WriterT $ try m
+ {-# INLINE try #-}
Lazy.WriterT m <?> l = Lazy.WriterT (m <?> l)
+ {-# INLINE (<?>) #-}
lookAhead (Lazy.WriterT m) = Lazy.WriterT $ lookAhead m
+ {-# INLINE lookAhead #-}
unexpected = lift . unexpected
+ {-# INLINE unexpected #-}
eof = lift eof
+ {-# INLINE eof #-}
instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where
try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s)
+ {-# INLINE try #-}
Lazy.RWST m <?> l = Lazy.RWST $ \r s -> m r s <?> l
+ {-# INLINE (<?>) #-}
lookAhead (Lazy.RWST m) = Lazy.RWST $ \r s -> lookAhead (m r s)
+ {-# INLINE lookAhead #-}
unexpected = lift . unexpected
+ {-# INLINE unexpected #-}
eof = lift eof
+ {-# INLINE eof #-}
instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where
try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s)
+ {-# INLINE try #-}
Strict.RWST m <?> l = Strict.RWST $ \r s -> m r s <?> l
+ {-# INLINE (<?>) #-}
lookAhead (Strict.RWST m) = Strict.RWST $ \r s -> lookAhead (m r s)
+ {-# INLINE lookAhead #-}
unexpected = lift . unexpected
+ {-# INLINE unexpected #-}
eof = lift eof
+ {-# INLINE eof #-}
instance (Parsing m, Monad m) => Parsing (IdentityT m) where
try = IdentityT . try . runIdentityT
+ {-# INLINE try #-}
IdentityT m <?> l = IdentityT (m <?> l)
+ {-# INLINE (<?>) #-}
skipMany = IdentityT . skipMany . runIdentityT
+ {-# INLINE skipMany #-}
lookAhead = IdentityT . lookAhead . runIdentityT
+ {-# INLINE lookAhead #-}
unexpected = lift . unexpected
+ {-# INLINE unexpected #-}
eof = lift eof
+ {-# INLINE eof #-}
View
0  Text/Parser/Expression.hs → src/Text/Parser/Expression.hs
File renamed without changes
View
5 Text/Parser/Permutation.hs → src/Text/Parser/Permutation.hs
@@ -43,6 +43,7 @@ infixl 2 <$$>, <$?>
(<||>) :: Functor m => Permutation m (a -> b) -> m a -> Permutation m b
(<||>) = add
+{-# INLINE (<||>) #-}
-- | The expression @f \<$$> p@ creates a fresh permutation parser
-- consisting of parser @p@. The the final result of the permutation
@@ -60,6 +61,7 @@ infixl 2 <$$>, <$?>
(<$$>) :: Functor m => (a -> b) -> m a -> Permutation m b
(<$$>) f p = newPermutation f <||> p
+{-# INLINE (<$$>) #-}
-- | The expression @perm \<||> (x,p)@ adds parser @p@ to the
-- permutation parser @perm@. The parser @p@ is optional - if it can
@@ -68,6 +70,7 @@ infixl 2 <$$>, <$?>
(<|?>) :: Functor m => Permutation m (a -> b) -> (a, m a) -> Permutation m b
(<|?>) perm (x,p) = addOpt perm x p
+{-# INLINE (<|?>) #-}
-- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser
-- consisting of parser @p@. The the final result of the permutation
@@ -77,6 +80,7 @@ infixl 2 <$$>, <$?>
(<$?>) :: Functor m => (a -> b) -> (a, m a) -> Permutation m b
(<$?>) f (x,p) = newPermutation f <|?> (x,p)
+{-# INLINE (<$?>) #-}
----------------------------------------------------------------
-- The permutation tree
@@ -123,6 +127,7 @@ permute (Permutation def xs)
-- build permutation trees
newPermutation :: (a -> b) -> Permutation m (a -> b)
newPermutation f = Permutation (Just f) []
+{-# INLINE newPermutation #-}
add :: Functor m => Permutation m (a -> b) -> m a -> Permutation m b
add perm@(Permutation _mf fs) p
View
143 Text/Parser/Token.hs → src/Text/Parser/Token.hs
@@ -59,6 +59,15 @@ module Text.Parser.Token
-- IdentifierStyle m -> IdentifierStyle (t m)
, ident -- :: TokenParsing m => IdentifierStyle m -> m String
, reserve -- :: TokenParsing m => IdentifierStyle m -> String -> m ()
+ -- ** Lenses and Traversals
+ , styleName
+ , styleStart
+ , styleLetter
+ , styleChars
+ , styleReserved
+ , styleHighlight
+ , styleReservedHighlight
+ , styleHighlights
) where
import Control.Applicative
@@ -73,6 +82,7 @@ import Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Identity
import Data.Char
+import Data.Functor.Identity
import qualified Data.HashSet as HashSet
import Data.HashSet (HashSet)
import Data.List (foldl')
@@ -261,102 +271,195 @@ class CharParsing m => TokenParsing m where
-- comments as white space as well.
someSpace :: m ()
someSpace = skipSome (satisfy isSpace)
+ {-# INLINE someSpace #-}
-- | Called when we enter a nested pair of symbols.
-- Overloadable to enable disabling layout
nesting :: m a -> m a
nesting = id
+ {-# INLINE nesting #-}
-- | The token parser |semi| parses the character \';\' and skips
-- any trailing white space. Returns the character \';\'. Overloadable to
-- permit automatic semicolon insertion or Haskell-style layout.
semi :: m Char
semi = (satisfy (';'==) <?> ";") <* (someSpace <|> pure ())
+ {-# INLINE semi #-}
-- | Tag a region of parsed text with a bit of semantic information.
-- Most parsers won't use this, but it is indispensible for highlighters.
highlight :: Highlight -> m a -> m a
highlight _ a = a
+ {-# INLINE highlight #-}
instance (TokenParsing m, MonadPlus m) => TokenParsing (Lazy.StateT s m) where
nesting (Lazy.StateT m) = Lazy.StateT $ nesting . m
+ {-# INLINE nesting #-}
someSpace = lift someSpace
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight h (Lazy.StateT m) = Lazy.StateT $ highlight h . m
+ {-# INLINE highlight #-}
instance (TokenParsing m, MonadPlus m) => TokenParsing (Strict.StateT s m) where
nesting (Strict.StateT m) = Strict.StateT $ nesting . m
+ {-# INLINE nesting #-}
someSpace = lift someSpace
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight h (Strict.StateT m) = Strict.StateT $ highlight h . m
+ {-# INLINE highlight #-}
instance (TokenParsing m, MonadPlus m) => TokenParsing (ReaderT e m) where
nesting (ReaderT m) = ReaderT $ nesting . m
+ {-# INLINE nesting #-}
someSpace = lift someSpace
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight h (ReaderT m) = ReaderT $ highlight h . m
+ {-# INLINE highlight #-}
instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Strict.WriterT w m) where
nesting (Strict.WriterT m) = Strict.WriterT $ nesting m
+ {-# INLINE nesting #-}
someSpace = lift someSpace
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight h (Strict.WriterT m) = Strict.WriterT $ highlight h m
+ {-# INLINE highlight #-}
instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Lazy.WriterT w m) where
nesting (Lazy.WriterT m) = Lazy.WriterT $ nesting m
+ {-# INLINE nesting #-}
someSpace = lift someSpace
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight h (Lazy.WriterT m) = Lazy.WriterT $ highlight h m
+ {-# INLINE highlight #-}
instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Lazy.RWST r w s m) where
nesting (Lazy.RWST m) = Lazy.RWST $ \r s -> nesting (m r s)
+ {-# INLINE nesting #-}
someSpace = lift someSpace
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight h (Lazy.RWST m) = Lazy.RWST $ \r s -> highlight h (m r s)
+ {-# INLINE highlight #-}
instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Strict.RWST r w s m) where
nesting (Strict.RWST m) = Strict.RWST $ \r s -> nesting (m r s)
+ {-# INLINE nesting #-}
someSpace = lift someSpace
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight h (Strict.RWST m) = Strict.RWST $ \r s -> highlight h (m r s)
+ {-# INLINE highlight #-}
instance (TokenParsing m, MonadPlus m) => TokenParsing (IdentityT m) where
nesting = IdentityT . nesting . runIdentityT
+ {-# INLINE nesting #-}
someSpace = lift someSpace
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight h = IdentityT . highlight h . runIdentityT
+ {-# INLINE highlight #-}
-- | Used to describe an input style for constructors, values, operators, etc.
data IdentifierStyle m = IdentifierStyle
- { styleName :: String
- , styleStart :: m Char
- , styleLetter :: m Char
- , styleReserved :: HashSet String
- , styleHighlight :: Highlight
- , styleReservedHighlight :: Highlight
+ { _styleName :: String
+ , _styleStart :: m Char
+ , _styleLetter :: m Char
+ , _styleReserved :: HashSet String
+ , _styleHighlight :: Highlight
+ , _styleReservedHighlight :: Highlight
}
+-- | This lens can be used to update the name for this style of identifier.
+--
+-- @'styleName' :: Lens' ('IdentifierStyle' m) 'String'@
+styleName :: Functor f => (String -> f String) -> IdentifierStyle m -> f (IdentifierStyle m)
+styleName f is = (\n -> is { _styleName = n }) <$> f (_styleName is)
+{-# INLINE styleName #-}
+
+-- | This lens can be used to update the action used to recognize the first letter in an identifier.
+--
+-- @'styleStart' :: Lens' ('IdentifierStyle' m) (m 'Char')@
+styleStart :: Functor f => (m Char -> f (m Char)) -> IdentifierStyle m -> f (IdentifierStyle m)
+styleStart f is = (\n -> is { _styleStart = n }) <$> f (_styleStart is)
+{-# INLINE styleStart #-}
+
+-- | This lens can be used to update the action used to recognize subsequent letters in an identifier.
+--
+-- @'styleLetter' :: Lens' ('IdentifierStyle' m) (m 'Char')@
+styleLetter :: Functor f => (m Char -> f (m Char)) -> IdentifierStyle m -> f (IdentifierStyle m)
+styleLetter f is = (\n -> is { _styleLetter = n }) <$> f (_styleLetter is)
+{-# INLINE styleLetter #-}
+
+-- | This is a traversal of both actions in contained in an 'IdentifierStyle'.
+--
+-- @'styleChars' :: Traversal ('IdentifierStyle' m) ('IdentifierStyle' n) (m 'Char') (n 'Char')@
+styleChars :: Applicative f => (m Char -> f (n Char)) -> IdentifierStyle m -> f (IdentifierStyle n)
+styleChars f is = (\n m -> is { _styleStart = n, _styleLetter = m }) <$> f (_styleStart is) <*> f (_styleLetter is)
+{-# INLINE styleChars #-}
+
+-- | This is a lens that can be used to modify the reserved identifier set.
+--
+-- @'styleReserved' :: Lens' ('IdentifierStyle' m) ('HashSet' 'String')@
+styleReserved :: Functor f => (HashSet String -> f (HashSet String)) -> IdentifierStyle m -> f (IdentifierStyle m)
+styleReserved f is = (\n -> is { _styleReserved = n }) <$> f (_styleReserved is)
+{-# INLINE styleReserved #-}
+
+-- | This is a lens that can be used to modify the highlight used for this identifier set.
+--
+-- @'styleHighlight' :: Lens' ('IdentifierStyle' m) 'Highlight'@
+styleHighlight :: Functor f => (Highlight -> f Highlight) -> IdentifierStyle m -> f (IdentifierStyle m)
+styleHighlight f is = (\n -> is { _styleHighlight = n }) <$> f (_styleHighlight is)
+{-# INLINE styleHighlight #-}
+
+-- | This is a lens that can be used to modify the highlight used for reserved identifiers in this identifier set.
+--
+-- @'styleReservedHighlight' :: Lens' ('IdentifierStyle' m) 'Highlight'@
+styleReservedHighlight :: Functor f => (Highlight -> f Highlight) -> IdentifierStyle m -> f (IdentifierStyle m)
+styleReservedHighlight f is = (\n -> is { _styleReservedHighlight = n }) <$> f (_styleReservedHighlight is)
+{-# INLINE styleReservedHighlight #-}
+
+-- | This is a traversal that can be used to modify the highlights used for both non-reserved and reserved identifiers in this identifier set.
+--
+-- @'styleHighlights' :: Traversal' ('IdentifierStyle' m) 'Highlight'@
+styleHighlights :: Applicative f => (Highlight -> f Highlight) -> IdentifierStyle m -> f (IdentifierStyle m)
+styleHighlights f is = (\n m -> is { _styleHighlight = n, _styleReservedHighlight = m }) <$> f (_styleHighlight is) <*> f (_styleReservedHighlight is)
+{-# INLINE styleHighlights #-}
+
-- | Lift an identifier style into a monad transformer
+--
+-- Using @over@ from the @lens@ package:
+--
+-- @'liftIdentifierStyle' = over 'styleChars' 'lift'@
liftIdentifierStyle :: (MonadTrans t, Monad m) => IdentifierStyle m -> IdentifierStyle (t m)
-liftIdentifierStyle s =
- s { styleStart = lift (styleStart s)
- , styleLetter = lift (styleLetter s)
- }
+liftIdentifierStyle = runIdentity . styleChars (Identity . lift)
{-# INLINE liftIdentifierStyle #-}
-- | parse a reserved operator or identifier using a given style
reserve :: (TokenParsing m, Monad m) => IdentifierStyle m -> String -> m ()
reserve s name = token $ try $ do
- _ <- highlight (styleReservedHighlight s) $ string name
- notFollowedBy (styleLetter s) <?> "end of " ++ show name
+ _ <- highlight (_styleReservedHighlight s) $ string name
+ notFollowedBy (_styleLetter s) <?> "end of " ++ show name
{-# INLINE reserve #-}
-- | parse an non-reserved identifier or symbol
ident :: (TokenParsing m, Monad m) => IdentifierStyle m -> m String
ident s = token $ try $ do
- name <- highlight (styleHighlight s)
- ((:) <$> styleStart s <*> many (styleLetter s) <?> styleName s)
- when (HashSet.member name (styleReserved s)) $ unexpected $ "reserved " ++ styleName s ++ " " ++ show name
+ name <- highlight (_styleHighlight s)
+ ((:) <$> _styleStart s <*> many (_styleLetter s) <?> _styleName s)
+ when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name
return name
{-# INLINE ident #-}
@@ -518,12 +621,17 @@ newtype Unhighlighted m a = Unhighlighted { runUnhighlighted :: m a }
instance MonadTrans Unhighlighted where
lift = Unhighlighted
+ {-# INLINE lift #-}
instance (TokenParsing m, MonadPlus m) => TokenParsing (Unhighlighted m) where
nesting (Unhighlighted m) = Unhighlighted (nesting m)
+ {-# INLINE nesting #-}
someSpace = lift someSpace
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight _ m = m
+ {-# INLINE highlight #-}
-- | This is a parser transformer you can use to disable the automatic trailing
-- space consumption of a Token parser.
@@ -532,9 +640,14 @@ newtype Unspaced m a = Unspaced { runUnspaced :: m a }
instance MonadTrans Unspaced where
lift = Unspaced
+ {-# INLINE lift #-}
instance (TokenParsing m, MonadPlus m) => TokenParsing (Unspaced m) where
nesting (Unspaced m) = Unspaced (nesting m)
+ {-# INLINE nesting #-}
someSpace = empty
+ {-# INLINE someSpace #-}
semi = lift semi
+ {-# INLINE semi #-}
highlight h (Unspaced m) = Unspaced (highlight h m)
+ {-# INLINE highlight #-}
View
0  Text/Parser/Token/Highlight.hs → src/Text/Parser/Token/Highlight.hs
File renamed without changes
View
74 Text/Parser/Token/Style.hs → src/Text/Parser/Token/Style.hs
@@ -17,6 +17,12 @@ module Text.Parser.Token.Style
(
-- * Comment and white space styles
CommentStyle(..)
+ -- ** Lenses
+ , commentStart
+ , commentEnd
+ , commentLine
+ , commentNesting
+ -- ** Common Comment Styles
, emptyCommentStyle
, javaCommentStyle
, haskellCommentStyle
@@ -39,12 +45,40 @@ import Data.List (nub)
-- | How to deal with comments.
data CommentStyle = CommentStyle
- { commentStart :: String -- ^ String that starts a multiline comment
- , commentEnd :: String -- ^ String that ends a multiline comment
- , commentLine :: String -- ^ String that starts a single line comment
- , commentNesting :: Bool -- ^ Can we nest multiline comments?
+ { _commentStart :: String -- ^ String that starts a multiline comment
+ , _commentEnd :: String -- ^ String that ends a multiline comment
+ , _commentLine :: String -- ^ String that starts a single line comment
+ , _commentNesting :: Bool -- ^ Can we nest multiline comments?
}
+-- | This is a lens that can edit the string that starts a multiline comment.
+--
+-- @'commentStart' :: Lens' 'CommentStyle' 'String'@
+commentStart :: Functor f => (String -> f String) -> CommentStyle -> f CommentStyle
+commentStart f (CommentStyle s e l n) = (\s' -> CommentStyle s' e l n) <$> f s
+{-# INLINE commentStart #-}
+
+-- | This is a lens that can edit the string that ends a multiline comment.
+--
+-- @'commentEnd' :: Lens' 'CommentStyle' 'String'@
+commentEnd :: Functor f => (String -> f String) -> CommentStyle -> f CommentStyle
+commentEnd f (CommentStyle s e l n) = (\e' -> CommentStyle s e' l n) <$> f e
+{-# INLINE commentEnd #-}
+
+-- | This is a lens that can edit the string that starts a single line comment.
+--
+-- @'commentLine' :: Lens' 'CommentStyle' 'String'@
+commentLine :: Functor f => (String -> f String) -> CommentStyle -> f CommentStyle
+commentLine f (CommentStyle s e l n) = (\l' -> CommentStyle s e l' n) <$> f l
+{-# INLINE commentLine #-}
+
+-- | This is a lens that can edit whether we can nest multiline comments.
+--
+-- @'commentNesting' :: Lens' 'CommentStyle' 'Bool'@
+commentNesting :: Functor f => (Bool -> f Bool) -> CommentStyle -> f CommentStyle
+commentNesting f (CommentStyle s e l n) = CommentStyle s e l <$> f n
+{-# INLINE commentNesting #-}
+
-- | No comments at all
emptyCommentStyle :: CommentStyle
emptyCommentStyle = CommentStyle "" "" "" True
@@ -90,41 +124,41 @@ set = HashSet.fromList
-- | A simple operator style based on haskell with no reserved operators
emptyOps :: TokenParsing m => IdentifierStyle m
emptyOps = IdentifierStyle
- { styleName = "operator"
- , styleStart = styleLetter emptyOps
- , styleLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
- , styleReserved = mempty
- , styleHighlight = Operator
- , styleReservedHighlight = ReservedOperator
+ { _styleName = "operator"
+ , _styleStart = _styleLetter emptyOps
+ , _styleLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , _styleReserved = mempty
+ , _styleHighlight = Operator
+ , _styleReservedHighlight = ReservedOperator
}
-- | A simple operator style based on haskell with the operators from Haskell 98.
haskell98Ops, haskellOps :: TokenParsing m => IdentifierStyle m
haskell98Ops = emptyOps
- { styleReserved = set ["::","..","=","\\","|","<-","->","@","~","=>"]
+ { _styleReserved = set ["::","..","=","\\","|","<-","->","@","~","=>"]
}
haskellOps = haskell98Ops
-- | A simple identifier style based on haskell with no reserve words
emptyIdents :: TokenParsing m => IdentifierStyle m
emptyIdents = IdentifierStyle
- { styleName = "identifier"
- , styleStart = letter <|> char '_'
- , styleLetter = alphaNum <|> oneOf "_'"
- , styleReserved = set []
- , styleHighlight = Identifier
- , styleReservedHighlight = ReservedIdentifier
+ { _styleName = "identifier"
+ , _styleStart = letter <|> char '_'
+ , _styleLetter = alphaNum <|> oneOf "_'"
+ , _styleReserved = set []
+ , _styleHighlight = Identifier
+ , _styleReservedHighlight = ReservedIdentifier
}
-- | A simple identifier style based on haskell with only the reserved words from Haskell 98.
haskell98Idents :: TokenParsing m => IdentifierStyle m
haskell98Idents = emptyIdents
- { styleReserved = set haskell98ReservedIdents }
+ { _styleReserved = set haskell98ReservedIdents }
-- | A simple identifier style based on haskell with the reserved words from Haskell 98 and some common extensions.
haskellIdents :: TokenParsing m => IdentifierStyle m
haskellIdents = haskell98Idents
- { styleLetter = styleLetter haskell98Idents <|> char '#'
- , styleReserved = set $ haskell98ReservedIdents ++
+ { _styleLetter = _styleLetter haskell98Idents <|> char '#'
+ , _styleReserved = set $ haskell98ReservedIdents ++
["foreign","import","export","primitive","_ccall_","_casm_" ,"forall"]
}
View
30 tests/doctests.hs
@@ -0,0 +1,30 @@
+module Main where
+
+import Build_doctests (deps)
+import Control.Applicative
+import Control.Monad
+import Data.List
+import System.Directory
+import System.FilePath
+import Test.DocTest
+
+main :: IO ()
+main = getSources >>= \sources -> doctest $
+ "-isrc"
+ : "-idist/build/autogen"
+ : "-optP-include"
+ : "-optPdist/build/autogen/cabal_macros.h"
+ : "-hide-all-packages"
+ : map ("-package="++) deps ++ sources
+
+getSources :: IO [FilePath]
+getSources = filter (isSuffixOf ".hs") <$> go "src"
+ where
+ go dir = do
+ (dirs, files) <- getFilesAndDirectories dir
+ (files ++) . concat <$> mapM go dirs
+
+getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])
+getFilesAndDirectories dir = do
+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir
+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
View
16 travis/cabal-apt-install
@@ -0,0 +1,16 @@
+#!/bin/sh
+set -eu
+
+sudo apt-get -q update
+sudo apt-get -q -y install dctrl-tools
+
+# Try installing some of the build-deps with apt-get for speed.
+eval "$(
+ printf '%s' "grep-aptavail -n -sPackage '(' -FFALSE -X FALSE ')'"
+ 2>/dev/null cabal install "$@" --dry-run -v | \
+ sed -nre "s/^([^ ]+)-[0-9.]+ \(.*$/ -o '(' -FPackage -X libghc-\1-dev ')'/p" | \
+ xargs -d'\n'
+)" | sort -u | xargs -d'\n' sudo apt-get -q -y install -- libghc-quickcheck2-dev
+
+# Install whatever is still needed with cabal.
+cabal install "$@"
View
16 travis/config
@@ -0,0 +1,16 @@
+-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix
+--
+-- This is particularly useful for travis-ci to get it to stop complaining
+-- about a broken build when everything is still correct on our end.
+--
+-- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead
+--
+-- To enable this, uncomment the before_script in .travis.yml
+
+remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive
+remote-repo-cache: ~/.cabal/packages
+world-file: ~/.cabal/world
+build-summary: ~/.cabal/logs/build.log
+remote-build-reporting: anonymous
+install-dirs user
+install-dirs global
Please sign in to comment.
Something went wrong with that request. Please try again.