packages feed

darkplaces-text 0.1 → 0.2

raw patch · 11 files changed

+878/−105 lines, 11 filesdep +QuickCheckdep +darkplaces-textdep +hspecdep ~basebuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, darkplaces-text, hspec, utf8-string

Dependency ranges changed: base

API changes (from Hackage documentation)

- DarkPlaces.Text: class ToText a
- DarkPlaces.Text: hPutStrLnUtf :: Handle -> DPText -> IO ()
- DarkPlaces.Text: hPutStrUtf :: Handle -> DPText -> IO ()
- DarkPlaces.Text: instance ToText DPText
- DarkPlaces.Text: instance ToText DPTextToken
- DarkPlaces.Text: putStrLnUtf :: DPText -> IO ()
- DarkPlaces.Text: putStrUtf :: DPText -> IO ()
- DarkPlaces.Text: toText :: ToText a => a -> Text
+ DarkPlaces.Text: DPNewline :: DPTextToken a
+ DarkPlaces.Text: DPStreamState :: a -> DPTextToken a -> DPStreamState a
+ DarkPlaces.Text: NexuizDecode :: DecodeType
+ DarkPlaces.Text: PrintStreamArgs :: Bool -> BinStreamState -> DecodeFun ByteString Text -> PrintStreamArgs
+ DarkPlaces.Text: Utf8Ignore :: DecodeType
+ DarkPlaces.Text: Utf8Lenient :: DecodeType
+ DarkPlaces.Text: Utf8Strict :: DecodeType
+ DarkPlaces.Text: data DPStreamState a
+ DarkPlaces.Text: data DecodeType
+ DarkPlaces.Text: data PrintStreamArgs
+ DarkPlaces.Text: decodeFun :: PrintStreamArgs -> DecodeFun ByteString Text
+ DarkPlaces.Text: defaultPrintStreamArgs :: PrintStreamArgs
+ DarkPlaces.Text: defaultStreamState :: BinStreamState
+ DarkPlaces.Text: hPrintDPText :: (Printable a, Eq a) => Handle -> DecodeFun ByteString a -> Bool -> ByteString -> IO ()
+ DarkPlaces.Text: hPrintStreamDPText :: Handle -> PrintStreamArgs -> ByteString -> IO BinStreamState
+ DarkPlaces.Text: hPutDPText :: (Printable a, Eq a) => Handle -> DPText a -> IO ()
+ DarkPlaces.Text: hPutDPTextLn :: (Printable a, Eq a) => Handle -> DPText a -> IO ()
+ DarkPlaces.Text: hStreamEnd :: Handle -> Bool -> BinStreamState -> IO ()
+ DarkPlaces.Text: hSupportColors :: Handle -> IO Bool
+ DarkPlaces.Text: instance IsString (DPText ByteString)
+ DarkPlaces.Text: minimizeColors :: Eq a => DPText a -> DPText a
+ DarkPlaces.Text: printDPText :: (Printable a, Eq a) => DecodeFun ByteString a -> Bool -> ByteString -> IO ()
+ DarkPlaces.Text: printStreamDPText :: PrintStreamArgs -> ByteString -> IO BinStreamState
+ DarkPlaces.Text: putDPText :: (Printable a, Eq a) => DPText a -> IO ()
+ DarkPlaces.Text: putDPTextLn :: (Printable a, Eq a) => DPText a -> IO ()
+ DarkPlaces.Text: simplifyColors :: DPText a -> DPText a
+ DarkPlaces.Text: streamColor :: DPStreamState a -> DPTextToken a
+ DarkPlaces.Text: streamEnd :: Bool -> BinStreamState -> IO ()
+ DarkPlaces.Text: streamLeft :: DPStreamState a -> a
+ DarkPlaces.Text: streamState :: PrintStreamArgs -> BinStreamState
+ DarkPlaces.Text: supportColors :: IO Bool
+ DarkPlaces.Text: toASCII :: DecodeType -> BinaryDPText -> DecodedDPText
+ DarkPlaces.Text: toUTF :: DecodeType -> BinaryDPText -> DecodedDPText
+ DarkPlaces.Text: type BinStreamState = DPStreamState ByteString
+ DarkPlaces.Text: type BinaryDPText = DPText ByteString
+ DarkPlaces.Text: type DecodedDPText = DPText Text
+ DarkPlaces.Text: withColor :: PrintStreamArgs -> Bool
+ DarkPlaces.Text.Types: DPNewline :: DPTextToken a
+ DarkPlaces.Text.Types: DPStreamState :: a -> DPTextToken a -> DPStreamState a
+ DarkPlaces.Text.Types: DPString :: a -> DPTextToken a
+ DarkPlaces.Text.Types: DPText :: [DPTextToken a] -> DPText a
+ DarkPlaces.Text.Types: HexColor :: Int -> DPTextToken a
+ DarkPlaces.Text.Types: NexuizDecode :: DecodeType
+ DarkPlaces.Text.Types: SimpleColor :: Int -> DPTextToken a
+ DarkPlaces.Text.Types: Utf8Ignore :: DecodeType
+ DarkPlaces.Text.Types: Utf8Lenient :: DecodeType
+ DarkPlaces.Text.Types: Utf8Strict :: DecodeType
+ DarkPlaces.Text.Types: data DPStreamState a
+ DarkPlaces.Text.Types: data DPTextToken a
+ DarkPlaces.Text.Types: data DecodeType
+ DarkPlaces.Text.Types: defaultStreamState :: BinStreamState
+ DarkPlaces.Text.Types: hexColor :: ByteString -> DPTextToken a
+ DarkPlaces.Text.Types: instance Bounded DecodeType
+ DarkPlaces.Text.Types: instance Enum DecodeType
+ DarkPlaces.Text.Types: instance Eq DecodeType
+ DarkPlaces.Text.Types: instance Eq a => Eq (DPStreamState a)
+ DarkPlaces.Text.Types: instance Eq a => Eq (DPText a)
+ DarkPlaces.Text.Types: instance Eq a => Eq (DPTextToken a)
+ DarkPlaces.Text.Types: instance Monoid (DPText a)
+ DarkPlaces.Text.Types: instance Ord DecodeType
+ DarkPlaces.Text.Types: instance Printable a => Printable (DPText a)
+ DarkPlaces.Text.Types: instance Read DecodeType
+ DarkPlaces.Text.Types: instance Show DecodeType
+ DarkPlaces.Text.Types: instance Show a => Show (DPStreamState a)
+ DarkPlaces.Text.Types: instance Show a => Show (DPText a)
+ DarkPlaces.Text.Types: instance Show a => Show (DPTextToken a)
+ DarkPlaces.Text.Types: isColor :: DPTextToken a -> Bool
+ DarkPlaces.Text.Types: isNewline :: DPTextToken a -> Bool
+ DarkPlaces.Text.Types: isString :: DPTextToken a -> Bool
+ DarkPlaces.Text.Types: isTextData :: DPTextToken a -> Bool
+ DarkPlaces.Text.Types: mapDPText :: (a -> b) -> DPText a -> DPText b
+ DarkPlaces.Text.Types: mapDPTextStream :: (a -> b) -> DPStreamState a -> DPStreamState b
+ DarkPlaces.Text.Types: mapToken :: (a -> b) -> DPTextToken a -> DPTextToken b
+ DarkPlaces.Text.Types: newtype DPText a
+ DarkPlaces.Text.Types: optimizeDPText :: Monoid a => DPText a -> DPText a
+ DarkPlaces.Text.Types: putDPText' :: Printable a => (Handle -> IO ()) -> Handle -> DPText a -> IO ()
+ DarkPlaces.Text.Types: putDPText'' :: Printable a => Handle -> DPText a -> IO ()
+ DarkPlaces.Text.Types: putDPTextNoReset :: Printable a => Handle -> DPText a -> IO ()
+ DarkPlaces.Text.Types: simpleColor :: ByteString -> DPTextToken a
+ DarkPlaces.Text.Types: streamColor :: DPStreamState a -> DPTextToken a
+ DarkPlaces.Text.Types: streamLeft :: DPStreamState a -> a
+ DarkPlaces.Text.Types: toText :: (Monoid a, IsString a) => DPText a -> a
+ DarkPlaces.Text.Types: type BinStreamState = DPStreamState ByteString
+ DarkPlaces.Text.Types: type BinaryDPText = DPText ByteString
+ DarkPlaces.Text.Types: type DecodeFun a b = DPText a -> DPText b
+ DarkPlaces.Text.Types: type DecodedDPText = DPText Text
- DarkPlaces.Text: DPString :: Text -> DPTextToken
+ DarkPlaces.Text: DPString :: a -> DPTextToken a
- DarkPlaces.Text: DPText :: [DPTextToken] -> DPText
+ DarkPlaces.Text: DPText :: [DPTextToken a] -> DPText a
- DarkPlaces.Text: HexColor :: Int -> DPTextToken
+ DarkPlaces.Text: HexColor :: Int -> DPTextToken a
- DarkPlaces.Text: SimpleColor :: Int -> DPTextToken
+ DarkPlaces.Text: SimpleColor :: Int -> DPTextToken a
- DarkPlaces.Text: data DPTextToken
+ DarkPlaces.Text: data DPTextToken a
- DarkPlaces.Text: newtype DPText
+ DarkPlaces.Text: newtype DPText a
- DarkPlaces.Text: parseDPText :: ByteString -> DPText
+ DarkPlaces.Text: parseDPText :: ByteString -> BinaryDPText
- DarkPlaces.Text: stripColors :: DPText -> DPText
+ DarkPlaces.Text: stripColors :: DPText a -> DPText a

