Commit 95283a5d authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Slightly optimise parseUnqualComponentName

The speed-up is smaller than I would like, only 1-2%.
parent f2717822
......@@ -12,6 +12,7 @@
module Distribution.Compat.DList (
DList,
runDList,
empty,
singleton,
fromList,
toList,
......@@ -19,7 +20,7 @@ module Distribution.Compat.DList (
) where
import Prelude ()
import Distribution.Compat.Prelude hiding (toList)
import Distribution.Compat.Prelude hiding (toList, empty)
-- | Difference list.
newtype DList a = DList ([a] -> [a])
......@@ -31,6 +32,9 @@ runDList (DList run) = run []
singleton :: a -> DList a
singleton a = DList (a:)
empty :: DList a
empty = DList id
fromList :: [a] -> DList a
fromList as = DList (as ++)
......@@ -41,7 +45,7 @@ snoc :: DList a -> a -> DList a
snoc xs x = xs <> singleton x
instance Monoid (DList a) where
mempty = DList id
mempty = empty
mappend = (<>)
instance Semigroup (DList a) where
......
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
......@@ -56,6 +57,7 @@ import Numeric (showIntAtBase)
import Prelude ()
import qualified Distribution.Compat.CharParsing as P
import qualified Distribution.Compat.DList as DList
import qualified Distribution.Compat.MonadFail as Fail
import qualified Text.Parsec as Parsec
......@@ -342,15 +344,65 @@ parsecQuoted = P.between (P.char '"') (P.char '"')
parsecMaybeQuoted :: CabalParsing m => m a -> m a
parsecMaybeQuoted p = parsecQuoted p <|> p
parsecUnqualComponentName :: CabalParsing m => m String
parsecUnqualComponentName = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-')
where
component :: CabalParsing m => m String
component = do
cs <- P.munch1 isAlphaNum
if all isDigit cs
then fail "all digits in portion of unqualified component name"
else return cs
parsecUnqualComponentName :: forall m. CabalParsing m => m String
parsecUnqualComponentName = state0 DList.empty where
--
-- using @kleene@ package we can easily see that
-- we need only two states to recognize
-- unqual-component-name
--
-- Compare with declarative
-- 'Distribution.FieldGrammar.Described.reUnqualComponent'.
--
-- @
-- import Kleene
-- import Kleene.Internal.Pretty
-- import Algebra.Lattice
-- import Data.Char
--
-- import qualified Data.RangeSet.Map as RSet
--
-- main = do
-- -- this is an approximation, to get an idea.
-- let component :: RE Char
-- component = star alphaNum <> alpha <> star alphaNum
--
-- alphaNum = alpha \/ num
-- alpha = unions $ map char ['a'..'z']
-- num = unions $ map char ['0'..'9']
--
-- re :: RE Char
-- re = component <> star (char '-' <> component)
--
-- putPretty re
-- putPretty $ fromTM re
-- @
state0 :: DList.DList Char -> m String
state0 acc = do
c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc)
case () of
_ | isDigit c -> state0 (DList.snoc acc c)
| isAlphaNum c -> state1 (DList.snoc acc c)
| c == '-' -> fail ("Empty component, after " ++ DList.toList acc)
| otherwise -> fail ("Internal error, after " ++ DList.toList acc)
state1 :: DList.DList Char -> m String
state1 acc = state1' acc `alt` return (DList.toList acc)
state1' :: DList.DList Char -> m String
state1' acc = do
c <- ch
case () of
_ | isAlphaNum c -> state1 (DList.snoc acc c)
| c == '-' -> state0 (DList.snoc acc c)
| otherwise -> fail ("Internal error, after " ++ DList.toList acc)
ch :: m Char
!ch = P.satisfy (\c -> isAlphaNum c || c == '-')
alt :: m String -> m String -> m String
!alt = (<|>)
stringLiteral :: forall m. P.CharParsing m => m String
stringLiteral = lit where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment