HStringTemplate-0.8.5/0000755000000000000000000000000012661173233012770 5ustar0000000000000000HStringTemplate-0.8.5/Setup.lhs0000644000000000000000000000011412661173233014574 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain HStringTemplate-0.8.5/LICENSE0000644000000000000000000000267712661173233014011 0ustar0000000000000000Copyright (c) Stering Clover 2008 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. HStringTemplate-0.8.5/HStringTemplate.cabal0000644000000000000000000000232512661173233017030 0ustar0000000000000000name: HStringTemplate version: 0.8.5 synopsis: StringTemplate implementation in Haskell. description: A port of the Java library by Terrence Parr. category: Text license: BSD3 license-file: LICENSE author: Sterling Clover maintainer: s.clover@gmail.com Tested-With: GHC == 7.10.3 Build-Type: Simple Cabal-Version: >= 1.6 library build-depends: syb, base >= 4, base < 5, filepath, parsec < 4, containers, pretty >= 1.1.0.0, time >= 1.4.2 && < 1.7, bytestring, directory, array, text, deepseq, blaze-builder,void, template-haskell >= 2.3, mtl, old-locale exposed-modules: Text.StringTemplate Text.StringTemplate.Base Text.StringTemplate.Classes Text.StringTemplate.GenericStandard Text.StringTemplate.QQ other-modules: Text.StringTemplate.Instances Text.StringTemplate.Group Text.StringTemplate.Renderf ghc-options: -Wall source-repository head type: darcs location: http://hub.darcs.net/sterlingclover/hstringtemplate HStringTemplate-0.8.5/Text/0000755000000000000000000000000012661173233013714 5ustar0000000000000000HStringTemplate-0.8.5/Text/StringTemplate.hs0000644000000000000000000000521112661173233017211 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Text.StringTemplate -- Copyright : (c) Sterling Clover 2008 -- License : BSD 3 Clause -- Maintainer : s.clover@gmail.com -- Stability : experimental -- Portability : portable -- -- A StringTemplate is a String with \"holes\" in it. -- This is a port of the Java StringTemplate library written by Terrence Parr. -- (). User-contributed documentation available at -- . -- -- This library implements the basic 3.1 grammar, lacking group files -- (though not groups themselves), Regions, and Interfaces. -- The goal is not to blindly copy the StringTemplate API, but rather to -- take its central ideas and implement them in a Haskellish manner. -- Indentation and wrapping, for example, are implemented through the -- HughesPJ Pretty Printing library. Calling toPPDoc on a StringTemplate -- yields a Doc with appropriate paragraph-fill wrapping that can be -- rendered in the usual fashion. -- -- Basic instances are provided of the StringTemplateShows and ToSElem class. -- Any type deriving ToSElem can be passed automatically as a StringTemplate -- attribute. This package can be installed with syb-with-class bindings -- that provide a ToSElem instance for anything deriving -- 'Data.Generics.SYB.WithClass.Basics.Data'. When defining an instance of -- ToSElem that can take a format parameter, you should first define an -- instance of StringTemplateShows, and then define an instance of ToSElem -- where @ toSElem = stShowsToSE@. ----------------------------------------------------------------------------- module Text.StringTemplate ( -- * Types StringTemplate, STGroup, -- * Classes ToSElem(..), StringTemplateShows(..), stShowsToSE, Stringable(..), SEType(..), -- * Creation newSTMP, newAngleSTMP, getStringTemplate, getStringTemplate', -- * Display toString, toPPDoc, render, dumpAttribs, checkTemplate, checkTemplateDeep, -- * Modification setAttribute, (|=), setManyAttrib, setNativeAttribute, setManyNativeAttrib, withContext, optInsertTmpl, optInsertGroup, setEncoder, setEncoderGroup, -- * Groups groupStringTemplates, addSuperGroup, addSubGroup, mergeSTGroups, directoryGroup, directoryGroupExt, unsafeVolatileDirectoryGroup, directoryGroupRecursive, directoryGroupRecursiveLazy, directoryGroupRecursiveExt, directoryGroupRecursiveLazyExt, directoryGroupLazy, directoryGroupLazyExt, nullGroup ) where import Text.StringTemplate.Base import Text.StringTemplate.Group import Text.StringTemplate.Renderf import Text.StringTemplate.Instances() HStringTemplate-0.8.5/Text/StringTemplate/0000755000000000000000000000000012661173233016656 5ustar0000000000000000HStringTemplate-0.8.5/Text/StringTemplate/Renderf.hs0000644000000000000000000000107712661173233020604 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} module Text.StringTemplate.Renderf ((|=), SEType(..)) where import Text.StringTemplate.Base class Stringable b => SEType b a where renderf :: StringTemplate b -> a instance Stringable a => SEType a a where renderf = render instance Stringable a => SEType a (StringTemplate a) where renderf = id instance (ToSElem a, SEType b r) => SEType b ((String, a) -> r) where renderf x (k, v) = renderf $ setAttribute k v x (|=) :: (Monad m) => a -> m a1 -> m (a, a1) k |= v = return . (,) k =<< v infixl 5 |= HStringTemplate-0.8.5/Text/StringTemplate/QQ.hs0000644000000000000000000000323312661173233017534 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, QuasiQuotes #-} ----------------------------------------------------------------------------- -- | -- Module : Text.StringTemplate.QQ -- Copyright : (c) Sterling Clover 2009 -- License : BSD 3 Clause -- Maintainer : s.clover@gmail.com -- Stability : experimental -- Portability : portable -- -- This module provides stmp, a quasi-quoter for StringTemplate expressions. -- Quoted templates are guaranteed syntactically well-formed at compile time, -- and antiquotation (of identifiers only) is provided by backticks. -- Usage: @ let var = [0,1,2] in toString [$stmp|($\`var\`; separator = ', '$)|] === \"(0, 1, 2)\"@ ----------------------------------------------------------------------------- module Text.StringTemplate.QQ (stmp) where import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote import Text.StringTemplate.Base import qualified Data.Set as S quoteTmplExp :: String -> TH.ExpQ quoteTmplPat :: String -> TH.PatQ stmp :: QuasiQuoter stmp = QuasiQuoter {quoteExp = quoteTmplExp, quotePat = quoteTmplPat} quoteTmplPat = error "Cannot apply stmp quasiquoter in patterns" quoteTmplExp s = return tmpl where vars = case parseSTMPNames ('$','$') s of Right (xs,_,_) -> xs Left err -> fail $ show err base = TH.AppE (TH.VarE (TH.mkName "Text.StringTemplate.newSTMP")) (TH.LitE (TH.StringL s)) tmpl = S.foldr addAttrib base $ S.fromList vars addAttrib var = TH.AppE (TH.AppE (TH.AppE (TH.VarE (TH.mkName "Text.StringTemplate.setAttribute")) (TH.LitE (TH.StringL ('`' : var ++ "`")))) (TH.VarE (TH.mkName var))) HStringTemplate-0.8.5/Text/StringTemplate/Instances.hs0000644000000000000000000001311712661173233021144 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleInstances, OverlappingInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK not-home #-} module Text.StringTemplate.Instances() where import Text.StringTemplate.Classes import qualified Data.Map as M import Numeric import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Ratio import Data.Array import Data.Maybe import qualified Data.Foldable as F import Data.Time import Data.Void import qualified Data.Text as T import qualified Data.Text.Lazy as LT #if !MIN_VERSION_time(1,5,0) import System.Locale (defaultTimeLocale) #endif {-------------------------------------------------------------------- Additional instances for items that may be set as StringTemplate attributes. The code should provide examples of how to proceed. --------------------------------------------------------------------} --Basics instance ToSElem () where toSElem _ = STR "" instance ToSElem Void where toSElem = absurd instance ToSElem Char where toSElem = STR . (:[]) toSElemList = STR instance ToSElem LB.ByteString where toSElem = BS instance ToSElem B.ByteString where toSElem = BS . LB.fromChunks . (:[]) instance ToSElem LT.Text where toSElem = TXT instance ToSElem T.Text where toSElem = TXT . LT.fromStrict instance ToSElem Bool where toSElem True = STR "" toSElem _ = SNull instance (ToSElem a) => ToSElem (Maybe a) where toSElem (Just x) = toSElem x toSElem _ = SNull instance (ToSElem a) => ToSElem (M.Map String a) where toSElem = SM . fmap toSElem instance (ToSElem a) => ToSElem [a] where toSElem = toSElemList instance (ToSElem a, Ix i) => ToSElem (Array i a) where toSElem = toSElem . elems instance (ToSElem a, F.Foldable t) => ToSElem (t a) where toSElem = toSElemList . F.toList --Numbers instance StringTemplateShows Float where stringTemplateShow = flip showFloat "" stringTemplateFormattedShow = flip flip [] . showGFloat . fmap fst . listToMaybe . reads instance ToSElem Float where toSElem = stShowsToSE instance StringTemplateShows Double where stringTemplateShow = flip showFloat "" stringTemplateFormattedShow = flip flip [] . showGFloat . fmap fst . listToMaybe . reads instance ToSElem Double where toSElem = stShowsToSE instance ToSElem Int where toSElem = STR . show instance ToSElem Integer where toSElem = STR . show instance (Integral a, Show a) => ToSElem (Ratio a) where toSElem = STR . show --Dates and Times instance StringTemplateShows Day where stringTemplateShow = show stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem Day where toSElem = stShowsToSE instance StringTemplateShows LocalTime where stringTemplateShow = show stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem LocalTime where toSElem = stShowsToSE instance StringTemplateShows TimeOfDay where stringTemplateShow = show stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem TimeOfDay where toSElem = stShowsToSE instance StringTemplateShows UTCTime where stringTemplateShow = show stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem UTCTime where toSElem = stShowsToSE instance StringTemplateShows TimeZone where stringTemplateShow = show stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem TimeZone where toSElem = stShowsToSE instance StringTemplateShows ZonedTime where stringTemplateShow = show stringTemplateFormattedShow = formatTime defaultTimeLocale instance ToSElem ZonedTime where toSElem = stShowsToSE t2map :: [SElem a] -> SElem a t2map = SM . M.fromList . zip (map show [(0::Int)..]) instance (ToSElem a, ToSElem b) => ToSElem (a, b) where toSElem (a,b) = t2map [toSElem a, toSElem b] instance (ToSElem a, ToSElem b, ToSElem c) => ToSElem (a, b, c) where toSElem (a,b,c) = t2map [toSElem a, toSElem b, toSElem c] instance (ToSElem a, ToSElem b, ToSElem c, ToSElem d) => ToSElem (a, b, c, d) where toSElem (a,b,c,d) = t2map [toSElem a, toSElem b, toSElem c, toSElem d] instance (ToSElem a, ToSElem b, ToSElem c, ToSElem d, ToSElem e) => ToSElem (a, b, c, d, e) where toSElem (a,b,c,d,e) = t2map [toSElem a, toSElem b, toSElem c, toSElem d, toSElem e] instance (ToSElem a, ToSElem b, ToSElem c, ToSElem d, ToSElem e, ToSElem f) => ToSElem (a, b, c, d, e, f) where toSElem (a,b,c,d,e, f) = t2map [toSElem a, toSElem b, toSElem c, toSElem d, toSElem e, toSElem f] instance (ToSElem a, ToSElem b, ToSElem c, ToSElem d, ToSElem e, ToSElem f, ToSElem g) => ToSElem (a, b, c, d, e, f, g) where toSElem (a,b,c,d,e,f,g) = t2map [toSElem a, toSElem b, toSElem c, toSElem d, toSElem e, toSElem f, toSElem g] instance (ToSElem a, ToSElem b, ToSElem c, ToSElem d, ToSElem e, ToSElem f, ToSElem g, ToSElem h) => ToSElem (a, b, c, d, e, f, g, h) where toSElem (a,b,c,d,e,f,g,h) = t2map [toSElem a, toSElem b, toSElem c, toSElem d, toSElem e, toSElem f, toSElem g, toSElem h] instance (ToSElem a, ToSElem b, ToSElem c, ToSElem d, ToSElem e, ToSElem f, ToSElem g, ToSElem h, ToSElem i) => ToSElem (a, b, c, d, e, f, g, h, i) where toSElem (a,b,c,d,e,f,g,h,i) = t2map [toSElem a, toSElem b, toSElem c, toSElem d, toSElem e, toSElem f, toSElem g, toSElem h, toSElem i] instance (ToSElem a, ToSElem b, ToSElem c, ToSElem d, ToSElem e, ToSElem f, ToSElem g, ToSElem h, ToSElem i, ToSElem j) => ToSElem (a, b, c, d, e, f, g, h, i, j) where toSElem (a,b,c,d,e,f,g,h,i,j) = t2map [toSElem a, toSElem b, toSElem c, toSElem d, toSElem e, toSElem f, toSElem g, toSElem h, toSElem i, toSElem j] HStringTemplate-0.8.5/Text/StringTemplate/Group.hs0000644000000000000000000002152612661173233020314 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} module Text.StringTemplate.Group (groupStringTemplates, addSuperGroup, addSubGroup, setEncoderGroup, mergeSTGroups, directoryGroup, directoryGroupExt, optInsertGroup, directoryGroupLazy, directoryGroupLazyExt, directoryGroupRecursive, directoryGroupRecursiveExt, directoryGroupRecursiveLazy, directoryGroupRecursiveLazyExt, unsafeVolatileDirectoryGroup, nullGroup ) where import Control.Applicative import Control.Arrow import qualified Control.Exception as CE import Control.Monad import Data.Monoid import Data.List import System.FilePath import System.Directory import Data.IORef import System.IO import System.IO.Unsafe import System.IO.Error import qualified Data.Map as M import Data.Time import Text.StringTemplate.Base import Text.StringTemplate.Classes {-------------------------------------------------------------------- Utilities --------------------------------------------------------------------} (<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b) (<$$>) = (<$>) . (<$>) readFileUTF :: FilePath -> IO String readFileUTF f = do h <- openFile f ReadMode hSetEncoding h utf8 hGetContents h readFile' :: FilePath -> IO String readFile' f = do x <- readFileUTF f length x `seq` return x groupFromFiles :: Stringable a => (FilePath -> IO String) -> [(FilePath,String)] -> IO (STGroup a) groupFromFiles rf fs = groupStringTemplates <$> forM fs (\(f,fname) -> do stmp <- newSTMP <$> rf f return (fname, stmp)) getTmplsRecursive :: FilePath -> FilePath -> FilePath -> IO [(FilePath, FilePath)] getTmplsRecursive ext base fp = do dirContents <- filter (not . isPrefixOf ".") <$> getDirectoryContents fp subDirs <- filterM (doesDirectoryExist . (fp )) dirContents subs <- concat <$> mapM (\x -> getTmplsRecursive ext (base x) (fp x)) subDirs return $ (map ((fp ) &&& (\x -> base dropExtension x)) $ filter ((ext ==) . takeExtension) dirContents) ++ subs {-------------------------------------------------------------------- Group API --------------------------------------------------------------------} -- | Given a list of named of StringTemplates, returns a group which generates -- them such that they can call one another. groupStringTemplates :: [(String,StringTemplate a)] -> STGroup a groupStringTemplates xs = newGen where newGen s = StFirst (M.lookup s ng) ng = M.fromList $ map (second $ inSGen (`mappend` newGen)) xs -- | Given a path, returns a group which generates all files in said directory -- which have the proper \"st\" extension. -- This function is strict, with all files read once. As it performs file IO, -- expect it to throw the usual exceptions. directoryGroup :: (Stringable a) => FilePath -> IO (STGroup a) directoryGroup = directoryGroupExt ".st" -- | Given a path, returns a group which generates all files in said directory which have the supplied extension. directoryGroupExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a) directoryGroupExt ext path = groupFromFiles readFile' . map (() path &&& takeBaseName) . filter ((ext ==) . takeExtension) =<< getDirectoryContents path -- | Given a path, returns a group which generates all files in said directory -- which have the proper \"st\" extension. -- This function is lazy in the same way that readFile is lazy, with all -- files read on demand, but no more than once. The list of files, however, -- is generated at the time the function is called. As this performs file IO, -- expect it to throw the usual exceptions. And, as it is lazy, expect -- these exceptions in unexpected places. directoryGroupLazy :: (Stringable a) => FilePath -> IO (STGroup a) directoryGroupLazy = directoryGroupLazyExt ".st" -- | Given a path, returns a group which generates all files in said directory which have the supplied extension. directoryGroupLazyExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a) directoryGroupLazyExt ext path = groupFromFiles readFileUTF . map (() path &&& takeBaseName) . filter ((ext ==) . takeExtension) =<< getDirectoryContents path -- | As with 'directoryGroup', but traverses subdirectories as well. A template named -- \"foo\/bar.st\" may be referenced by \"foo\/bar\" in the returned group. directoryGroupRecursive :: (Stringable a) => FilePath -> IO (STGroup a) directoryGroupRecursive = directoryGroupRecursiveExt ".st" -- | As with 'directoryGroupRecursive', but a template extension is supplied. directoryGroupRecursiveExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a) directoryGroupRecursiveExt ext path = groupFromFiles readFile' =<< getTmplsRecursive ext "" path -- | See documentation for 'directoryGroupRecursive'. directoryGroupRecursiveLazy :: (Stringable a) => FilePath -> IO (STGroup a) directoryGroupRecursiveLazy = directoryGroupRecursiveLazyExt ".st" -- | As with 'directoryGroupRecursiveLazy', but a template extension is supplied. directoryGroupRecursiveLazyExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a) directoryGroupRecursiveLazyExt ext path = groupFromFiles readFileUTF =<< getTmplsRecursive ext "" path -- | Adds a supergroup to any StringTemplate group such that templates from -- the original group are now able to call ones from the supergroup as well. addSuperGroup :: STGroup a -> STGroup a -> STGroup a addSuperGroup f g = inSGen (`mappend` g) <$$> f -- | Adds a \"subgroup\" to any StringTemplate group such that templates from -- the original group now have template calls \"shadowed\" by the subgroup. addSubGroup :: STGroup a -> STGroup a -> STGroup a addSubGroup f g = inSGen (g `mappend`) <$$> f -- | Merges two groups into a single group. This function is left-biased, -- prefering bindings from the first group when there is a conflict. mergeSTGroups :: STGroup a -> STGroup a -> STGroup a mergeSTGroups f g = addSuperGroup f g `mappend` addSubGroup g f -- | Adds a set of global options to a group optInsertGroup :: [(String, String)] -> STGroup a -> STGroup a optInsertGroup opts f = (inSGen (optInsertGroup opts) . optInsertTmpl opts) <$$> f -- | Sets an encoding function of a group that all values are -- rendered with in each enclosed template setEncoderGroup :: (Stringable a) => (a -> a) -> STGroup a -> STGroup a setEncoderGroup x f = (inSGen (setEncoderGroup x) . setEncoder x) <$$> f -- | For any requested template, returns a message that the template was -- unable to be found. Useful to add as a super group for a set of templates -- under development, to aid in debugging. nullGroup :: Stringable a => STGroup a nullGroup x = StFirst . Just . newSTMP $ "Could not find template: " ++ x -- | Given an integral amount of seconds and a path, returns a group generating -- all files in said directory and subdirectories with the proper \"st\" extension, -- cached for that amount of seconds. IO errors are \"swallowed\" by this so -- that exceptions don't arise in unexpected places. -- This violates referential transparency, but can be very useful in developing -- templates for any sort of server application. It should be swapped out for -- production purposes. The dumpAttribs template is added to the returned group -- by default, as it should prove useful for debugging and developing templates. unsafeVolatileDirectoryGroup :: Stringable a => FilePath -> Int -> IO (STGroup a) unsafeVolatileDirectoryGroup path m = return . flip addSubGroup extraTmpls $ cacheSTGroup stfg where stfg = StFirst . Just . newSTMP . unsafePerformIO . flip CE.catch (return . (\e -> "IO Error: " ++ show (ioeGetFileName e) ++ " -- " ++ ioeGetErrorString e)) . readFileUTF . (path ) . (++".st") extraTmpls = addSubGroup (groupStringTemplates [("dumpAttribs", dumpAttribs)]) nullGroup delayTime :: Double delayTime = fromIntegral m cacheSTGroup :: STGroup a -> STGroup a cacheSTGroup g = unsafePerformIO $ do !ior <- newIORef M.empty return $ \s -> unsafePerformIO $ do mp <- readIORef ior curtime <- getCurrentTime let udReturn now = do let st = g s atomicModifyIORef ior $ flip (,) () . M.insert s (now, st) return st case M.lookup s mp of Nothing -> udReturn curtime Just (t, st) -> if (realToFrac $ diffUTCTime curtime t) > delayTime then udReturn curtime else return st HStringTemplate-0.8.5/Text/StringTemplate/GenericStandard.hs0000644000000000000000000000464112661173233022254 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances, Rank2Types, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -------------------------------------------------------------------- -- | Generic Instance for ToSElem using standard Data.Generic libraries. --------------------------------------------------------------------} module Text.StringTemplate.GenericStandard() where import qualified Data.Map as M import Text.StringTemplate.Classes import Text.StringTemplate.Instances() import Data.Generics.Basics import Data.Generics.Aliases import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB -- import qualified System.Time as OldTime -- import System.Locale -- import Data.Time import qualified Data.Text as T import qualified Data.Text.Lazy as LT gToSElem :: forall a b.(Data a, Stringable b) => a -> SElem b gToSElem = (\x -> case (map stripInitUnder (constrFields . toConstr $ x)) of [] -> LI (STR (showConstr (toConstr x)) : gmapQ gToSElem x) fs -> SM (M.fromList (zip fs (gmapQ gToSElem x))) ) `ext1Q` (\t -> case t of (Just x) -> gToSElem x; _ -> SNull) `ext1Q` (SM . fmap gToSElem) `ext1Q` (LI . map gToSElem) -- `extQ` (toSElem :: OldTime.CalendarTime -> SElem b) -- `extQ` (toSElem :: OldTime.TimeDiff -> SElem b) -- `extQ` (toSElem :: TimeOfDay -> SElem b) -- `extQ` (toSElem :: UTCTime -> SElem b) -- `extQ` (toSElem :: TimeZone -> SElem b) -- `extQ` (toSElem :: ZonedTime -> SElem b) -- `extQ` (toSElem :: Day -> SElem b) -- `extQ` (toSElem :: LocalTime -> SElem b) `extQ` (toSElem :: Char -> SElem b) `extQ` (toSElem :: LB.ByteString -> SElem b) `extQ` (toSElem :: B.ByteString -> SElem b) `extQ` (toSElem :: LT.Text -> SElem b) `extQ` (toSElem :: T.Text -> SElem b) `extQ` (toSElem :: Bool -> SElem b) `extQ` (toSElem :: Float -> SElem b) `extQ` (toSElem :: Double -> SElem b) `extQ` (toSElem :: Int -> SElem b) `extQ` (toSElem :: Integer -> SElem b) `extQ` (toSElem :: String -> SElem b) instance Data a => ToSElem a where toSElem = gToSElem stripInitUnder :: String -> String stripInitUnder ('_':s) = stripInitUnder s stripInitUnder s = s HStringTemplate-0.8.5/Text/StringTemplate/Classes.hs0000644000000000000000000001153012661173233020607 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, FlexibleInstances, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeSynonymInstances #-} {-# OPTIONS_HADDOCK not-home #-} module Text.StringTemplate.Classes (SElem(..), StringTemplateShows(..), ToSElem(..), SMap, STShow(..), StFirst(..), Stringable(..), stShowsToSE ) where import qualified Data.Map as M import Data.List import Data.Monoid import qualified Blaze.ByteString.Builder as BB import qualified Blaze.ByteString.Builder.Char.Utf8 as BB import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB --import qualified Data.ByteString.Lazy.Builder as DBB import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Encoding as LT import qualified Text.PrettyPrint.HughesPJ as PP newtype StFirst a = StFirst { stGetFirst :: Maybe a } deriving (Eq, Ord, Read, Show) instance Monoid (StFirst a) where mempty = StFirst Nothing r@(StFirst (Just _)) `mappend` _ = r StFirst Nothing `mappend` r = r instance Functor StFirst where fmap f = StFirst . fmap f . stGetFirst type SMap a = M.Map String (SElem a) data SElem a = STR String | BS LB.ByteString | TXT LT.Text | STSH STShow | SM (SMap a) | LI [SElem a] | SBLE a | SNAT a | SNull -- | The ToSElem class should be instantiated for all types that can be -- inserted as attributes into a StringTemplate. class ToSElem a where toSElem :: Stringable b => a -> SElem b toSElemList :: Stringable b => [a] -> SElem b toSElemList = LI . map toSElem -- | The StringTemplateShows class should be instantiated for all types that are -- directly displayed in a StringTemplate, but take an optional format string. Each such type must have an appropriate ToSElem method defined as well. class (Show a) => StringTemplateShows a where -- | Defaults to 'show'. stringTemplateShow :: a -> String stringTemplateShow = show -- | Defaults to @ \ _ a -> stringTemplateShow a @ stringTemplateFormattedShow :: String -> a -> String stringTemplateFormattedShow = flip $ const . stringTemplateShow -- | This method should be used to create ToSElem instances for -- types defining a custom formatted show function. stShowsToSE :: (StringTemplateShows a, Stringable b) => a -> SElem b stShowsToSE = STSH . STShow data STShow = forall a.(StringTemplateShows a) => STShow a -- | The Stringable class should be instantiated with care. -- Generally, the provided instances should be enough for anything. class Monoid a => Stringable a where stFromString :: String -> a stFromByteString :: LB.ByteString -> a stFromByteString = stFromText . LT.decodeUtf8 stFromText :: LT.Text -> a stFromText = stFromString . LT.unpack stToString :: a -> String -- | Defaults to @ mconcatMap m k = foldr (mappend . k) mempty m @ mconcatMap :: [b] -> (b -> a) -> a mconcatMap m k = foldr (mappend . k) mempty m -- | Defaults to @ (mconcat .) . intersperse @ mintercalate :: a -> [a] -> a mintercalate = (mconcat .) . intersperse -- | Defaults to @ mlabel x y = mconcat [x, stFromString "[", y, stFromString "]"] @ mlabel :: a -> a -> a mlabel x y = mconcat [x, stFromString "[", y, stFromString "]"] instance Stringable String where stFromString = id stToString = id instance Stringable PP.Doc where stFromString = PP.text stToString = PP.render mconcatMap m k = PP.fcat . map k $ m mintercalate = (PP.fcat .) . PP.punctuate mlabel x y = x PP.$$ PP.nest 1 y instance Stringable B.ByteString where stFromString = B.pack stFromByteString = B.concat . LB.toChunks stToString = B.unpack instance Stringable LB.ByteString where stFromString = LB.pack stFromByteString = id stToString = LB.unpack instance Stringable T.Text where stFromString = T.pack stFromByteString = T.decodeUtf8 . B.concat . LB.toChunks stFromText = LT.toStrict stToString = T.unpack instance Stringable LT.Text where stFromString = LT.pack stFromByteString = LT.decodeUtf8 stFromText = id stToString = LT.unpack instance Stringable BB.Builder where stFromString = BB.fromString stFromByteString = BB.fromLazyByteString stToString = LB.unpack . BB.toLazyByteString {- instance Stringable LBB.Builder where stFromString = stringUtf8 stFromByteString = LBB.lazyByteString stToString = LB.unpack . LBB.toLazyByteString -} instance Stringable TB.Builder where stFromString = TB.fromString stFromText = TB.fromLazyText stToString = LT.unpack . TB.toLazyText --add dlist instance instance Stringable (Endo String) where stFromString = Endo . (++) stToString = ($ []) . appEndo HStringTemplate-0.8.5/Text/StringTemplate/Base.hs0000644000000000000000000006317212661173233020075 0ustar0000000000000000{-# LANGUAGE RelaxedPolyRec, DeriveDataTypeable #-} {-# OPTIONS_HADDOCK not-home #-} module Text.StringTemplate.Base (StringTemplate(..), StringTemplateShows(..), ToSElem(..), STGroup, Stringable(..), stShowsToSE, inSGen, toString, toPPDoc, render, newSTMP, newAngleSTMP, getStringTemplate, getStringTemplate', setAttribute, setManyAttrib, setNativeAttribute, setManyNativeAttrib, withContext, optInsertTmpl, setEncoder, paddedTrans, SEnv(..), parseSTMP, dumpAttribs, checkTemplate, checkTemplateDeep, parseSTMPNames ) where import Control.Arrow import Control.Applicative hiding ((<|>),many,optional) import Control.Monad import Control.DeepSeq import qualified Control.Exception as C import Data.List import Data.Maybe import Data.Monoid import Data.Typeable import System.IO.Unsafe import Text.ParserCombinators.Parsec import qualified Data.Map as M import qualified Text.PrettyPrint.HughesPJ as PP import Text.StringTemplate.Classes import Text.StringTemplate.Instances() {-------------------------------------------------------------------- Generic Utilities --------------------------------------------------------------------} type TmplParser = GenParser Char ((Char, Char),[String],[String],[String]) (<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b) (<$$>) = (<$>) . (<$>) infixr 8 <$$> (|.) :: (t1 -> t2) -> (t -> t1) -> t -> t2 (|.) f g = f . g infixr 3 |. (.>>) :: (Monad m) => m a -> m b -> m b (.>>) f g = f >> g infixr 5 .>> fromMany :: b -> ([a] -> b) -> [a] -> b fromMany e _ [] = e fromMany _ f xs = f xs swing :: (((a -> c1) -> c1) -> b -> c) -> b -> a -> c swing = flip . (. flip id) paddedTrans :: a -> [[a]] -> [[a]] paddedTrans _ [] = [] paddedTrans n as = take (maximum . map length $ as) . trans $ as where trans ([] : xss) = (n : map h xss) : trans ([n] : map t xss) trans ((x : xs) : xss) = (x : map h xss) : trans (m xs : map t xss) trans _ = []; h (x:_) = x; h _ = n; t (_:y:xs) = y:xs; t _ = [n]; m (x:xs) = x:xs; m _ = [n]; {-------------------------------------------------------------------- StringTemplate and the API --------------------------------------------------------------------} -- | A function that generates StringTemplates. -- This is conceptually a query function into a \"group\" of StringTemplates. type STGroup a = String -> (StFirst (StringTemplate a)) -- | A String with \"holes\" in it. StringTemplates may be composed of any -- 'Stringable' type, which at the moment includes 'String's, 'ByteString's, -- PrettyPrinter 'Doc's, and 'Endo' 'String's, which are actually of type -- 'ShowS'. When a StringTemplate is composed of a type, its internals are -- as well, so it is, so to speak \"turtles all the way down.\" data StringTemplate a = STMP {senv :: SEnv a, runSTMP :: Either String (SEnv a -> a), chkSTMP :: SEnv a -> (Maybe String, Maybe [String], Maybe [String])} -- | Renders a StringTemplate to a String. toString :: StringTemplate String -> String toString = render -- | Renders a StringTemplate to a 'Text.PrettyPrint.HughesPJ.Doc'. toPPDoc :: StringTemplate PP.Doc -> PP.Doc toPPDoc = render -- | Generic render function for a StringTemplate of any type. render :: Stringable a => StringTemplate a -> a render = either (showStr) id . runSTMP <*> senv nullEnv :: SEnv a nullEnv = SEnv M.empty [] mempty id -- | Returns a tuple of three Maybes. The first is set if there is a parse error in the template. -- The next is set to a list of attributes that have not been set, or Nothing if all attributes are set. -- The last is set to a list of invoked templates that cannot be looked up, or Nothing if all invoked templates can be found. -- Note that this check is shallow -- i.e. missing attributes and templates are only caught in the top level template, not any invoked subtemplate. checkTemplate :: Stringable a => StringTemplate a -> (Maybe String, Maybe [String], Maybe [String]) checkTemplate t = chkSTMP t (senv t) -- | Parses a String to produce a StringTemplate, with \'$\'s as delimiters. -- It is constructed with a stub group that cannot look up other templates. newSTMP :: Stringable a => String -> StringTemplate a newSTMP s = STMP nullEnv (parseSTMP ('$','$') s) (chkStmp ('$','$') s) -- | Parses a String to produce a StringTemplate, delimited by angle brackets. -- It is constructed with a stub group that cannot look up other templates. newAngleSTMP :: Stringable a => String -> StringTemplate a newAngleSTMP s = STMP nullEnv (parseSTMP ('<','>') s) (chkStmp ('<','>') s) -- | Yields a StringTemplate with the appropriate attribute set. -- If the attribute already exists, it is appended to a list. setAttribute :: (ToSElem a, Stringable b) => String -> a -> StringTemplate b -> StringTemplate b setAttribute s x st = st {senv = envInsApp s (toSElem x) (senv st)} -- | Yields a StringTemplate with the appropriate attributes set. -- If any attribute already exists, it is appended to a list. setManyAttrib :: (ToSElem a, Stringable b) => [(String, a)] -> StringTemplate b -> StringTemplate b setManyAttrib = flip . foldl' . flip $ uncurry setAttribute -- | Yields a StringTemplate with the appropriate attribute set. -- If the attribute already exists, it is appended to a list. -- This will not translate the attribute through any intermediate -- representation, so is more efficient when, e.g. setting -- attributes that are large bytestrings in a bytestring template. setNativeAttribute :: Stringable b => String -> b -> StringTemplate b -> StringTemplate b setNativeAttribute s x st = st {senv = envInsApp s (SNAT x) (senv st)} -- | Yields a StringTemplate with the appropriate attributes set. -- If any attribute already exists, it is appended to a list. -- Attributes are added natively, which may provide -- efficiency gains. setManyNativeAttrib :: (Stringable b) => [(String, b)] -> StringTemplate b -> StringTemplate b setManyNativeAttrib = flip . foldl' . flip $ uncurry setNativeAttribute -- | Replaces the attributes of a StringTemplate with those -- described in the second argument. If the argument does not yield -- a set of named attributes but only a single one, that attribute -- is named, as a default, \"it\". withContext :: (ToSElem a, Stringable b) => StringTemplate b -> a -> StringTemplate b withContext st x = case toSElem x of SM a -> st {senv = (senv st) {smp = a}} b -> st {senv = (senv st) {smp = M.singleton "it" b}} -- | Queries an String Template Group and returns Just the appropriate -- StringTemplate if it exists, otherwise, Nothing. getStringTemplate :: (Stringable a) => String -> STGroup a -> Maybe (StringTemplate a) getStringTemplate s sg = stGetFirst (sg s) -- | As with 'getStringTemplate' but never inlined, so appropriate for use -- with volatile template groups. {-# NOINLINE getStringTemplate' #-} getStringTemplate' :: (Stringable a) => String -> STGroup a -> Maybe (StringTemplate a) getStringTemplate' s sg = stGetFirst (sg s) -- | Adds a set of global options to a single template optInsertTmpl :: [(String, String)] -> StringTemplate a -> StringTemplate a optInsertTmpl x st = st {senv = optInsert (map (second justSTR) x) (senv st)} -- | Sets an encoding function of a template that all values are -- rendered with. For example one useful encoder would be 'Text.Html.stringToHtmlString'. All attributes will be encoded once and only once. setEncoder :: (Stringable a) => (a -> a) -> StringTemplate a -> StringTemplate a setEncoder x st = st {senv = (senv st) {senc = x} } -- | A special template that simply dumps the values of all the attributes set in it. -- This may be made available to any template as a function by adding it to its group. -- I.e. @ myNewGroup = addSuperGroup myGroup $ groupStringTemplates [("dumpAttribs", dumpAttribs)] @ dumpAttribs :: Stringable a => StringTemplate a dumpAttribs = STMP nullEnv (Right $ \env -> showVal env (SM $ smp env)) (const (Nothing, Nothing, Nothing)) {-------------------------------------------------------------------- Internal API --------------------------------------------------------------------} --IMPLEMENT groups having stLookup return a Maybe for regions data SEnv a = SEnv {smp :: SMap a, sopts :: [(String, (SEnv a -> SElem a))], sgen :: STGroup a, senc :: a -> a} inSGen :: (STGroup a -> STGroup a) -> StringTemplate a -> StringTemplate a inSGen f st@STMP{senv = env} = st {senv = env {sgen = f (sgen env)} } {- envLookup :: String -> SEnv a -> Maybe (SElem a) envLookup x = M.lookup x . smp -} envLookupEx :: String -> SEnv a -> SElem a envLookupEx x snv = case M.lookup x (smp snv) of Just a -> a Nothing -> case optLookup "throwException" snv of Just _ -> C.throw $ NoAttrib x Nothing -> SNull envInsert :: (String, SElem a) -> SEnv a -> SEnv a envInsert (s, x) y = y {smp = M.insert s x (smp y)} envInsApp :: Stringable a => String -> SElem a -> SEnv a -> SEnv a envInsApp s x y = y {smp = M.insertWith go s x (smp y)} where go a (LI bs) = LI (a:bs) go a b = LI [a,b] optLookup :: String -> SEnv a -> Maybe (SEnv a -> SElem a) optLookup x = lookup x . sopts optInsert :: [(String, SEnv a -> SElem a)] -> SEnv a -> SEnv a optInsert x env = env {sopts = x ++ sopts env} nullOpt :: SEnv a -> SElem a nullOpt = fromMaybe (justSTR "") =<< optLookup "null" stLookup :: (Stringable a) => String -> SEnv a -> StringTemplate a stLookup x env = maybe (newSTMP ("No Template Found for: " ++ x)) (\st-> st {senv = mergeSEnvs env (senv st)}) $ stGetFirst (sgen env x) --merges values of former into latter, preserving encoder --of latter, as well as non-overriden options. group of latter is overridden. mergeSEnvs :: SEnv a -> SEnv a -> SEnv a mergeSEnvs x y = SEnv {smp = M.union (smp x) (smp y), sopts = (sopts y ++ sopts x), sgen = sgen x, senc = senc y} parseSTMP :: (Stringable a) => (Char, Char) -> String -> Either String (SEnv a -> a) parseSTMP x = either (Left . show) Right . runParser (stmpl False) (x,[],[],[]) "" . dropTrailingBr dropTrailingBr :: String -> String dropTrailingBr ('\r':'\n':[]) = [] dropTrailingBr ('\n':[]) = [] dropTrailingBr [] = [] dropTrailingBr (x:xs) = x : dropTrailingBr xs getSeps :: TmplParser (Char, Char) getSeps = (\(x,_,_,_) -> x) <$> getState tellName :: String -> TmplParser () tellName x = getState >>= \(s,q,n,t) -> setState (s,q,x:n,t) tellQQ :: String -> TmplParser () tellQQ x = getState >>= \(s,q,n,t) -> setState (s,x:q,n,t) tellTmpl :: String -> TmplParser () tellTmpl x = getState >>= \(s,q,n,t) -> setState (s,q,n,x:t) -- | Gets all quasiquoted names, normal names & templates used in a given template. -- Must be passed a pair of chars denoting the delimeters to be used. parseSTMPNames :: (Char, Char) -> String -> Either ParseError ([String],[String],[String]) parseSTMPNames cs s = runParser getRefs (cs,[],[],[]) "" s where getRefs = do _ <- stmpl False :: TmplParser (SEnv String -> String) (_,qqnames,regnames,tmpls) <- getState return (qqnames, regnames, tmpls) chkStmp :: Stringable a => (Char, Char) -> String -> SEnv a -> (Maybe String, Maybe [String], Maybe [String]) chkStmp cs s snv = case parseSTMPNames cs s of Left err -> (Just $ "Parse error: " ++ show err, Nothing, Nothing) Right (_, regnames, tmpls) -> let nonms = filter (\x -> not $ elem x (M.keys $ smp snv)) regnames notmpls = filter (\x -> isNothing $ stGetFirst (sgen snv x)) tmpls in (Nothing, if null nonms then Nothing else Just nonms, if null notmpls then Nothing else Just notmpls) data TmplException = NoAttrib String | NoTmpl String | ParseError String String deriving (Show, Typeable) instance C.Exception TmplException -- | Generic render function for a StringTemplate of any type. renderErr :: Stringable a => String -> StringTemplate a -> a renderErr n t = case runSTMP t of Right rt -> rt (senv t) Left err -> case optLookup "throwException" (senv t) of Just _ -> C.throw $ ParseError n err Nothing -> showStr err (senv t) -- | Returns a tuple of three lists. The first is of templates with parse errors, and their errors. The next is of missing attributes, and the last is of missing templates. If there are no errors, then all lists will be empty. This check is performed recursively. checkTemplateDeep :: (Stringable a, NFData a) => StringTemplate a -> ([(String,String)], [String], [String]) checkTemplateDeep t = case runSTMP t of Left err -> ([("Top Level Template", err)], [],[]) Right _ -> unsafePerformIO $ go ([],[],[]) $ inSGen (`mappend` nullGroup) $ optInsertTmpl [("throwException","true")] t where go (e1,e2,e3) tmpl = (C.evaluate (rnf $ render tmpl) >> return (e1,e2,e3)) `C.catch` \e -> case e of NoTmpl x -> go (e1,e2,x:e3) $ addSub x tmpl NoAttrib x -> go (e1,x:e2, e3) $ setAttribute x "" tmpl ParseError n x -> go ((n,x):e1,e2,e3) $ addSub n tmpl addSub x tmpl = inSGen (mappend $ blankGroup x) tmpl blankGroup x s = StFirst $ if x == s then Just (newSTMP "") else Nothing nullGroup x = StFirst $ Just (C.throw $ NoTmpl x) {-------------------------------------------------------------------- Internal API for polymorphic display of elements --------------------------------------------------------------------} mconcatMap' :: Stringable a => SEnv a -> [b] -> (b -> a) -> a mconcatMap' snv xs f = mintercalate sep . map f $ xs where sep = showVal snv $ fromMaybe (justSTR "") =<< optLookup "separator" $ snv showVal :: Stringable a => SEnv a -> SElem a -> a showVal snv se = case se of STR x -> stEncode x BS x -> stEncodeBS x TXT x -> stEncodeText x LI xs -> joinUpWith showVal xs SM sm -> joinUpWith showAssoc $ M.assocs sm STSH x -> stEncode (format x) SNAT x -> senc snv x SBLE x -> x SNull -> showVal <*> nullOpt $ snv where format = maybe stshow . stfshow <*> optLookup "format" $ snv joinUpWith f xs = mconcatMap' snv xs (f snv) showAssoc e (k,v) = stEncode (k ++ ": ") `mlabel` showVal e v stEncode = senc snv . stFromString stEncodeBS = senc snv . stFromByteString stEncodeText = senc snv . stFromText showStr :: Stringable a => String -> SEnv a -> a showStr = const . stFromString {-------------------------------------------------------------------- Utility Combinators --------------------------------------------------------------------} justSTR :: String -> b -> SElem a justSTR = const . STR stshow :: STShow -> String stshow (STShow a) = stringTemplateShow a stfshow :: Stringable a => SEnv a -> (SEnv a -> SElem a) -> STShow -> String stfshow snv fs (STShow a) = stringTemplateFormattedShow (stToString <$$> showVal <*> fs $ snv) a around :: Char -> GenParser Char st t -> Char -> GenParser Char st t around x p y = do {_ <- char x; v<-p; _ <- char y; return v} spaced :: GenParser Char st t -> GenParser Char st t spaced p = do {spaces; v<-p; spaces; return v} identifierChar :: GenParser Char st Char identifierChar = alphaNum <|> char '_' word :: GenParser Char st String word = many1 identifierChar comlist :: GenParser Char st a -> GenParser Char st [a] comlist p = spaced (p `sepBy1` spaced (char ',')) props :: Stringable a => TmplParser [SEnv a -> SElem a] props = many $ char '.' >> (around '(' subexprn ')' <|> justSTR <$> word) escapedChar, escapedStr :: String -> GenParser Char st String escapedChar chs = noneOf chs >>= \x -> if x == '\\' then anyChar >>= \y -> return [y] else return [x] escapedStr chs = concat <$> many1 (escapedChar chs) {- escapedStr' chs = dropTrailingBr <$> escapedStr chs -} {-------------------------------------------------------------------- The Grammar --------------------------------------------------------------------} myConcat :: Stringable a => [SEnv a -> a] -> (SEnv a -> a) myConcat xs a = mconcatMap xs ($ a) -- | if p is true, stmpl can fail gracefully, false it dies hard. -- Set to false at the top level, and true within if expressions. stmpl :: Stringable a => Bool -> TmplParser (SEnv a -> a) stmpl p = do (ca, cb) <- getSeps myConcat <$> many (showStr <$> escapedStr [ca] <|> try (around ca optExpr cb) <|> try comment <|> bl "template") where bl | p = try blank | otherwise = blank subStmp :: Stringable a => TmplParser (([SElem a], [SElem a]) -> SEnv a -> a) subStmp = do (ca, cb) <- getSeps udEnv <- option (transform ["it"]) (transform <$> try attribNames) st <- myConcat <$> many (showStr <$> escapedStr (ca:"}|") <|> try (around ca optExpr cb) <|> try comment <|> blank "subtemplate") return (st <$$> udEnv) where transform an (att,is) = flip (foldr envInsert) $ zip ("i":"i0":an) (is++att) attribNames = (char '|' >>) . return =<< comlist (spaced word) comment :: Stringable a => TmplParser (SEnv a -> a) comment = do (ca, cb) <- getSeps _ <- string [ca,'!'] >> manyTill anyChar (try . string $ ['!',cb]) return (showStr "") blank :: Stringable a => TmplParser (SEnv a -> a) blank = do (ca, cb) <- getSeps _ <- char ca spaces _ <- char cb return (showStr "") optExpr :: Stringable a => TmplParser (SEnv a -> a) optExpr = do (_, cb) <- getSeps (try (string ("else"++[cb])) <|> try (string "elseif(") <|> try (string "endif")) .>> fail "Malformed If Statement." <|> return () expr <- try ifstat <|> spaced exprn opts <- (char ';' >> optList) <|> return [] return $ expr . optInsert opts where -- opt = around ';' (spaced word) '=' >>= (<$> spaced subexprn) . (,) optList = sepBy oneOpt (char ',' <|> char ';') oneOpt = do o <- spaced word _ <- char '=' v <- spaced subexprn return (o,v) {-------------------------------------------------------------------- Statements --------------------------------------------------------------------} optLine :: TmplParser () optLine = optional (char '\r') >> optional (char '\n') --if env then do stuff getProp :: Stringable a => [SEnv a -> SElem a] -> SElem a -> SEnv a -> SElem a getProp (p:ps) (SM mp) env = case M.lookup (stToString . showVal env $ p env) mp of Just prop -> getProp ps prop env Nothing -> case optLookup "throwException" env of Just _ -> C.throw . NoAttrib $ "yeek" --intercalate "." . map showIt $ (p:ps) Nothing -> SNull --where showIt x = stToString . showVal env $ x env getProp (_:_) _ _ = SNull getProp _ se _ = se ifIsSet :: t -> t -> Bool -> SElem a -> t ifIsSet t e n SNull = if n then e else t ifIsSet t e n _ = if n then t else e ifstat ::Stringable a => TmplParser (SEnv a -> a) ifstat = do (_, cb) <- getSeps _ <- string "if(" n <- option True (char '!' >> return False) e <- subexprn p <- props char ')' >> char cb >> optLine act <- stmpl True cont <- (try elseifstat <|> try elsestat <|> endifstat) return (ifIsSet act cont n =<< getProp p =<< e) elseifstat ::Stringable a => TmplParser (SEnv a -> a) elseifstat = getSeps >>= char . fst >> string "else" >> ifstat elsestat ::Stringable a => TmplParser (SEnv a -> a) elsestat = do (ca, cb) <- getSeps _ <- around ca (string "else") cb optLine act <- stmpl True _ <- char ca >> string "endif" return act endifstat ::Stringable a => TmplParser (SEnv a -> a) endifstat = getSeps >>= char . fst >> string "endif" >> return (showStr "") {-------------------------------------------------------------------- Expressions --------------------------------------------------------------------} exprn :: Stringable a => TmplParser (SEnv a -> a) exprn = do exprs <- comlist ( (SBLE <$$> around '(' exprn ')') <|> subexprn) "expression" templ <- tmplChain return $ fromMany (showVal <*> head exprs) ((sequence exprs >>=) . seqTmpls') templ where tmplChain = many (char ':' >> iterApp <$> comlist (anonTmpl <|> regTemplate)) "template call" seqTmpls' :: Stringable a => [[SElem a] -> SEnv a -> [a]] -> [SElem a] -> SEnv a -> a seqTmpls' tmpls elems snv = mintercalate sep $ seqTmpls tmpls elems snv where sep = showVal snv $ fromMaybe (justSTR "") =<< optLookup "separator" $ snv seqTmpls :: Stringable a => [[SElem a] -> SEnv a -> [a]] -> [SElem a] -> SEnv a -> [a] seqTmpls [f] y snv = f y snv seqTmpls (f:fs) y snv = concatMap (\x -> seqTmpls fs x snv) (map ((:[]) . SBLE) $ f y snv) seqTmpls _ _ _ = [stFromString ""] subexprn :: Stringable a => TmplParser (SEnv a -> SElem a) subexprn = cct <$> spaced (braceConcat <|> SBLE <$$> ($ ([SNull],ix0)) <$> try regTemplate <|> attrib <|> SBLE <$$> ($ ([SNull],ix0)) <$> anonTmpl "expression") `sepBy1` spaced (char '+') where cct xs@(_:_:_) = SBLE |. flip mconcatMap <$> showVal <*> sequence xs cct [x] = x cct _ = const SNull braceConcat :: Stringable a => TmplParser (SEnv a -> SElem a) braceConcat = LI . foldr go [] <$$> sequence <$> around '['(comlist subexprn)']' where go (LI x) lst = x++lst; go x lst = x:lst literal :: GenParser Char st (b -> SElem a) literal = justSTR <$> (around '"' (concat <$> many (escapedChar "\"")) '"' <|> around '\'' (concat <$> many (escapedChar "'")) '\'') attrib :: Stringable a => TmplParser (SEnv a -> SElem a) attrib = do a <- literal <|> try functn <|> envLookupEx <$> regWord <|> envLookupEx <$> qqWord <|> around '(' subexprn ')' "attribute" proprs <- props return $ fromMany a ((a >>=) . getProp) proprs where qqWord = do w <- around '`' word '`' tellQQ w return $ '`' : w ++ "`" regWord = do w <- word tellName w return w --add null func functn :: Stringable a => TmplParser (SEnv a -> SElem a) functn = do f <- string "first" <|> try (string "rest") <|> string "reverse" <|> string "strip" <|> try (string "length") <|> string "last" "function" (fApply f .) <$> around '(' subexprn ')' where fApply str (LI xs) | str == "first" = if null xs then SNull else head xs | str == "last" = if null xs then SNull else last xs | str == "rest" = if null xs then SNull else (LI . tail) xs | str == "reverse" = LI . reverse $ xs | str == "strip" = LI . filter (not . liNil) $ xs | str == "length" = STR . show . length $ xs fApply str x | str == "rest" = LI [] | str == "length" = STR "1" | otherwise = x liNil (LI x) = null x liNil _ = False {-------------------------------------------------------------------- Templates --------------------------------------------------------------------} --change makeTmpl to do notation for clarity? mkIndex :: (Num b, Show b) => [b] -> [[SElem a]] mkIndex = map ((:) . STR . show . (1+) <*> (:[]) . STR . show) ix0 :: [SElem a] ix0 = [STR "1",STR "0"] cycleApp :: (Stringable a) => [([SElem a], [SElem a]) -> SEnv a -> a] -> [([SElem a], [SElem a])] -> SEnv a -> [a] cycleApp x y snv = map ($ snv) (zipWith ($) (cycle x) y) pluslen :: [a] -> [([a], [SElem b])] pluslen xs = zip (map (:[]) xs) $ mkIndex [0..(length xs)] liTrans :: [SElem a] -> [([SElem a], [SElem a])] liTrans = pluslen' . paddedTrans SNull . map u where u (LI x) = x; u x = [x] pluslen' xs = zip xs $ mkIndex [0..(length xs)] --map repeatedly, then finally concat iterApp :: Stringable a => [([SElem a], [SElem a]) -> SEnv a -> a] -> [SElem a] -> SEnv a -> [a] iterApp [f] (LI xs:[]) snv = map (flip f snv) (pluslen xs) iterApp [f] vars@(LI _:_) snv = map (flip f snv) (liTrans vars) iterApp [f] v snv = [f (v,ix0) snv] iterApp fs (LI xs:[]) snv = cycleApp fs (pluslen xs) snv iterApp fs vars@(LI _:_) snv = cycleApp fs (liTrans vars) snv iterApp fs xs snv = cycleApp fs (pluslen xs) snv anonTmpl :: Stringable a => TmplParser (([SElem a], [SElem a]) -> SEnv a -> a) anonTmpl = around '{' subStmp '}' regTemplate :: Stringable a => TmplParser (([SElem a], [SElem a]) -> SEnv a -> a) regTemplate = do try (functn::TmplParser (SEnv String -> SElem String)) .>> fail "" <|> return () name <- justSTR <$> many1 (identifierChar <|> char '/') <|> around '(' subexprn ')' tryTellTmpl (name nullEnv) vals <- around '(' (spaced $ try assgn <|> anonassgn <|> return []) ')' return $ join . (. name) . makeTmpl vals where makeTmpl v ((se:_),is) (STR x) = renderErr x |. stBind . (zip ["it","i","i0"] (se:is) ++) . swing (map . second) v <*> stLookup x makeTmpl _ _ _ = showStr "Invalid Template Specified" stBind v st = st {senv = foldr envInsert (senv st) v} anonassgn = (:[]) . (,) "it" <$> subexprn assgn = (spaced word >>= (<$> char '=' .>> spaced subexprn) . (,)) `sepEndBy1` char ';' tryTellTmpl (STR x) = tellTmpl x tryTellTmpl _ = return () --DEBUG {-pTrace s = pt <|> return () where pt = try $ do x <- try $ many1 anyChar trace (s++": " ++x) $ try $ char 'z' fail x -}