rawstring-qm 0.1.6 → 0.2.0
raw patch · 4 files changed
+120/−77 lines, 4 filesdep −haskell-src-meta
Dependencies removed: haskell-src-meta
Files
- CHANGES +4/−0
- rawstring-qm.cabal +1/−2
- src/Data/String/QM.hs +63/−66
- src/Data/Text/ToText.hs +52/−9
CHANGES view
@@ -1,3 +1,7 @@+0.2.0+* remove lookup i.e. {} will not work from qm+* add tl qtl+* drop monster `haskell-src-meta` dependency 0.1.6 *Bounds for 7.6.3 0.1.5
rawstring-qm.cabal view
@@ -1,5 +1,5 @@ name: rawstring-qm-version: 0.1.6+version: 0.2.0 cabal-version: >=1.10 synopsis: Simple raw string quotation and dictionary interpolation description: Supply a couple of usefull QuasiQuotes so we can use functions to lookup values@@ -28,7 +28,6 @@ , text , template-haskell , bytestring- , haskell-src-meta hs-source-dirs: src default-language: Haskell2010
src/Data/String/QM.hs view
@@ -1,26 +1,23 @@-{-# LANGUAGE OverloadedStrings #-}--{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, - UndecidableInstances, OverlappingInstances, MultiParamTypeClasses,- IncoherentInstances+{-# LANGUAGE TemplateHaskell+ , OverloadedStrings #-} module Data.String.QM- (qq, qm)+ ( qq+ , qm+ , qt+ , qtl+ ) where import Language.Haskell.TH import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax--import Prelude ((.), ($), fail, map, return, foldl,foldl1, foldr)+import Data.Text.ToText import qualified Language.Haskell.TH as TH-import Language.Haskell.TH.Quote-import Language.Haskell.Meta.Parse import GHC.Exts (IsString(..))-import Data.Monoid (Monoid(..))+import Data.Monoid (Monoid(..), (<>)) import Data.ByteString.Char8 as Strict (ByteString, unpack) import Data.ByteString.Lazy.Char8 as Lazy (ByteString, unpack) import Data.Text as T (Text, unpack)@@ -29,85 +26,85 @@ import Prelude import Data.Maybe -data StringPart = Literal String | AntiQuote String | Lookup String deriving Show-+data StringPart = Literal String | AntiQuote String deriving Show +-- | qq is a block quote extension, it can be used anywhere you would put normal quotes+-- but you would require to have new line in them+-- if you put it as a pattern it will expan to 'a':'b':'c'... qq :: QuasiQuoter-qq = QuasiQuoter - { quoteExp = return . LitE . StringL- -- , quotePat = return . ListP . map (LitP . CharL)- , quotePat = return . bla+qq = QuasiQuoter+ { quoteExp = ls+ , quotePat = return . expandIntoCons , quoteType = \_ -> fail "illegal raw string QuasiQuote (allowed as expression only, used as a type)" , quoteDec = \_ -> fail "illegal raw string QuasiQuote (allowed as expression only, used as a declaration)" } --- lets have--bla [c] = LitP (CharL c)-bla (c:cs) = InfixP (LitP (CharL c)) '(:) (bla cs)+-- | QuasiQuoter for interpolating '$var' and '${expr}' into a string literal.+-- var and expr are just Names+qm :: QuasiQuoter+qm = QuasiQuoter (makeExpr . parseQM [])+ (error "Cannot use qm as a pattern")+ (error "Cannot use qm as a type")+ (error "Cannot use qm as a dec") +-- | QuasiQuoter for interpolating '$var' and '${expr}' into a string literal.+-- var and expr are just Names output is of type text vars are auto converted to text+qt :: QuasiQuoter+qt = QuasiQuoter (makeExprT . parseQM [])+ (error "Cannot use qm as a pattern")+ (error "Cannot use qm as a type")+ (error "Cannot use qm as a dec") -unQM a [] = [Literal (reverse a)]-unQM a ('\\':x:xs) = unQM (x:a) xs-unQM a ('\\':[]) = unQM ('\\':a) []-unQM a ('}':xs) = Lookup (reverse a) : parseQM [] xs-unQM a (x:xs) = unQM (x:a) xs+-- | QuasiQuoter for interpolating '$var' and '${expr}' into a string literal.+-- var and expr are just Names type lazy text, vars are magically (via `ToText` typeclass) converted to text+qtl :: QuasiQuoter+qtl = QuasiQuoter (makeExprTL . parseQM [])+ (error "Cannot use qm as a pattern")+ (error "Cannot use qm as a type")+ (error "Cannot use qm as a dec") parseQM a [] = [Literal (reverse a)] parseQM a ('\\':x:xs) = parseQM (x:a) xs-parseQM a ('\\':[]) = parseQM ('\\':a) []+parseQM a "\\" = parseQM ('\\':a) []++parseQM a ('$':'{':xs) = Literal (reverse a) : unQM [] xs parseQM a ('$':x:xs) | x == '_' || isAlpha x = Literal (reverse a) : AntiQuote (x:pre) : parseQM [] post where (pre, post) = span isIdent xs-parseQM a ('{':xs) = Literal (reverse a) : unQM [] xs parseQM a (x:xs) = parseQM (x:a) xs -isIdent '_' = True-isIdent '\'' = True-isIdent x = isAlphaNum x+unQM a ('\\':x:xs) = unQM (x:a) xs+unQM a "\\" = unQM ('\\':a) []+unQM a ('}':xs) = AntiQuote (reverse a) : parseQM [] xs+unQM a (x:xs) = unQM (x:a) xs makeExpr [] = ls ""-makeExpr ((Literal a):xs) = TH.appE [| (++) a |] +makeExpr (Literal a:xs) = TH.appE [| (<>) a |] $ makeExpr xs-makeExpr ((AntiQuote a):xs) = TH.appE [| (++) $(reifyM a) |]+makeExpr (AntiQuote a:xs) = TH.appE [| (<>) (reify a) |] $ makeExpr xs -ls = return . TH.LitE . TH.StringL--makeExprF1 a = - if (hasLookup a)- then- do- l <- TH.newName "lookup" -- string -> value- x <- TH.appE [| fromString |] $ makeExprF l a- return $ TH.LamE [TH.VarP l ] $ x- else- TH.appE [| fromString |] $ makeExpr a--makeExprF l [] = ls ""-makeExprF l ((Literal a):xs) = TH.appE [| (++) a |] - $ makeExprF l xs-makeExprF l ((AntiQuote a):xs) = TH.appE [| (++) $(reifyM a) |] - $ makeExprF l xs-makeExprF l ((Lookup a):xs) = TH.appE [| (++) ((fromMaybe "" $( return $ TH.AppE (TH.VarE l) (TH.LitE (TH.StringL a)) )) ) |] - $ makeExprF l xs+makeExprT [] = ls ""+makeExprT (Literal a:xs) = TH.appE [| (<>) a |]+ $ makeExprT xs+makeExprT (AntiQuote a:xs) = TH.appE [| (<>) (toText (reify a)) |]+ $ makeExprT xs -hasLookup [] = False-hasLookup ((Lookup _ ):as) = True-hasLookup (_:as) = hasLookup as+makeExprTL [] = ls ""+makeExprTL (Literal a:xs) = TH.appE [| (<>) a |]+ $ makeExprT xs+makeExprTL (AntiQuote a:xs) = TH.appE [| (<>) (toLazyText (reify a)) |]+ $ makeExprT xs --- | QuasiQuoter for interpolating '$var' and '{expr}' into a string literal. The pattern portion is undefined.-qm :: QuasiQuoter-qm = QuasiQuoter (makeExprF1 . parseQM [])- (error "Cannot use qm as a pattern")- (error "Cannot use qm as a type")- (error "Cannot use qm as a dec")+ls = return . TH.LitE . TH.StringL -reifyM s = - case parseExp s of- Left s -> TH.reportWarning s >> ls ""- Right e -> return e+isIdent '_' = True+isIdent '\'' = True+isIdent x = isAlphaNum x +-- Convert cons into pattern cons+expandIntoCons [c] = LitP (CharL c)+expandIntoCons (c:cs) = InfixP (LitP (CharL c)) '(:) (expandIntoCons cs)
src/Data/Text/ToText.hs view
@@ -1,29 +1,72 @@ {-# Language TypeSynonymInstances- , FlexibleInstances #-}+ , FlexibleInstances+ , ScopedTypeVariables+ , OverloadedStrings+ #-} module Data.Text.ToText where import Prelude import Data.Text+import qualified Data.Text.Lazy as TL import Data.Text.Lazy (toStrict)-import Data.Text.Lazy.Builder (toLazyText)+import qualified Data.Text.Lazy.Builder as TLB (toLazyText) import Data.Text.Lazy.Builder.Int (decimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) -class ToText a where- toText :: a -> Text+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy.Encoding as TL++import Text.Read+import Data.Typeable+import Data.Maybe (maybe)+import Data.Monoid++class (Typeable a, Read a) => ToText a where+ toText :: a -> Text+ toText = toStrict . toLazyText+ toLazyText :: a -> TL.Text++ fromText :: Text -> Either Text a+ fromText v = maybe (Left $ "parse failed: `" <> v <>"` can not be parsed as" <> pack (show (typeOf (undefined :: a))) ) Right . readMaybe . unpack $ v+ maybeFromText :: Text -> Maybe a+ maybeFromText = either (const Nothing) Just . fromText++ fromLazyText :: TL.Text -> Either Text a+ fromLazyText = fromText . toStrict+ maybeFromLazyText :: TL.Text -> Maybe a+ maybeFromLazyText = either (const Nothing) Just . fromLazyText+ instance ToText Int where- toText = toStrict . toLazyText . decimal+ toLazyText = TLB.toLazyText . decimal+ instance ToText Integer where- toText = toStrict . toLazyText . decimal+ toLazyText = TLB.toLazyText . decimal instance ToText Float where- toText = toStrict . toLazyText . realFloat+ toLazyText = TLB.toLazyText . realFloat +instance ToText Double where+ toLazyText = TLB.toLazyText . realFloat+ instance ToText Text where- toText = id+ toText = id+ toLazyText = TL.fromStrict +instance ToText TL.Text where+ toLazyText = id+ instance ToText String where- toText = pack+ toText = pack+ toLazyText = TL.pack++instance ToText BS.ByteString where+ toText = T.decodeUtf8+ toLazyText = TL.decodeUtf8 . BSL.fromChunks . (:[])++instance ToText BSL.ByteString where+ toLazyText = TL.decodeUtf8