[auto ekmett@gmail.com**20090504091837 Ignore-this: acd6ab08121bbc68a785851e6cb98720 ] { hunk ./doc/html/parsimony/Text-Parsimony-Prim.html 507 -> Magic Any Magic Any
data Magic Source
MagicText.Parsimony.Utilimport Prelude hiding ((.),id) -import Text.Parsimony.Util -import Unsafe.Coerce (unsafeCoerce) -import Data.Traversable -#ifdef X_OverloadedStrings -import Data.String -#endif - --- | This parser is capable of parsing a token stream and obtaining an answer -data Parsing - --- | This parser may only be used to recognize a token stream as belonging to a context-free language -data Recognizing - --- | 'Parser' invariants provided by smart constructors: --- --- (1) a Name never contains a Name directly --- --- (2) Labels never contain Labels directly --- --- (3) an Alt never contains an Alt directly --- --- (4) a Greedy never contains a Greedy directly --- --- (5) a Skip never contains a Skip transitively --- --- Unenforceable invariants required for the parallel parser: --- --- (1) The set of non-terminals used by the parser is finite - -data Parser m t a where - App :: Parser m t (a -> b) -> Parser m t a -> Parser m t b - Pure :: Pure m a -> Parser m t a - Alt :: [Parser m t a] -> Parser m t a - Greedy :: [Parser m t a] -> Parser m t a - Satisfy :: Fun m t a -> (t -> Bool) -> Parser m t a - Skip :: Parser Recognizing t a -> Parser m t () - Name :: Parser m t a -> String -> Parser m t a - Labels :: Parser m t a -> [String] -> Parser m t a - --- | A parser mode defines what optimizations are possible, and how much information must be retained -class (Arrow (Fun m), Applicative (Pure m)) => Mode m where - type Pure m :: * -> * - type Fun m :: * -> * -> * - - fmapParser :: (a -> b) -> Parser m t a -> Parser m t b - pureParser :: a -> Parser m t a - appParser :: Parser m t (a -> b) -> Parser m t a -> Parser m t b - skip :: Parser Recognizing t a -> Parser m t () - - fmapParser g (App f x) = App (fmap g <$> f) x - fmapParser g (Pure a) = Pure (g <$> a) - fmapParser g (Alt as) = Alt (fmap g <$> as) - fmapParser g (Greedy as) = Greedy (fmap g <$> as) - fmapParser g (Satisfy s p) = Satisfy (arr g . s) p - fmapParser _ s@(Skip _) = unsafeCoerce s - fmapParser g (Name p s) = Name (g <$> p) s - fmapParser g (Labels p ss) = Labels (g <$> p) ss - - pureParser = Pure . pure - - skip = Skip - --- | Generate a parser that recognizes a single token using a predicate -satisfy :: Mode m => (t -> Bool) -> Parser m t t -satisfy = Satisfy id - --- | treat a non-recognizing parser as a recognizing one to reduce redundant rules -recognizing :: Mode m => Parser m t a -> Parser Recognizing t a -recognizing = unsafeCoerce - --- | a parser mode that actually parses and retains intermediate results -instance Mode Parsing where - type Pure Parsing = Id - type Fun Parsing = (->) - - appParser (Pure f) (Pure x) = Pure (f <*> x) - appParser (Pure f) (Satisfy s p) = Satisfy (runId f <$> s) p - appParser f x = App f x - --- | unsafeCoerces parsers to gain additional sharing that cannot be obtained in a general parser -instance Mode Recognizing where - type Pure Recognizing = TrivialApplicative - type Fun Recognizing = TrivialArrow - - skip = unsafeCoerce - fmapParser _ = unsafeCoerce - - appParser Pure{} x = unsafeCoerce x - appParser f Pure{} = unsafeCoerce f - appParser f x = App f x - - pureParser _ = unsafeCoerce epsilon - --- | parser that accepts the empty string used by Recognizing parsers where necessary -epsilon :: Parser Recognizing Magic () -epsilon = Pure undefined `named` "epsilon" - -instance Mode m => Functor (Parser m t) where - fmap = fmapParser - -instance Mode m => Applicative (Parser m t) where - pure = pureParser - (<*>) = appParser - -instance Mode m => Alternative (Parser m t) where - empty = Alt [] - Alt as <|> Alt bs = Alt (as ++ bs) - Alt as <|> b = Alt (as ++ [b]) - a <|> Alt bs = Alt (a:bs) - a <|> b = Alt [a,b] - --- | optimized version of '(<$)' -(<<$) :: Mode m => a -> Parser Recognizing t b -> Parser m t a -a <<$ p = const a <$> skip p - --- | optimized version of '(*>)' -(*>>) :: Mode m => Parser Recognizing t a -> Parser m t b -> Parser m t b -a *>> b = const id <$> skip a <*> b - --- | optimized version of '(<*)' -(<<*) :: Mode m => Parser m t a -> Parser Recognizing t b -> Parser m t a -a <<* b = const <$> a <*> skip b - --- | smart constructor for naming parsers for purposes of displaying the grammar -named :: Parser m t a -> String -> Parser m t a -named (Name p _) = Name p -named p = Name p - --- | smart constructor for labeling the grammar ala Parsec -labels :: Parser m t a -> [String] -> Parser m t a -labels (Labels p _) = Labels p -labels p = Labels p - --- | Annotate a parser with what it should say was expected if the first character in it is unconsumed -(<?>) :: Parser m t a -> String -> Parser m t a -p <?> s = labels p [s] - --- | Multiple parsers returning multiple answers -choice :: [Parser m t a] -> Parser m t a -choice = Alt . foldr flatten [] where - flatten (Alt bs) as = bs ++ as - flatten a as = a : as - --- | Prefers the result from the left when present. Only accepts parses from the right hand parser --- when the left hand parser fails. -(<<|>) :: Parser m t a -> Parser m t a -> Parser m t a -Greedy as <<|> Greedy bs = Greedy (as ++ bs) -Greedy as <<|> a = Greedy (as ++ [a]) -a <<|> Greedy as = Greedy (a : as) -a <<|> b = Greedy [a,b] - --- | Multiple parsers returning the results from the left-most parser that matches anything -greedyChoice :: [Parser m t a] -> Parser m t a -greedyChoice = Greedy . foldr flatten [] where - flatten (Greedy bs) as = bs ++ as - flatten a as = a : as - --- | Here rather than in Text.Parsimony.Char to avoid an orphan instance -#ifdef X_OverloadedStrings -instance Mode m => IsString (Parser m Char String) where - fromString = traverse (\x -> satisfy (==x) <?> show [x]) -#endif +import GHC.Prim (Any) +import Prelude hiding ((.),id) +import Text.Parsimony.Util +import Unsafe.Coerce (unsafeCoerce) +import Data.Traversable +#ifdef X_OverloadedStrings +import Data.String +#endif + +-- | This parser is capable of parsing a token stream and obtaining an answer +data Parsing + +-- | This parser may only be used to recognize a token stream as belonging to a context-free language +data Recognizing + +-- | 'Parser' invariants provided by smart constructors: +-- +-- (1) a Name never contains a Name directly +-- +-- (2) Labels never contain Labels directly +-- +-- (3) an Alt never contains an Alt directly +-- +-- (4) a Greedy never contains a Greedy directly +-- +-- (5) a Skip never contains a Skip transitively +-- +-- Unenforceable invariants required for the parallel parser: +-- +-- (1) The set of non-terminals used by the parser is finite + +data Parser m t a where + App :: Parser m t (a -> b) -> Parser m t a -> Parser m t b + Pure :: Pure m a -> Parser m t a + Alt :: [Parser m t a] -> Parser m t a + Greedy :: [Parser m t a] -> Parser m t a + Satisfy :: Fun m t a -> (t -> Bool) -> Parser m t a + Skip :: Parser Recognizing t a -> Parser m t () + Name :: Parser m t a -> String -> Parser m t a + Labels :: Parser m t a -> [String] -> Parser m t a + +-- | A parser mode defines what optimizations are possible, and how much information must be retained +class (Arrow (Fun m), Applicative (Pure m)) => Mode m where + type Pure m :: * -> * + type Fun m :: * -> * -> * + + fmapParser :: (a -> b) -> Parser m t a -> Parser m t b + pureParser :: a -> Parser m t a + appParser :: Parser m t (a -> b) -> Parser m t a -> Parser m t b + skip :: Parser Recognizing t a -> Parser m t () + + fmapParser g (App f x) = App (fmap g <$> f) x + fmapParser g (Pure a) = Pure (g <$> a) + fmapParser g (Alt as) = Alt (fmap g <$> as) + fmapParser g (Greedy as) = Greedy (fmap g <$> as) + fmapParser g (Satisfy s p) = Satisfy (arr g . s) p + fmapParser _ s@(Skip _) = unsafeCoerce s + fmapParser g (Name p s) = Name (g <$> p) s + fmapParser g (Labels p ss) = Labels (g <$> p) ss + + pureParser = Pure . pure + + skip = Skip + +-- | Generate a parser that recognizes a single token using a predicate +satisfy :: Mode m => (t -> Bool) -> Parser m t t +satisfy = Satisfy id + +-- | treat a non-recognizing parser as a recognizing one to reduce redundant rules +recognizing :: Mode m => Parser m t a -> Parser Recognizing t a +recognizing = unsafeCoerce + +-- | a parser mode that actually parses and retains intermediate results +instance Mode Parsing where + type Pure Parsing = Id + type Fun Parsing = (->) + + appParser (Pure f) (Pure x) = Pure (f <*> x) + appParser (Pure f) (Satisfy s p) = Satisfy (runId f <$> s) p + appParser f x = App f x + +-- | unsafeCoerces parsers to gain additional sharing that cannot be obtained in a general parser +instance Mode Recognizing where + type Pure Recognizing = TrivialApplicative + type Fun Recognizing = TrivialArrow + + skip = unsafeCoerce + fmapParser _ = unsafeCoerce + + appParser Pure{} x = unsafeCoerce x + appParser f Pure{} = unsafeCoerce f + appParser f x = App f x + + pureParser _ = unsafeCoerce epsilon + +-- | parser that accepts the empty string used by Recognizing parsers where necessary +epsilon :: Parser Recognizing Any () +epsilon = Pure undefined `named` "epsilon" + +instance Mode m => Functor (Parser m t) where + fmap = fmapParser + +instance Mode m => Applicative (Parser m t) where + pure = pureParser + (<*>) = appParser + +instance Mode m => Alternative (Parser m t) where + empty = Alt [] + Alt as <|> Alt bs = Alt (as ++ bs) + Alt as <|> b = Alt (as ++ [b]) + a <|> Alt bs = Alt (a:bs) + a <|> b = Alt [a,b] + +-- | optimized version of '(<$)' +(<<$) :: Mode m => a -> Parser Recognizing t b -> Parser m t a +a <<$ p = const a <$> skip p + +-- | optimized version of '(*>)' +(*>>) :: Mode m => Parser Recognizing t a -> Parser m t b -> Parser m t b +a *>> b = const id <$> skip a <*> b + +-- | optimized version of '(<*)' +(<<*) :: Mode m => Parser m t a -> Parser Recognizing t b -> Parser m t a +a <<* b = const <$> a <*> skip b + +-- | smart constructor for naming parsers for purposes of displaying the grammar +named :: Parser m t a -> String -> Parser m t a +named (Name p _) = Name p +named p = Name p + +-- | smart constructor for labeling the grammar ala Parsec +labels :: Parser m t a -> [String] -> Parser m t a +labels (Labels p _) = Labels p +labels p = Labels p + +-- | Annotate a parser with what it should say was expected if the first character in it is unconsumed +(<?>) :: Parser m t a -> String -> Parser m t a +p <?> s = labels p [s] + +-- | Multiple parsers returning multiple answers +choice :: [Parser m t a] -> Parser m t a +choice = Alt . foldr flatten [] where + flatten (Alt bs) as = bs ++ as + flatten a as = a : as + +-- | Prefers the result from the left when present. Only accepts parses from the right hand parser +-- when the left hand parser fails. +(<<|>) :: Parser m t a -> Parser m t a -> Parser m t a +Greedy as <<|> Greedy bs = Greedy (as ++ bs) +Greedy as <<|> a = Greedy (as ++ [a]) +a <<|> Greedy as = Greedy (a : as) +a <<|> b = Greedy [a,b] + +-- | Multiple parsers returning the results from the left-most parser that matches anything +greedyChoice :: [Parser m t a] -> Parser m t a +greedyChoice = Greedy . foldr flatten [] where + flatten (Greedy bs) as = bs ++ as + flatten a as = a : as + +-- | Here rather than in Text.Parsimony.Char to avoid an orphan instance +#ifdef X_OverloadedStrings +instance Mode m => IsString (Parser m Char String) where + fromString = traverse (\x -> satisfy (==x) <?> show [x]) +#endif hunk ./doc/html/parsimony/src/Text-Parsimony-StableMap.html 27 - -import Text.Parsimony.Util (Magic) - -newtype StableMap f = StableMap { getStableMap :: IntMap [(StableName Magic, f Magic)] } - -empty :: StableMap f -empty = StableMap IntMap.empty - -insert :: StableName a -> f a -> StableMap f -> StableMap f -insert k v = StableMap . IntMap.insertWith (++) (hashStableName k) [unsafeCoerce (k, v)] . getStableMap - -lookup :: StableName a -> StableMap f -> Maybe (f a) -lookup k (StableMap m) = do - x <- IntMap.lookup (hashStableName k) m - unsafeCoerce $ Prelude.lookup (unsafeCoerce k) x - -update :: StableName a -> f a -> StableMap f -> StableMap f -update k v = StableMap . IntMap.adjust update' (hashStableName k) . getStableMap where - k' :: StableName Magic - k' = unsafeCoerce k - - v' :: f Magic - v' = unsafeCoerce v - - update' :: [(StableName Magic, f Magic)] -> [(StableName Magic, f Magic)] - update' ((k'',v''):ks) - | k' == k'' = (k'',v'):ks - | otherwise = (k'',v''):update' ks - update' [] = [] +import GHC.Prim (Any) + +newtype StableMap f = StableMap { getStableMap :: IntMap [(StableName Any, f Any)] } + +empty :: StableMap f +empty = StableMap IntMap.empty + +insert :: StableName a -> f a -> StableMap f -> StableMap f +insert k v = StableMap . IntMap.insertWith (++) (hashStableName k) [unsafeCoerce (k, v)] . getStableMap + +lookup :: StableName a -> StableMap f -> Maybe (f a) +lookup k (StableMap m) = do + x <- IntMap.lookup (hashStableName k) m + unsafeCoerce $ Prelude.lookup (unsafeCoerce k) x + +update :: StableName a -> f a -> StableMap f -> StableMap f +update k v = StableMap . IntMap.adjust update' (hashStableName k) . getStableMap where + k' :: StableName Any + k' = unsafeCoerce k + + v' :: f Any + v' = unsafeCoerce v + + update' :: [(StableName Any, f Any)] -> [(StableName Any, f Any)] + update' ((k'',v''):ks) + | k' == k'' = (k'',v'):ks + | otherwise = (k'',v''):update' ks + update' [] = [] hunk ./doc/html/parsimony/src/Text-Parsimony-Util.html 27 - , Magic - ) where - -import Control.Applicative -import Control.Category -import Control.Arrow - -data TrivialApplicative a -instance Functor TrivialApplicative where - fmap = undefined -instance Applicative TrivialApplicative where - pure = undefined - (<*>) = undefined - -data TrivialArrow a b -instance Functor (TrivialArrow a) where - fmap = undefined -instance Category TrivialArrow where - (.) = undefined - id = undefined -instance Arrow TrivialArrow where - arr = undefined - first = undefined - --- Control.Monad.Identity may lacks an Applicative definition by default -newtype Id a = Id { runId :: a } -instance Functor Id where - fmap f (Id a) = Id (f a) - -instance Applicative Id where - pure = Id - Id f <*> Id x = Id (f x) - --- place holder used when we need a typing dodge -data Magic + ) where + +import Control.Applicative +import Control.Category +import Control.Arrow + +data TrivialApplicative a +instance Functor TrivialApplicative where + fmap = undefined +instance Applicative TrivialApplicative where + pure = undefined + (<*>) = undefined + +data TrivialArrow a b +instance Functor (TrivialArrow a) where + fmap = undefined +instance Category TrivialArrow where + (.) = undefined + id = undefined +instance Arrow TrivialArrow where + arr = undefined + first = undefined + +-- Control.Monad.Identity may lacks an Applicative definition by default +newtype Id a = Id { runId :: a } +instance Functor Id where + fmap f (Id a) = Id (f a) + +instance Applicative Id where + pure = Id + Id f <*> Id x = Id (f x) + }