Permalink
Browse files

added layout

  • Loading branch information...
1 parent 17aa5a9 commit 0cd8072ef1427d42ed7ef44ebe082147e771b2c8 @ekmett committed Sep 11, 2011
View
@@ -9,3 +9,4 @@ markdown or haddock-style comments
monoidal Dyck language recognition to pre-balance parentheses
preprocessing static fragments for more intelligent backtracking
i18n support
+A literate-haskell-style comment mode
@@ -16,6 +16,9 @@ module Text.Trifecta.Diagnostic.Err
, fatalErr
) where
+import Control.Applicative
+import Data.Foldable
+import Data.Traversable
import Data.Semigroup
import Data.Functor.Plus
import Text.Trifecta.Diagnostic.Prim
@@ -46,6 +49,19 @@ instance Functor Err where
fmap _ (PanicErr s) = PanicErr s
fmap f (Err rs l e es) = Err rs l (f e) (fmap (fmap f) es)
+instance Foldable Err where
+ foldMap _ EmptyErr = mempty
+ foldMap _ FailErr{} = mempty
+ foldMap _ PanicErr{} = mempty
+ foldMap f (Err _ _ e ds) = f e `mappend` foldMap (foldMap f) ds
+
+instance Traversable Err where
+ traverse _ EmptyErr = pure EmptyErr
+ traverse _ (FailErr s) = pure $ FailErr s
+ traverse _ (PanicErr s) = pure $ PanicErr s
+ traverse f (Err rs l e ds) = Err rs l <$> f e <*> traverse (traverse f) ds
+
+-- | Merge two errors, selecting the most severe.
instance Alt Err where
a <!> EmptyErr = a
_ <!> a@(Err _ Fatal _ _) = a
@@ -55,13 +71,16 @@ instance Alt Err where
_ <!> b = b
{-# INLINE (<!>) #-}
+-- | Merge two errors, selecting the most severe.
instance Plus Err where
zero = EmptyErr
+-- | Merge two errors, selecting the most severe.
instance Semigroup (Err t) where
(<>) = (<!>)
times1p _ = id
+-- | Merge two errors, selecting the most severe.
instance Monoid (Err t) where
mempty = EmptyErr
mappend = (<!>)
@@ -38,6 +38,8 @@ data Highlight
| ReservedConstructorOperator
| BadInput
| Unbound
+ | Layout
+ | MatchedSymbols
deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded)
type Highlights = IntervalMap Delta Highlight
@@ -0,0 +1,110 @@
+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Trifecta.Parser.Layout
+-- Copyright : (C) 2011 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Edward Kmett <ekmett@gmail.com>
+-- Stability : experimental
+-- Portability : non-portable
+--
+----------------------------------------------------------------------------
+module Text.Trifecta.Parser.Layout
+ ( Layout(..)
+ , runLayout
+ , defaultLayoutState
+ ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State.Class
+import Control.Monad.Trans.State.Strict (StateT(..))
+import Control.Monad.Writer.Class
+import Control.Monad.Reader.Class
+import Control.Monad.Cont.Class
+import Control.Monad.Trans.Class
+import Data.Lens
+import Text.Trifecta.Diagnostic.Class
+import Text.Trifecta.Parser.Class
+import Text.Trifecta.Parser.Combinators
+import Text.Trifecta.Parser.Token.Class
+import Text.Trifecta.Parser.Layout.Class
+import Text.Trifecta.Rope.Delta
+
+newtype Layout m a = Layout { unlayout :: StateT LayoutState m a }
+ deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadTrans, MonadCont)
+
+runLayout :: Monad m => Layout m a -> LayoutState -> m (a, LayoutState)
+runLayout = runStateT . unlayout
+
+instance MonadTokenParser m => MonadParser (Layout m) where
+ satisfy p = try $ layoutEq Other *> lift (satisfy p)
+ satisfy8 p = try $ layoutEq Other *> lift (satisfy8 p)
+ line = lift line
+ mark = lift mark
+ release = lift . release
+ liftIt = lift . liftIt
+ unexpected = lift . unexpected
+ try = Layout . try . unlayout
+ labels m s = Layout $ labels (unlayout m) s
+ skipMany = Layout . skipMany . unlayout
+ highlight h = Layout . highlight h . unlayout
+
+instance MonadDiagnostic e m => MonadDiagnostic e (Layout m) where
+ fatalWith xs r e = lift $ fatalWith xs r e
+ errWith xs r e = lift $ errWith xs r e
+ logWith l xs r e = lift $ logWith l xs r e
+
+instance MonadTokenParser m => MonadTokenParser (Layout m) where
+ whiteSpace = skipOptional $ try (() <$ layoutEq WhiteSpace <?> "")
+ nesting (Layout m) = disableLayout $ Layout (nesting m)
+ semi = getLayout layoutStack >>= \ stk -> case stk of
+ IndentedLayout _:_ -> try (';' <$ layoutEq VirtualSemi <?> "virtual semi-colon")
+ <|> lift semi
+ _ -> lift semi
+
+instance MonadTokenParser m => MonadLayoutParser (Layout m) where
+ getLayout l = Layout $ access l
+ setLayout l t = () <$ (Layout $ l ~= t)
+ modLayout l f = () <$ (Layout $ l %= f)
+ layout = do
+ bol <- getLayout layoutBol
+ m <- mark
+ lift whiteSpace
+ r <- mark
+ if near m r && not bol
+ then onside m r
+ else do
+ stk <- getLayout layoutStack
+ case compare (column r) (depth stk) of
+ LT -> case stk of
+ (IndentedLayout _:xs) -> VirtualRightBrace <$ setLayout layoutStack xs <* setLayout layoutBol True
+ [] -> unexpected "empty layout"
+ _ -> unexpected "layout"
+ EQ -> return VirtualSemi
+ GT -> onside m r
+ where
+ onside m r
+ | r /= m = pure WhiteSpace
+ | otherwise = setLayout layoutBol False *> option Other (VirtualRightBrace <$ eof <* trailing)
+ trailing = getLayout layoutStack >>= \ stk -> case stk of
+ (IndentedLayout _:xs) -> setLayout layoutStack xs
+ _ -> empty
+
+ depth [] = 0
+ depth (IndentedLayout r:_) = column r
+ depth (DisabledLayout _:_) = -1
+
+instance MonadState s m => MonadState s (Layout m) where
+ get = Layout $ lift get
+ put = Layout . lift . put
+
+instance MonadReader e m => MonadReader e (Layout m) where
+ ask = Layout $ lift ask
+ local f (Layout m) = Layout $ local f m
+
+instance MonadWriter w m => MonadWriter w (Layout m) where
+ tell = Layout . lift . tell
+ listen (Layout m) = Layout $ listen m
+ pass (Layout m) = Layout $ pass m
@@ -0,0 +1,148 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Text.Trifecta.Parser.Layout.Class
+ ( LayoutToken(..)
+ , LayoutState(..)
+ , LayoutContext(..)
+ , MonadLayoutParser(..)
+ , defaultLayoutState
+ , layoutBol
+ , layoutStack
+ , layoutEq
+ , disableLayout
+ , enableLayout
+ , laidout
+ ) where
+
+import Control.Applicative
+import Control.Monad (guard)
+import Data.Lens.Common
+import Data.Monoid
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Identity
+import qualified Control.Monad.Trans.State.Lazy as Lazy
+import qualified Control.Monad.Trans.State.Strict as Strict
+import qualified Control.Monad.Trans.Writer.Lazy as Lazy
+import qualified Control.Monad.Trans.Writer.Strict as Strict
+import qualified Control.Monad.Trans.RWS.Lazy as Lazy
+import qualified Control.Monad.Trans.RWS.Strict as Strict
+import Text.Trifecta.Rope.Delta
+import Text.Trifecta.Rope.Bytes
+import Text.Trifecta.Parser.Class
+import Text.Trifecta.Parser.Token.Class
+import Text.Trifecta.Parser.Token.Combinators
+import qualified Text.Trifecta.Highlight.Prim as Highlight
+import Text.Trifecta.Diagnostic.Rendering.Prim
+
+data LayoutToken
+ = VirtualSemi
+ | VirtualRightBrace
+ | WhiteSpace
+ | Other
+ deriving (Eq,Ord,Show,Read)
+
+data LayoutContext
+ = IndentedLayout Rendering
+ | DisabledLayout Rendering
+
+instance HasDelta LayoutContext where
+ delta (IndentedLayout r) = delta r
+ delta (DisabledLayout r) = delta r
+
+instance HasBytes LayoutContext where
+ bytes = bytes . delta
+
+data LayoutState = LayoutState
+ { _layoutBol :: Bool
+ , _layoutStack :: [LayoutContext]
+ }
+
+defaultLayoutState :: LayoutState
+defaultLayoutState = LayoutState False []
+
+layoutBol :: Lens LayoutState Bool
+layoutBol = lens _layoutBol (\s l -> l { _layoutBol = s})
+
+layoutStack :: Lens LayoutState [LayoutContext]
+layoutStack = lens _layoutStack (\s l -> l { _layoutStack = s})
+
+disableLayout :: MonadLayoutParser m => m a -> m a
+disableLayout p = do
+ r <- rend
+ modLayout layoutStack (DisabledLayout r:)
+ result <- p
+ stk <- getLayout layoutStack
+ case stk of
+ DisabledLayout r':xs | delta r == delta r' -> result <$ setLayout layoutStack xs
+ _ -> unexpected "layout"
+
+enableLayout :: MonadLayoutParser m => m a -> m a
+enableLayout p = do
+ result <- highlight Highlight.Layout $ do
+ r <- rend
+ modLayout layoutStack (IndentedLayout r:)
+ p
+ result <$ layout <?> "virtual right brace"
+
+laidout :: MonadLayoutParser m => m a -> m a
+laidout p = braces p <|> enableLayout p
+
+layoutEq :: MonadLayoutParser m => LayoutToken -> m LayoutToken
+layoutEq s = try $ do
+ r <- layout
+ guard (s == r)
+ return r
+
+class MonadTokenParser m => MonadLayoutParser m where
+ layout :: m LayoutToken
+ getLayout :: Lens LayoutState t -> m t
+ setLayout :: Lens LayoutState t -> t -> m ()
+ modLayout :: Lens LayoutState t -> (t -> t) -> m ()
+
+instance MonadLayoutParser m => MonadLayoutParser (Strict.StateT s m) where
+ layout = lift layout
+ getLayout l = lift $ getLayout l
+ setLayout l t = lift $ setLayout l t
+ modLayout l f = lift $ modLayout l f
+
+instance MonadLayoutParser m => MonadLayoutParser (Lazy.StateT s m) where
+ layout = lift layout
+ getLayout l = lift $ getLayout l
+ setLayout l t = lift $ setLayout l t
+ modLayout l f = lift $ modLayout l f
+
+instance MonadLayoutParser m => MonadLayoutParser (ReaderT e m) where
+ layout = lift layout
+ getLayout l = lift $ getLayout l
+ setLayout l t = lift $ setLayout l t
+ modLayout l f = lift $ modLayout l f
+
+instance (Monoid w, MonadLayoutParser m) => MonadLayoutParser (Strict.WriterT w m) where
+ layout = lift layout
+ getLayout l = lift $ getLayout l
+ setLayout l t = lift $ setLayout l t
+ modLayout l f = lift $ modLayout l f
+
+instance (Monoid w, MonadLayoutParser m) => MonadLayoutParser (Lazy.WriterT w m) where
+ layout = lift layout
+ getLayout l = lift $ getLayout l
+ setLayout l t = lift $ setLayout l t
+ modLayout l f = lift $ modLayout l f
+
+instance (Monoid w, MonadLayoutParser m) => MonadLayoutParser (Strict.RWST r w s m) where
+ layout = lift layout
+ getLayout l = lift $ getLayout l
+ setLayout l t = lift $ setLayout l t
+ modLayout l f = lift $ modLayout l f
+
+instance (Monoid w, MonadLayoutParser m) => MonadLayoutParser (Lazy.RWST r w s m) where
+ layout = lift layout
+ getLayout l = lift $ getLayout l
+ setLayout l t = lift $ setLayout l t
+ modLayout l f = lift $ modLayout l f
+
+instance MonadLayoutParser m => MonadLayoutParser (IdentityT m) where
+ layout = lift layout
+ getLayout l = lift $ getLayout l
+ setLayout l t = lift $ setLayout l t
+ modLayout l f = lift $ modLayout l f
Oops, something went wrong.

0 comments on commit 0cd8072

Please sign in to comment.