Permalink
Browse files

simplifying dependencies. started work on the highlighting parser tra…

…nsformer
  • Loading branch information...
1 parent 8b16cd4 commit ffe59af3e16be3abec4d13c2ee4f37faf46b0376 @ekmett committed Jul 6, 2012
@@ -19,6 +19,7 @@ module Text.Trifecta.Highlight
, withHighlight
, HighlightDoc(..)
, doc
+-- , Highlighter(..)
) where
import Control.Applicative
@@ -138,3 +139,29 @@ instance ToHtml HighlightDoc where
title $ toHtml t
link ! rel "stylesheet" ! type_ "text/css" ! href (toValue css)
body $ toHtml cs
+
+{-
+newtype Highlighter m a = Highlighter { runHighlighter :: IntervalMap Map Highlight -> m (a, IntervalMap Map Highlight) }
+ deriving (Functor)
+
+instance (Functor m, Monad m) => Applicative (Highlighter m) where
+ (<*>) = ap
+ pure = return
+
+instance (Functor m, MonadPlus m) => Alternative (Highlighter m) where
+ (<|>) = mplus
+ empty = mzero
+
+instance Monad m => Monad (Highlighter m) where
+ return a = Highlighter $ \s -> return (a, s)
+ Highlighter m >>= f = Highlighter $ \s -> m s >>= \(a, s') -> runHighlighter (f a) s'
+
+instance MonadTrans Highlighter where
+ lift m = Highlighter $ \s -> fmap (\a -> (a,s)) m
+
+instance MonadPlus m => MonadPlus (Highlighter m) where
+ mplus (Highlighter m) (Highligher n) = Highlighter $ \s -> m s `mplus` n s
+ mzero = Highlighter $ const mzero
+
+-- instance Parsing m => Parsing (Highlighter m) where
+-}
@@ -44,10 +44,7 @@ import Control.Monad (MonadPlus(..), ap, join, guard)
import Data.ByteString as Strict hiding (empty, snoc)
import Data.ByteString.UTF8 as UTF8
import Data.Foldable
-import Data.Functor.Apply
import Data.Maybe (fromMaybe, isJust)
-import Data.Functor.Bind (Bind((>>-)))
-import Data.Functor.Plus as Plus
import qualified Data.List as List
import Data.Semigroup
import Data.Semigroup.Reducer
@@ -97,19 +94,12 @@ instance Functor Parser where
a <$ Parser m = Parser $ \ eo ee co -> m (\_ -> eo a) ee (\_ -> co a)
{-# INLINE (<$) #-}
-instance Apply Parser where (<.>) = (<*>)
instance Applicative Parser where
pure a = Parser $ \ eo _ _ _ _ _ -> eo a mempty
{-# INLINE pure #-}
(<*>) = ap
{-# INLINE (<*>) #-}
-instance Alt Parser where
- (<!>) = (<|>)
- many p = Prelude.reverse <$> manyAccum (:) p
- some p = p *> Plus.many p
-
-instance Plus Parser where zero = empty
instance Alternative Parser where
empty = Parser $ \_ ee _ _ _ _ -> ee mempty
{-# INLINE empty #-}
@@ -127,7 +117,6 @@ instance Monoid (Parser a) where
mappend = (<|>)
mempty = empty
-instance Bind Parser where (>>-) = (>>=)
instance Monad Parser where
return a = Parser $ \ eo _ _ _ _ _ -> eo a mempty
{-# INLINE return #-}
@@ -253,21 +242,12 @@ instance Applicative Result where
Failure xs <*> Success _ = Failure xs
Failure xs <*> Failure ys = Failure $ above xs ys
-instance Apply Result where
- (<.>) = (<*>)
-
-instance Alt Result where
- Failure xs <!> Failure ys = Failure $ above xs ys
- Success a <!> Success _ = Success a
- Success a <!> Failure _ = Success a
- Failure _ <!> Success a = Success a
-
-instance Plus Result where
- zero = Failure mempty
-
instance Alternative Result where
- (<|>) = (<!>)
- empty = zero
+ Failure xs <|> Failure ys = Failure $ above xs ys
+ Success a <|> Success _ = Success a
+ Success a <|> Failure _ = Success a
+ Failure _ <|> Success a = Success a
+ empty = Failure mempty
data Step a
= StepDone !Rope a
@@ -57,14 +57,11 @@ import Data.ByteString as B hiding (groupBy, empty, any)
import qualified Data.ByteString.UTF8 as UTF8
import Data.Foldable
import Data.Function (on)
-import Data.Functor.Bind
import Data.Hashable
import Data.Int (Int64)
import Data.List (groupBy)
import Data.Semigroup
-import Data.Semigroup.Foldable
import Data.Semigroup.Reducer
-import Data.Semigroup.Traversable
import Data.Traversable
import Prelude as P hiding (span)
import System.Console.Terminfo.Color
@@ -234,28 +231,15 @@ instance Comonad Rendered where
extend f as@(_ :@ s) = f as :@ s
extract (a :@ _) = a
-instance Apply Rendered where
- (f :@ s) <.> (a :@ t) = f a :@ (s <> t)
-
instance ComonadApply Rendered where
(f :@ s) <@> (a :@ t) = f a :@ (s <> t)
-instance Bind Rendered where
- (a :@ s) >>- f = case f a of
- b :@ t -> b :@ (s <> t)
-
instance Foldable Rendered where
foldMap f (a :@ _) = f a
instance Traversable Rendered where
traverse f (a :@ s) = (:@ s) <$> f a
-instance Foldable1 Rendered where
- foldMap1 f (a :@ _) = f a
-
-instance Traversable1 Rendered where
- traverse1 f (a :@ s) = (:@ s) <$> f a
-
instance Renderable (Rendered a) where
render (_ :@ s) = s
@@ -312,6 +296,9 @@ instance Comonad Careted where
extend f as@(_ :^ s) = f as :^ s
extract (a :^ _) = a
+instance ComonadApply Careted where
+ (a :^ c) <@> (b :^ d) = a b :^ (c <> d)
+
instance Foldable Careted where
foldMap f (a :^ _) = f a
@@ -326,7 +313,6 @@ instance Reducer (Careted a) Rendering where
instance Hashable a => Hashable (Careted a) where
-
spanEffects :: [ScopedEffect]
spanEffects = [soft (Foreground Green)]
@@ -370,6 +356,9 @@ instance Comonad Spanned where
extend f as@(_ :~ s) = f as :~ s
extract (a :~ _) = a
+instance ComonadApply Spanned where
+ (a :~ c) <@> (b :~ d) = a b :~ (c <> d)
+
instance Foldable Spanned where
foldMap f (a :~ _) = f a
@@ -412,4 +401,3 @@ instance Reducer Fixit Rendering where
instance Renderable Fixit where
render (Fixit (Span s e bs) r) = addFixit s e (UTF8.toString r) $ rendering s bs
-
@@ -50,15 +50,12 @@ module Text.Trifecta.Util.IntervalMap
import Control.Applicative hiding (empty)
import qualified Data.FingerTree as FT
import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><))
-import Data.Functor.Plus
import Data.Traversable (Traversable(traverse))
import Data.Foldable (Foldable(foldMap))
-import Data.Bifunctor
import Data.Semigroup
import Data.Semigroup.Reducer
import Data.Semigroup.Union
import Data.Key
-import Data.Pointed
----------------------------------
-- 4.8 Application: interval trees
@@ -96,19 +93,13 @@ instance Foldable Interval where
instance Traversable Interval where
traverse f (Interval a b) = Interval <$> f a <*> f b
-instance Pointed Interval where
- point v = Interval v v
-
data Node v a = Node (Interval v) a
type instance Key (Node v) = Interval v
instance Functor (Node v) where
fmap f (Node i x) = Node i (f x)
-instance Bifunctor Node where
- bimap f g (Node v a) = Node (fmap f v) (g a)
-
instance Keyed (Node v) where
mapWithKey f (Node i x) = Node i (f i x)
@@ -198,15 +189,9 @@ instance Ord v => Monoid (IntervalMap v a) where
mempty = empty
mappend = union
-instance Ord v => Alt (IntervalMap v) where
- (<!>) = union
-
-instance Ord v => Plus (IntervalMap v) where
- zero = empty
-
-- | /O(n)/. Add a delta to each interval in the map
offset :: (Ord v, Monoid v) => v -> IntervalMap v a -> IntervalMap v a
-offset v (IntervalMap m) = IntervalMap $ FT.fmap' (first (mappend v)) m
+offset v (IntervalMap m) = IntervalMap $ FT.fmap' (\(Node (Interval lo hi) a) -> Node (Interval (mappend v lo) (mappend v hi)) a) m
-- | /O(1)/. Interval map with a single entry.
singleton :: Ord v => Interval v -> a -> IntervalMap v a
@@ -32,8 +32,6 @@ import Control.Monad
import Data.Semigroup
import Data.ByteString as Strict
import Data.ByteString.Lazy as Lazy
-import Data.Functor.Bind
-import Data.Profunctor
import Data.Key as Key
import Text.Trifecta.Rope
import Text.Trifecta.Delta
@@ -53,13 +51,6 @@ instance Functor (It r) where
type instance Key (It r) = r
-instance Profunctor It where
- lmap _ (Pure a) = Pure a
- lmap f (It a k) = It a (lmap f . k . f)
-
- rmap g (Pure a) = Pure (g a)
- rmap g (It a k) = It (g a) (rmap g . k)
-
instance Applicative (It r) where
pure = Pure
Pure f <*> Pure a = Pure $ f a
@@ -88,8 +79,7 @@ instance Monad (It r) where
It a' k' -> It (Key.index (f a') r) $ k' >=> f
Pure a' -> simplifyIt (f a') r
-instance Apply (It r) where (<.>) = (<*>)
-instance Bind (It r) where (>>-) = (>>=)
+instance ComonadApply (It r) where (<@>) = (<*>)
-- | It is a cofree comonad
instance Comonad (It r) where
View
@@ -45,7 +45,6 @@ library
build-depends:
array >= 0.3.0.2 && < 0.5,
base == 4.*,
- bifunctors == 3.0.*,
blaze-builder >= 0.3.0.1 && < 0.4,
blaze-html >= 0.4.1.6 && < 0.5,
bytestring >= 0.9.1 && < 0.11,
@@ -58,10 +57,7 @@ library
keys == 3.0.*,
mtl >= 2.0.1 && < 2.2,
parsers == 0.2.*,
- pointed == 3.0.*,
- profunctors == 3.0.*,
reducers == 3.0.*,
- semigroupoids == 3.0.*,
semigroups >= 0.8.3.1 && < 0.9,
terminfo >= 0.3.2 && < 0.4,
transformers >= 0.2 && < 0.4,

0 comments on commit ffe59af

Please sign in to comment.