Dag Odenhall avatar Dag Odenhall committed 258a299

Haskell lexer: template-haskell quoted names

Comments (0)

Files changed (2)

pygments/lexers/functional.py

             (r'\berror\b', Name.Exception),
             (r'\b(%s)(?!\')\b' % '|'.join(reserved), Keyword.Reserved),
             (r'^[_a-z][\w\']*', Name.Function),
-            (r'[_a-z][\w\']*', Name),
-            (r'[A-Z][\w\']*', Keyword.Type),
+            (r"'?[_a-z][\w']*", Name),
+            (r"('')?[A-Z][\w\']*", Keyword.Type),
             #  Operators
             (r'\\(?![:!#$%&*+.\\/<=>?@^|~-]+)', Name.Function), # lambda operator
             (r'(<-|::|->|=>|=)(?![:!#$%&*+.\\/<=>?@^|~-]+)', Operator.Word), # specials

tests/examplefiles/AcidStateAdvanced.hs

+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving
+  , MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TemplateHaskell
+  , TypeFamilies, FlexibleInstances #-}
+module Main where
+import Control.Applicative  (Applicative, Alternative, (<$>))
+import Control.Exception.Lifted    (bracket)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad        (MonadPlus, mplus)
+import Control.Monad.Reader (MonadReader, ReaderT(..), ask)
+import Control.Monad.Trans  (MonadIO(..))
+import Data.Acid            ( AcidState(..), EventState(..), EventResult(..)
+                            , Query(..), QueryEvent(..), Update(..), UpdateEvent(..)
+                            , IsAcidic(..), makeAcidic, openLocalState
+                            )
+import Data.Acid.Local      ( createCheckpointAndClose
+                            , openLocalStateFrom
+                            )
+import Data.Acid.Advanced   (query', update')
+import Data.Maybe           (fromMaybe)
+import Data.SafeCopy        (SafeCopy, base, deriveSafeCopy)
+import Data.Data            (Data, Typeable)
+import Data.Lens            ((%=), (!=))
+import Data.Lens.Template   (makeLens)
+import Data.Text.Lazy       (Text)
+import Happstack.Server     ( Happstack, HasRqData, Method(GET, POST), Request(rqMethod)
+                            , Response
+                            , ServerPartT(..), WebMonad, FilterMonad, ServerMonad
+                            , askRq, decodeBody, dir, defaultBodyPolicy, lookText
+                            , mapServerPartT, nullConf, nullDir, ok, simpleHTTP
+                            , toResponse
+                            )
+import Prelude hiding       (head, id)
+import System.FilePath      ((</>))
+import Text.Blaze           ((!))
+import Text.Blaze.Html4.Strict (body, head, html, input, form, label, p, title, toHtml)
+import Text.Blaze.Html4.Strict.Attributes (action, enctype, for, id, method, name, type_, value)
+class HasAcidState m st where
+   getAcidState :: m (AcidState st)
+query :: forall event m. 
+         ( Functor m
+         , MonadIO m
+         , QueryEvent event
+         , HasAcidState m (EventState event)
+         ) => 
+         event
+      -> m (EventResult event)
+query event =
+    do as <- getAcidState
+       query' (as :: AcidState (EventState event)) event
+update :: forall event m. 
+          ( Functor m
+          , MonadIO m
+          , UpdateEvent event
+          , HasAcidState m (EventState event)
+          ) => 
+          event 
+       -> m (EventResult event)
+update event =
+    do as <- getAcidState
+       update' (as :: AcidState (EventState event)) event
+-- | bracket the opening and close of the `AcidState` handle. 
+
+-- automatically creates a checkpoint on close
+withLocalState :: (MonadBaseControl IO m, MonadIO m, IsAcidic st, Typeable st) => 
+                  Maybe FilePath           -- ^ path to state directory
+                 -> st                     -- ^ initial state value
+                 -> (AcidState st -> m a) -- ^ function which uses the `AcidState` handle
+                 -> m a
+withLocalState mPath initialState =
+    bracket (liftIO $ (maybe openLocalState openLocalStateFrom mPath) initialState)
+            (liftIO . createCheckpointAndClose)
+-- State that stores a hit count
+
+data CountState = CountState { _count :: Integer }
+                deriving (Eq, Ord, Data, Typeable, Show)
+
+$(deriveSafeCopy 0 'base ''CountState)
+$(makeLens ''CountState)
+
+initialCountState :: CountState
+initialCountState = CountState { _count = 0 }
+
+incCount :: Update CountState Integer
+incCount = count %= succ
+
+$(makeAcidic ''CountState ['incCount])
+-- State that stores a greeting
+data GreetingState = GreetingState {  _greeting :: Text }
+                deriving (Eq, Ord, Data, Typeable, Show)
+
+$(deriveSafeCopy 0 'base ''GreetingState)
+$(makeLens ''GreetingState)
+
+initialGreetingState :: GreetingState
+initialGreetingState = GreetingState { _greeting = "Hello" }
+
+getGreeting :: Query GreetingState Text
+getGreeting = _greeting <$> ask
+
+setGreeting :: Text -> Update GreetingState Text
+setGreeting txt = greeting != txt
+
+$(makeAcidic ''GreetingState ['getGreeting, 'setGreeting])
+data Acid = Acid { acidCountState    :: AcidState CountState
+                 , acidGreetingState :: AcidState GreetingState
+                 }
+
+withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a
+withAcid mBasePath action =
+    let basePath = fromMaybe "_state" mBasePath
+    in withLocalState (Just $ basePath </> "count")    initialCountState    $ \c ->
+       withLocalState (Just $ basePath </> "greeting") initialGreetingState $ \g ->
+           action (Acid c g)
+newtype App a = App { unApp :: ServerPartT (ReaderT Acid IO) a }
+    deriving ( Functor, Alternative, Applicative, Monad, MonadPlus, MonadIO
+               , HasRqData, ServerMonad ,WebMonad Response, FilterMonad Response
+               , Happstack, MonadReader Acid)
+
+runApp :: Acid -> App a -> ServerPartT IO a
+runApp acid (App sp) = mapServerPartT (flip runReaderT acid) sp
+instance HasAcidState App CountState where
+    getAcidState = acidCountState    <$> ask 
+
+instance HasAcidState App GreetingState where
+    getAcidState = acidGreetingState <$> ask
+page :: App Response
+page =
+    do nullDir
+       g <- greet
+       c <- update IncCount -- ^ a CountState event
+       ok $ toResponse $
+          html $ do
+            head $ do
+              title "acid-state demo"
+            body $ do
+              form ! action "/" ! method "POST" ! enctype "multipart/form-data" $ do
+                label "new message: " ! for "msg"
+                input ! type_ "text" ! id "msg" ! name "greeting"
+                input ! type_ "submit" ! value "update message"
+              p $ toHtml g
+              p $ do "This page has been loaded " 
+                     toHtml c
+                     " time(s)."
+    where
+    greet =
+        do m <- rqMethod <$> askRq
+           case m of
+             POST -> 
+                 do decodeBody (defaultBodyPolicy "/tmp/" 0 1000 1000)
+                    newGreeting <- lookText "greeting"
+                    update (SetGreeting newGreeting)   -- ^ a GreetingState event
+                    return newGreeting
+             GET  -> 
+                 do query GetGreeting                  -- ^ a GreetingState event
+main :: IO ()
+main =
+    withAcid Nothing $ \acid ->
+        simpleHTTP nullConf $ runApp acid page
+newtype FooState = FooState { foo :: Text }
+    deriving (Eq, Ord, Data, Typeable, SafeCopy)
+
+initialFooState :: FooState
+initialFooState = FooState { foo = "foo" }
+
+askFoo :: Query FooState Text
+askFoo = foo <$> ask
+
+$(makeAcidic ''FooState ['askFoo])
+fooPlugin :: (Happstack m, HasAcidState m FooState) => m Response
+fooPlugin =
+    dir "foo" $ do
+       txt <- query AskFoo
+       ok $ toResponse txt
+data Acid' = Acid' { acidCountState'    :: AcidState CountState
+                   , acidGreetingState' :: AcidState GreetingState
+                   , acidFooState'      :: AcidState FooState
+                   }
+withAcid' :: Maybe FilePath -> (Acid' -> IO a) -> IO a
+withAcid' mBasePath action =
+    let basePath = fromMaybe "_state" mBasePath
+    in withLocalState (Just $ basePath </> "count")    initialCountState    $ \c ->
+       withLocalState (Just $ basePath </> "greeting") initialGreetingState $ \g ->
+       withLocalState (Just $ basePath </> "foo")      initialFooState      $ \f ->
+           action (Acid' c g f)
+newtype App' a = App' { unApp' :: ServerPartT (ReaderT Acid' IO) a }
+    deriving ( Functor, Alternative, Applicative, Monad, MonadPlus, MonadIO
+               , HasRqData, ServerMonad ,WebMonad Response, FilterMonad Response
+               , Happstack, MonadReader Acid')
+
+instance HasAcidState App' FooState where
+    getAcidState = acidFooState' <$> ask
+fooAppPlugin :: App' Response
+fooAppPlugin = fooPlugin
+fooReaderPlugin :: ReaderT (AcidState FooState) (ServerPartT IO) Response
+fooReaderPlugin = fooPlugin
+instance HasAcidState (ReaderT (AcidState FooState) (ServerPartT IO)) FooState where
+    getAcidState = ask
+withFooPlugin :: (MonadIO m, MonadBaseControl IO m) => 
+                 FilePath                          -- ^ path to state directory
+              -> (ServerPartT IO Response -> m a)  -- ^ function that uses fooPlugin
+              -> m a
+withFooPlugin basePath f =
+       do withLocalState (Just $ basePath </> "foo") initialFooState $ \fooState -> 
+              f $ runReaderT fooReaderPlugin fooState
+main' :: IO ()
+main' = 
+    withFooPlugin "_state" $ \fooPlugin' ->
+        withAcid Nothing $ \acid ->
+            simpleHTTP nullConf $ fooPlugin' `mplus` runApp acid page
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.