Files

Setup.hs view
@@ -1,2 +1,19 @@ import Distribution.Simple-main = defaultMain+import Distribution.Simple.Setup+import Data.List (elem)+++main = defaultMainWithHooks myhooks+  where+    hooks = simpleUserHooks+    myconf = wrapConfHook $ confHook hooks+    myhooks = hooks {confHook=myconf}+++wrapConfHook f args conf = f args conf'+  where+    pargs = configProgramArgs conf+    alex_args = ("alex", ["--latin1"])+    conf' = if alex_args `elem` pargs+        then conf+        else conf {configProgramArgs=alex_args : pargs}
darkplaces-text.cabal view
@@ -1,5 +1,5 @@ name:                darkplaces-text-version:             0.1+version:             0.2 license:             GPL-2 license-file:        LICENSE author:              Slava Bacherikov@@ -7,7 +7,7 @@ homepage:            https://github.com/bacher09/darkplaces-text bug-reports:         https://github.com/bacher09/darkplaces-text/issues category:            Game-build-type:          Simple+build-type:          Custom copyright:           (c) Slava Bacherikov 2015 cabal-version:       >=1.10 stability:           alpha@@ -19,15 +19,19 @@   that are unique for darkplaces fonts.  library-  exposed-modules:     DarkPlaces.Text-  other-modules:       DarkPlaces.Text.Lexer,+  exposed-modules:     DarkPlaces.Text,+                       DarkPlaces.Text.Types++  other-modules:       DarkPlaces.Text.Classes,+                       DarkPlaces.Text.Lexer,                        DarkPlaces.Text.Chars,                        DarkPlaces.Text.Colors-  -- other-extensions:    -  build-depends:       base >=4.7 && <4.8,++  build-depends:       base >=4.5 && <5,                        bytestring >=0.10 && <0.11,                        array,                        text >=1.0,+                       utf8-string >=0.3,                        vector >=0.10,                        ansi-terminal >=0.6 @@ -35,7 +39,23 @@   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -O2 -funbox-strict-fields -Wall -fno-warn-name-shadowing+  default-extensions:  FlexibleInstances +test-suite tests+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             Spec.hs+  other-modules:       DarkPlaces.TextSpec++  build-depends:       base >=4.5 && <5,+                       bytestring >=0.10 && <0.11,+                       darkplaces-text,+                       QuickCheck >= 2.5,+                       hspec++  default-extensions:  OverloadedStrings+ source-repository head   type:                git-  location:            https://github.com/bacher09/darkplaces-text+  location:            https://github.com/bacher09/darkplaces-text.git
+ dist/build/DarkPlaces/Text/Lexer.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE CPP,MagicHash #-}+{-# LINE 1 "src/DarkPlaces/Text/Lexer.x" #-}++{-# OPTIONS_GHC -w #-}+module DarkPlaces.Text.Lexer (+    parseDPText+) where+import DarkPlaces.Text.Types+import qualified Data.ByteString.Lazy as BL++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Char (ord)+import Data.Array.Base (unsafeAt)+#else+import Array+import Char (ord)+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+-- -----------------------------------------------------------------------------+-- Alex wrapper code.+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++import Data.Word (Word8)+++import qualified Data.Char+import qualified Data.ByteString.Lazy     as ByteString+import qualified Data.ByteString.Internal as ByteString (w2c)+++{-# LINE 47 "templates/wrappers.hs" #-}++type Byte = Word8++-- -----------------------------------------------------------------------------+-- The input type+++{-# LINE 72 "templates/wrappers.hs" #-}+++{-# LINE 92 "templates/wrappers.hs" #-}+++type AlexInput = (Char,+                  ByteString.ByteString)++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (c,_) = c++alexGetByte (_, cs)+   | ByteString.null cs = Nothing+   | otherwise          = Just (ByteString.head cs,+                                (ByteString.w2c $ ByteString.head cs,+                                 ByteString.tail cs))++++{-# LINE 121 "templates/wrappers.hs" #-}++-- -----------------------------------------------------------------------------+-- Token positions++-- `Posn' records the location of a token in the input text.  It has three+-- fields: the address (number of chacaters preceding the token), line number+-- and column of a token within the file. `start_pos' gives the position of the+-- start of the file and `eof_pos' a standard encoding for the end of file.+-- `move_pos' calculates the new position after traversing a given character,+-- assuming the usual eight character tab stops.+++{-# LINE 144 "templates/wrappers.hs" #-}++-- -----------------------------------------------------------------------------+-- Default monad+++{-# LINE 242 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Monad (with ByteString input)+++{-# LINE 333 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper+++{-# LINE 360 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper, ByteString version++++-- alexScanTokens :: String -> [token]+alexScanTokens str = go ('\n',str)+  where go inp@(_,str) =+          case alexScan inp 0 of+                AlexEOF -> []+                AlexError _ -> error "lexical error"+                AlexSkip  inp' len     -> go inp'+                AlexToken inp'@(_,str') _ act -> act (ByteString.take len str) : go inp'+                 where len = ByteString.length str - ByteString.length str'+++++{-# LINE 392 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper++-- Adds text positions to the basic model.+++{-# LINE 409 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper, ByteString version+++{-# LINE 424 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- GScan wrapper++-- For compatibility with previous versions of Alex, and because we can.+++alex_base :: AlexAddr+alex_base = AlexA# "\xf7\xff\xff\xff\xd2\xff\xff\xff\xe9\xff\xff\xff\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x09\x00\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA# "\x00\x00\x04\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_check :: AlexAddr+alex_check = AlexA# "\xff\xff\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_deflt :: AlexAddr+alex_deflt = AlexA# "\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff"#++alex_accept = listArray (0::Int,8) [AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAcc (alex_action_0),AlexAcc (alex_action_1),AlexAcc (alex_action_2),AlexAcc (alex_action_3),AlexAcc (alex_action_3)]+{-# LINE 26 "src/DarkPlaces/Text/Lexer.x" #-}++++-- | convert lazy `BL.ByteString` to `BinaryDPText`+parseDPText :: BL.ByteString -> BinaryDPText+parseDPText = DPText . alexScanTokens++alex_action_0 =  const DPNewline +alex_action_1 =  simpleColor +alex_action_2 =  hexColor +alex_action_3 =  DPString +{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine+++{-# LINE 21 "templates/GenericTemplate.hs" #-}++++++-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ > 706+#define GTE(n,m) (tagToEnum# (n >=# m))+#define EQ(n,m) (tagToEnum# (n ==# m))+#else+#define GTE(n,m) (n >=# m)+#define EQ(n,m) (n ==# m)+#endif++{-# LINE 51 "templates/GenericTemplate.hs" #-}+++data AlexAddr = AlexA# Addr#+-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+  narrow16Int# i+  where+        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+        low  = int2Word# (ord# (indexCharOffAddr# arr off'))+        off' = off *# 2#+#else+  indexInt16OffAddr# arr off+#endif++++++{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN+  narrow32Int# i+  where+   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+		     (b2 `uncheckedShiftL#` 16#) `or#`+		     (b1 `uncheckedShiftL#` 8#) `or#` b0)+   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))+   off' = off *# 4#+#else+  indexInt32OffAddr# arr off+#endif+++++++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+++++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+  = AlexEOF+  | AlexError  !AlexInput+  | AlexSkip   !AlexInput !Int+  | AlexToken  !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input (I# (sc))+  = alexScanUser undefined input (I# (sc))++alexScanUser user input (I# (sc))+  = case alex_scan_tkn user input 0# input sc AlexNone of+	(AlexNone, input') ->+		case alexGetByte input of+			Nothing -> ++++				   AlexEOF+			Just _ ->++++				   AlexError input'++	(AlexLastSkip input'' len, _) ->++++		AlexSkip input'' len++	(AlexLastAcc k input''' len, _) ->++++		AlexToken input''' len k+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user orig_input len input s last_acc =+  input `seq` -- strict in the input+  let +	new_acc = (check_accs (alex_accept `quickIndex` (I# (s))))+  in+  new_acc `seq`+  case alexGetByte input of+     Nothing -> (new_acc, input)+     Just (c, new_input) -> ++++      case fromIntegral c of { (I# (ord_c)) ->+        let+                base   = alexIndexInt32OffAddr alex_base s+                offset = (base +# ord_c)+                check  = alexIndexInt16OffAddr alex_check offset+		+                new_s = if GTE(offset,0#) && EQ(check,ord_c)+			  then alexIndexInt16OffAddr alex_table offset+			  else alexIndexInt16OffAddr alex_deflt s+	in+        case new_s of+	    -1# -> (new_acc, input)+		-- on an error, we want to keep the input *before* the+		-- character that failed, not after.+    	    _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len)+                                                -- note that the length is increased ONLY if this is the 1st byte in a char encoding)+			new_input new_s new_acc+      }+  where+	check_accs (AlexAccNone) = last_acc+	check_accs (AlexAcc a  ) = AlexLastAcc a input (I# (len))+	check_accs (AlexAccSkip) = AlexLastSkip  input (I# (len))++{-# LINE 198 "templates/GenericTemplate.hs" #-}++data AlexLastAcc a+  = AlexNone+  | AlexLastAcc a !AlexInput !Int+  | AlexLastSkip  !AlexInput !Int++instance Functor AlexLastAcc where+    fmap f AlexNone = AlexNone+    fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z+    fmap f (AlexLastSkip x y) = AlexLastSkip x y++data AlexAcc a user+  = AlexAccNone+  | AlexAcc a+  | AlexAccSkip++{-# LINE 242 "templates/GenericTemplate.hs" #-}++-- used by wrappers+iUnbox (I# (i)) = i+
src/DarkPlaces/Text.hs view
@@ -1,82 +1,199 @@ module DarkPlaces.Text (     DPText(..),     DPTextToken(..),-    ToText(..),+    DecodeType(..),+    DPStreamState(..),+    BinStreamState,+    PrintStreamArgs(..),+    BinaryDPText,+    DecodedDPText,     parseDPText,+    defaultStreamState,+    defaultPrintStreamArgs,     stripColors,-    hPutStrUtf,-    hPutStrLnUtf,-    putStrUtf,-    putStrLnUtf,+    minimizeColors,+    simplifyColors,+    hPrintDPText,+    printDPText,+    hPrintStreamDPText,+    printStreamDPText,+    hStreamEnd,+    streamEnd,+    toUTF,+    toASCII,+    hSupportColors,+    supportColors,+    hPutDPText,+    hPutDPTextLn,+    putDPText,+    putDPTextLn ) where import DarkPlaces.Text.Lexer+import DarkPlaces.Text.Types import DarkPlaces.Text.Colors import DarkPlaces.Text.Chars-import Numeric-import qualified Data.Text.Lazy as TL-import System.Console.ANSI-import qualified Data.Text.IO as TIO+import DarkPlaces.Text.Classes+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE import System.IO (Handle, stdout, hPutStrLn)+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.UTF8 as BLU+import System.Console.ANSI (hSupportsANSI)+import Data.String+import Data.Monoid  -class ToText a where-    toText :: a -> TL.Text+data PrintStreamArgs = PrintStreamArgs {+    withColor   :: Bool,+    streamState :: BinStreamState,+    decodeFun   :: DecodeFun BL.ByteString T.Text+} -instance ToText DPTextToken where-    toText (SimpleColor x) = TL.pack $ "^" ++ show x-    toText (HexColor x) = TL.pack $ "^x" ++ showHex x ""-    toText (DPString x) = TL.fromStrict x -instance ToText DPText where-    toText (DPText x) = TL.concat $ map toText x+defaultPrintStreamArgs :: PrintStreamArgs+defaultPrintStreamArgs = PrintStreamArgs True defaultStreamState (toUTF Utf8Lenient)  --- | Removes colors from `DPText`-stripColors :: DPText -> DPText-stripColors (DPText t) = DPText $ filter isString t+-- | Removes colors from `DPText a`+stripColors :: DPText a -> DPText a+stripColors (DPText t) = DPText $ filter isTextData t  -minimizeColors :: DPText -> DPText-minimizeColors (DPText t) = DPText $ minimize' t (SimpleColor 0)+minimizeColors' :: (Eq a) => DPTextToken a -> DPText a -> DPText a+minimizeColors' sc (DPText t) = DPText $ minimize' t sc   where     minimize' (x:xs) c         | isColor x && x == c = minimize' xs c         | isColor x = x : minimize' xs x+        | isNewline x = x : minimize' xs start_color         | otherwise = x : minimize' xs c      minimize' [] _ = []+    start_color = SimpleColor 0  -simplifyColors :: DPText -> DPText+minimizeColors :: (Eq a) => DPText a -> DPText a+minimizeColors = minimizeColors' (SimpleColor 0)+++simplifyColors :: DPText a -> DPText a simplifyColors (DPText t) =  DPText $ map convert t   where     convert (HexColor h) = SimpleColor (simplifyColor h)     convert x = x  -printColors' :: Handle -> DPText -> IO ()-printColors' f (DPText t) = mapM_ print t+splitStreamDPText :: DPStreamState a -> DPText a -> (DPText a, DPStreamState a)+splitStreamDPText st (DPText t) = (\(a, b) -> (DPText a, b)) $ go t st   where-    print (SimpleColor c) = hSetSGR f (getColor c)-    print (DPString s) = TIO.hPutStr f s-    print _ = return ()+    go [] st = ([], st)+    go [DPString s] st = ([], st {streamLeft=s})+    go (x:xs) st = let st' = if isColor x then st {streamColor=x} else st+                       (xs', st'') = go xs st'+                   in (x : xs', st'')  -printColors :: Handle -> DPText -> IO ()-printColors h = printColors' h . minimizeColors . simplifyColors+parseStreamDPText :: BinStreamState -> BL.ByteString -> (BinaryDPText, BinStreamState)+parseStreamDPText st bin_data = splitStreamDPText st' dp_text+  where+    dp_text = parseDPText $ streamLeft st <> bin_data+    st' = st {streamLeft=BL.empty}  -hPutStrUtf :: Handle -> DPText -> IO ()-hPutStrUtf h t = printColors h (decodeDPTextUTF t) >> hSetSGR h [Reset]+printColors :: (Printable a, Eq a) => Handle -> DPText a -> IO ()+printColors h = hPutPrintable h . minimizeColors . simplifyColors  -hPutStrLnUtf :: Handle -> DPText -> IO ()-hPutStrLnUtf h t = hPutStrUtf h t >> hPutStrLn h ""+printStreamColors :: (Printable a, Eq a) => Handle -> DPStreamState a -> DPText a -> IO ()+printStreamColors h st = hPutPrintable h . minimizeColors' (streamColor st) . simplifyColors ++hPutDPText :: (Printable a, Eq a) => Handle -> DPText a -> IO ()+hPutDPText h t = printColors h t >> hReset h+++hPutDPTextNoColors :: (Printable a, Eq a) => Handle -> DPText a -> IO ()+hPutDPTextNoColors h t = putDPTextNoReset h $ stripColors t+++hPutDPTextLn :: (Printable a, Eq a) => Handle -> DPText a -> IO ()+hPutDPTextLn h t = hPutDPText h t >> hPutStrLn h ""+ -- | prints `DPText` to console using utf8 encoding-putStrUtf :: DPText -> IO ()-putStrUtf = hPutStrUtf stdout+putDPText :: (Printable a, Eq a) => DPText a -> IO ()+putDPText = hPutDPText stdout  -- | same as `putStrUtf` but with newline break at the end-putStrLnUtf :: DPText -> IO ()-putStrLnUtf = hPutStrLnUtf stdout+putDPTextLn :: (Printable a, Eq a) => DPText a -> IO ()+putDPTextLn = hPutDPTextLn stdout++-- | Will print color message if first arg is True+-- | or if handle is terminal device+hPrintDPText ::(Printable a, Eq a) => Handle -> DecodeFun BL.ByteString a -> Bool -> BL.ByteString -> IO ()+hPrintDPText handle fun color text = if color+    then hPutDPText handle dptext+    else hPutDPTextNoColors handle dptext+  where+    dptext = fun $ parseDPText text+++printDPText :: (Printable a, Eq a) => DecodeFun BL.ByteString a -> Bool -> BL.ByteString -> IO ()+printDPText = hPrintDPText stdout+++hPrintStreamDPText :: Handle -> PrintStreamArgs -> BL.ByteString -> IO BinStreamState+hPrintStreamDPText h (PrintStreamArgs color st fun) bin = (if color+    then printStreamColors h st_dec dptext+    else hPutDPTextNoColors h dptext) >> return st'+  where+    (bintext, st') = parseStreamDPText st bin+    dptext = fun bintext+    st_dec = mapDPTextStream (const T.empty) st+++printStreamDPText :: PrintStreamArgs -> BL.ByteString -> IO BinStreamState+printStreamDPText = hPrintStreamDPText stdout+++hStreamEnd :: Handle -> Bool -> BinStreamState -> IO ()+hStreamEnd h color st = if color && streamColor st /= (SimpleColor 0)+    then hReset h+    else return ()+++streamEnd :: Bool -> BinStreamState -> IO ()+streamEnd = hStreamEnd stdout+++instance IsString (DPText BL.ByteString) where+    fromString = parseDPText . BLU.fromString+++toDecodedDPText :: DecodeType -> BinaryDPText -> DecodedDPText+toDecodedDPText dec_type = mapDPText (decodeFun dec_type . BL.toStrict)+  where+    decodeFun Utf8Lenient = TE.decodeUtf8With TEE.lenientDecode+    decodeFun Utf8Ignore = TE.decodeUtf8With TEE.ignore+    decodeFun Utf8Strict = TE.decodeUtf8With TEE.strictDecode+    decodeFun NexuizDecode = TE.decodeLatin1+++toUTF :: DecodeType -> BinaryDPText -> DecodedDPText+toUTF dec_type bin_text = decodeDPTextUTF (dec_type /= NexuizDecode) dec_text+  where+    dec_text = toDecodedDPText dec_type bin_text+++toASCII :: DecodeType -> BinaryDPText -> DecodedDPText+toASCII dec_type bin_text = decodeDPTextASCII (dec_type /= NexuizDecode) dec_text+  where+    dec_text = toDecodedDPText dec_type bin_text+++hSupportColors :: Handle -> IO Bool+hSupportColors = hSupportsANSI+++supportColors :: IO Bool+supportColors = hSupportColors stdout
src/DarkPlaces/Text/Chars.hs view
@@ -1,8 +1,8 @@ module DarkPlaces.Text.Chars where import Data.Vector import Data.Char-import qualified Data.Text as T-import DarkPlaces.Text.Lexer+import DarkPlaces.Text.Types+import DarkPlaces.Text.Classes   -- from https://github.com/xonotic/darkplaces/blob/master/console.c#L116@@ -113,27 +113,41 @@     ]  -decodeQFont :: Vector Char -> T.Text -> T.Text-decodeQFont qtable = T.map replace_char+decodeQFont :: (CharMap a) => Vector Char -> a -> a+decodeQFont qtable = mapChars replace_char   where     replace_char c = if '\xe000' <= c && c <= '\xe0ff'         then qtable ! (ord c - 0xe000)         else c -decodeQFontASCII :: T.Text -> T.Text-decodeQFontASCII = decodeQFont qfont_ascii_table -decodeQFontUTF :: T.Text -> T.Text-decodeQFontUTF = decodeQFont qfont_unicode_table--decodeDPText :: (T.Text -> T.Text) -> DPText -> DPText-decodeDPText f (DPText t) = DPText $ fmap mfun t+decodeQFontOld :: (CharMap a) => Vector Char -> a -> a+decodeQFontOld qtable = mapChars replace_char   where-    mfun (DPString s) = DPString $ f s-    mfun x = x+    replace_char c = if '\0' <= c && c <= '\255' && c /= '\n'+        then qtable ! (ord c)+        else c -decodeDPTextASCII :: DPText -> DPText-decodeDPTextASCII = decodeDPText decodeQFontASCII -decodeDPTextUTF :: DPText -> DPText-decodeDPTextUTF = decodeDPText decodeQFontUTF+-- also 42 and 96 are mappend in nexuiz+isOldGlyph :: Char -> Bool+isOldGlyph c = ('\0' <= c && c <= '\31' && c /= '\n') ||+               ('\127' <= c && c <= '\255')+++decodeQFontASCII :: (CharMap a) => Bool -> a -> a+decodeQFontASCII True = decodeQFont qfont_ascii_table+decodeQFontASCII False = decodeQFontOld qfont_ascii_table+++decodeQFontUTF :: (CharMap a) => Bool -> a -> a+decodeQFontUTF True = decodeQFont qfont_unicode_table+decodeQFontUTF False = decodeQFontOld qfont_unicode_table+++decodeDPTextASCII :: (CharMap a) => Bool -> DPText a -> DPText a+decodeDPTextASCII is_new = mapDPText $ decodeQFontASCII is_new+++decodeDPTextUTF :: (CharMap a) => Bool -> DPText a -> DPText a+decodeDPTextUTF is_new = mapDPText $ decodeQFontUTF is_new
+ src/DarkPlaces/Text/Classes.hs view
@@ -0,0 +1,72 @@+module DarkPlaces.Text.Classes (+    Printable(..),+    CharMap(..)+) where+import System.IO (Handle, stdout, hPutStr, hPutStrLn)+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TLIO+++class Printable a where+    hPutPrintable :: Handle -> a -> IO ()++    hPutPrintableLn :: Handle -> a -> IO ()+    hPutPrintableLn h d = hPutPrintableLn h d >> hPutStrLn h ""++    putPrintable :: a -> IO ()+    putPrintable d = hPutPrintable stdout d++    putPrintableLn :: a -> IO ()+    putPrintableLn d = hPutPrintableLn stdout d+++instance Printable [Char] where+    hPutPrintable = hPutStr+++instance Printable BC.ByteString where+    hPutPrintable = BC.hPut+    hPutPrintableLn = BC.hPutStrLn+++instance Printable BLC.ByteString where+    hPutPrintable = BLC.hPut+    hPutPrintableLn = BLC.hPutStrLn+++instance Printable T.Text where+    hPutPrintable = TIO.hPutStr+    hPutPrintableLn = TIO.hPutStrLn+++instance Printable TL.Text where+    hPutPrintable = TLIO.hPutStr+    hPutPrintableLn = TLIO.hPutStrLn+++class CharMap a where+    mapChars :: (Char -> Char) -> a -> a+++instance CharMap [Char] where+    mapChars = map+++instance CharMap BC.ByteString where+    mapChars = BC.map+++instance CharMap BLC.ByteString where+    mapChars = BLC.map+++instance CharMap T.Text where+    mapChars = T.map+++instance CharMap TL.Text where+    mapChars = TL.map
src/DarkPlaces/Text/Colors.hs view
@@ -2,10 +2,12 @@     RGB(..),     getRGB,     getColor,-    simplifyColor+    simplifyColor,+    hReset ) where import Data.Bits import System.Console.ANSI+import System.IO (Handle)  newtype RGB = RGB (Int, Int, Int) deriving(Show, Eq) newtype HSV = HSV (Double, Double, Double) deriving(Show, Eq)@@ -72,3 +74,7 @@     | n == 0 || n == 7 = [Reset]     | n == 8 || n == 9 = [SetConsoleIntensity BoldIntensity, SetColor Foreground Dull  Black]     | otherwise = []+++hReset :: Handle -> IO ()+hReset h = hSetSGR h [Reset]
src/DarkPlaces/Text/Lexer.x view
@@ -1,66 +1,32 @@ { {-# OPTIONS_GHC -w #-} module DarkPlaces.Text.Lexer (-    DPTextToken(..),-    DPText(..),-    parseDPText,-    isString,-    isColor+    parseDPText ) where+import DarkPlaces.Text.Types import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Text.Encoding-import qualified Data.Text.Lazy.Encoding as  TLE-import Data.String-import Numeric }  %wrapper "basic-bytestring"  $num = [0-9] $hexnum = [$num A-Fa-f]+$newline = \n @simple_color = \^ $num @hex_color = \^x $hexnum{3} @other = [^\^]+ | [. $white]  words :- +    $newline           { const DPNewline }     @simple_color      { simpleColor }     @hex_color         { hexColor }-    @other             { DPString . decodeUtf8 . BL.toStrict }+    @other             { DPString }  {-data DPTextToken = SimpleColor Int-                 | HexColor Int-                 | DPString T.Text-    deriving(Show, Eq)  -newtype DPText = DPText [DPTextToken]-    deriving(Show, Eq)---simpleColor :: BL.ByteString -> DPTextToken-simpleColor = SimpleColor . fst . head . readDec . BLC.unpack . BL.drop 1--hexColor :: BL.ByteString -> DPTextToken-hexColor = HexColor . fst . head . readHex . BLC.unpack . BL.drop 2---- | convert lazy `BL.ByteString` to `DPText`-parseDPText :: BL.ByteString -> DPText+-- | convert lazy `BL.ByteString` to `BinaryDPText`+parseDPText :: BL.ByteString -> BinaryDPText parseDPText = DPText . alexScanTokens--isString :: DPTextToken -> Bool-isString (DPString _) = True-isString _ = False--isColor :: DPTextToken -> Bool-isColor (SimpleColor _) = True-isColor (HexColor _) = True-isColor _ = False--instance IsString DPText where-    fromString = parseDPText . TLE.encodeUtf8 . TL.pack }
+ src/DarkPlaces/Text/Types.hs view
@@ -0,0 +1,137 @@+module DarkPlaces.Text.Types where+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.Text as T+import DarkPlaces.Text.Classes+import DarkPlaces.Text.Colors+import System.Console.ANSI+import System.IO (Handle, hPutChar)+import Data.Monoid+import Data.String+import Numeric+++data DPTextToken a = SimpleColor Int+                   | HexColor Int+                   | DPNewline+                   | DPString a+    deriving(Show, Eq)+++newtype DPText a = DPText [DPTextToken a]+    deriving(Show, Eq)+++type BinaryDPText = DPText BL.ByteString+type DecodedDPText = DPText T.Text+++data DecodeType = Utf8Lenient+                | Utf8Ignore+                | Utf8Strict+                | NexuizDecode+    deriving(Show, Read, Eq, Ord, Enum, Bounded)+++type DecodeFun a b = DPText a -> DPText b+++data DPStreamState a = DPStreamState {+    streamLeft  :: a,+    streamColor :: DPTextToken a+} deriving (Show, Eq)+++type BinStreamState = DPStreamState BL.ByteString+++defaultStreamState :: BinStreamState+defaultStreamState = DPStreamState BL.empty (SimpleColor 0)+++simpleColor :: BL.ByteString -> DPTextToken a+simpleColor = SimpleColor . fst . head . readDec . BLC.unpack . BL.drop 1+++hexColor :: BL.ByteString -> DPTextToken a+hexColor = HexColor . fst . head . readHex . BLC.unpack . BL.drop 2+++isString :: DPTextToken a -> Bool+isString (DPString _) = True+isString _ = False+++isColor :: DPTextToken a -> Bool+isColor (SimpleColor _) = True+isColor (HexColor _) = True+isColor _ = False+++isNewline :: DPTextToken a -> Bool+isNewline DPNewline = True+isNewline _ = False+++isTextData :: DPTextToken a -> Bool+isTextData = not . isColor+++mapToken :: (a -> b) -> DPTextToken a -> DPTextToken b+mapToken f (DPString s) = DPString $ f s+mapToken _ DPNewline = DPNewline+mapToken _ (SimpleColor c) = SimpleColor c+mapToken _ (HexColor c) = HexColor c+++mapDPText :: (a -> b) -> DPText a -> DPText b+mapDPText f (DPText l) = DPText $ map (mapToken f) l+++mapDPTextStream :: (a -> b) -> DPStreamState a -> DPStreamState b+mapDPTextStream f st = DPStreamState (f left) (mapToken f color)+  where+    (DPStreamState left color) = st+++putDPText' :: (Printable a) => (Handle -> IO ()) -> Handle -> DPText a -> IO ()+putDPText' nf h (DPText t) = mapM_ print t+  where+    print (SimpleColor c) = hSetSGR h (getColor c)+    print (DPString s) = hPutPrintable h s+    print DPNewline = nf h+    print _ = return ()+++putDPText'' :: (Printable a) => Handle -> DPText a -> IO ()+putDPText'' = putDPText' (\h -> hPutChar h '\n' >> hReset h)+++putDPTextNoReset :: (Printable a) => Handle -> DPText a -> IO ()+putDPTextNoReset = putDPText' (flip hPutChar '\n')+++instance Printable a => Printable (DPText a) where+    hPutPrintable = putDPText''+++instance Monoid (DPText a) where+    mempty = DPText []+    mappend (DPText a) (DPText b) = DPText $ a ++ b+++toText :: (Monoid a, IsString a) => DPText a -> a+toText (DPText tl) = mconcat $ map repr tl+  where+    repr DPNewline = fromString "\n"+    repr (DPString s) = s+    repr (SimpleColor c) = fromString $ "^" ++ show c+    repr (HexColor c) = fromString $ "^x" ++ showHex c ""+++optimizeDPText :: (Monoid a) => DPText a -> DPText a+optimizeDPText (DPText s) = DPText $ go s+  where+    go (DPString f : DPString s : xs) = DPString (f <> s) : go xs+    go (x:xs) = x : go xs+    go [] = []
+ tests/DarkPlaces/TextSpec.hs view
@@ -0,0 +1,57 @@+module DarkPlaces.TextSpec (+    spec+) where+import Test.Hspec+import DarkPlaces.Text+import DarkPlaces.Text.Types+import Test.QuickCheck+import Control.Applicative+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.Char+import Data.Monoid+++instance Arbitrary BL.ByteString where+    arbitrary = BL.pack <$> arbitrary+++instance (Arbitrary a) => Arbitrary (DPTextToken a) where+    arbitrary = do+        t <- choose (0, 3) :: Gen Int+        case t of+            0 -> SimpleColor <$> choose (0, 9)+            1 -> HexColor <$> choose (0, 0xFFF)+            2 -> DPString <$> arbitrary+            3 -> return DPNewline+++instance (Arbitrary a) => Arbitrary (DPText a) where+    arbitrary = DPText <$> arbitrary+++spec :: Spec+spec = do+    describe "parseDPText" $ do+        it "test base examples" $ do+            let res = DPText [+                      SimpleColor 1,DPString "one",SimpleColor 2,+                      DPString "two",HexColor 4095,DPString "three",+                      DPNewline,DPString "four"]++            parseDPText "^1one^2two^xfffthree\nfour" `shouldBe` res++        it "parsing string and converting back to string give same str" $ do+            property $ \xs -> lower (toText $ parseDPText xs) == lower xs++        it "converting to string and parsing gives same result" $ property $+            \xs -> toText (parseDPText $ toText xs) == toText xs++        it "check monoid property" $ property $+            \f s -> toText (f <> s) == (toText f :: BL.ByteString) <> (toText s)++    describe "stripColors" $ do+        it "should remove colors tokens" $ property $+            \xs -> (\(DPText s) -> not $ any isColor s) (stripColors xs :: DPText BL.ByteString)+  where+    lower = BLC.map toLower
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}