authoring 0.3 → 0.3.1

raw patch · 2 files changed

+64/−10 lines, 2 files

Files

• authoring.cabal +1/−1
• src/Text/Authoring/TH.hs +63/−9

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                authoring-version:             0.3+version:             0.3.1 synopsis:            A library for writing papers description:         This package is a combinator library for writing papers. homepage:            http://github.com/nushio3/authoring

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} @@ -24,13 +25,15 @@  -} -module Text.Authoring.TH (rawQ, escQ) where+module Text.Authoring.TH (rawQ, escQ, declareLabels) where   import Control.Applicative-import Data.Char (isSpace)+import Control.Monad+import Data.Char (isSpace, toUpper, toLower)+import Data.Typeable (Typeable) import Data.Monoid-import Data.Text (pack)+import qualified Data.Text as T import Language.Haskell.TH import Language.Haskell.TH.Quote import Text.Trifecta@@ -41,6 +44,7 @@ import System.IO  import Text.Authoring.Combinator.Writer (raw, esc)+import Text.Authoring.Label (Label, fromValue)   -- | Quote with LaTeX special characters escaped. @@ -50,9 +54,9 @@ rawQ :: QuasiQuoter rawQ = QuasiQuoter {    quoteExp = parseE (QQConfig { escaper = appE (varE 'raw)}),-  quotePat  = error "Don't use Authoring QuasiQuotes in expression context" ,  -  quoteType = error "Don't use Authoring QuasiQuotes in expression context" ,  -  quoteDec  = error "Don't use Authoring QuasiQuotes in expression context" +  quotePat  = error "Authoring QuasiQuotes are only for expression context" ,  +  quoteType = error "Authoring QuasiQuotes are only for expression context" ,  +  quoteDec  = error "Authoring QuasiQuotes are only for expression context"    }  data QQConfig = QQConfig @@ -72,12 +76,12 @@   cvtE :: QQConfig -> Component -> ExpQ-cvtE cfg (StrPart x)    = escaper cfg $ appE (varE 'pack) $ stringE x-cvtE cfg (EmbedShow x)  = escaper cfg $ appE (varE 'pack) $ appE (varE 'showJoin) (varE $ mkName $ trim x)+cvtE cfg (StrPart x)    = escaper cfg $ appE (varE 'T.pack) $ stringE x+cvtE cfg (EmbedShow x)  = escaper cfg $ appE (varE 'T.pack) $ appE (varE 'showJoin) (varE $ mkName $ trim x) cvtE _   (EmbedMonad x) = (varE $ mkName $ trim x)                             trim :: String -> String-trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse+trim = T.unpack . T.strip . T.pack  showJoin :: Show a => a -> String showJoin x = maybe sx id rsx@@ -117,3 +121,53 @@ parseEmbedShow :: Parser Component parseEmbedShow = EmbedShow <$> between (string "#{") (string "}") (some $ noneOf "}")           <?> "Embed an instance of Show #{...}"+++-- | Define a type and a 'Label' from the given name. We use Types to uniquely label concepts within a paper.+-- For example+--+-- > [declareLabels| myFormula |]+--+-- generates following three lines.+--+-- > data MyFormula = MyFormula deriving Typeable+-- > myFormula :: Label+-- > myFormula = fromValue MyFormula+--+-- You can declare multiple labels at one shot by separating them with a comma. +--+-- > [declareLabels| FluxConservation, FaradayLaw, GaussLaw, AmpereLaw |]++declareLabels = + QuasiQuoter { +  quoteExp  = error "defineLabel QuasiQuote is only for declaration context" ,  +  quotePat  = error "defineLabel QuasiQuote is only for declaration context" ,  +  quoteType = error "defineLabel QuasiQuote is only for declaration context" ,  +  quoteDec  = decLabelsQ+  }+ + +decLabelsQ :: String -> DecsQ +decLabelsQ str = fmap concat $ mapM decLabelQ names+  where+    names = +      map T.unpack $+      map T.strip $+      T.splitOn "," $ T.pack str+              +              +decLabelQ :: String -> DecsQ+decLabelQ theName = do+  let (hName:tName) = theName+      theTypeName = mkName (toUpper hName : tName)+      theConName  = mkName (toUpper hName : tName)+      theValName  = mkName (toLower hName : tName)  +  +  let  decTheType = dataD (cxt []) theTypeName [] [normalC theConName []] [''Eq, ''Show, ''Typeable]                 +       typeTheVal = sigD theValName (conT ''Label)+       decTheVal = funD theValName [clause [] (normalB theBody) []]+       theBody = appE (varE 'fromValue) (conE theConName)+  sequence [decTheType, typeTheVal, decTheVal]+  ++