sgf 0.1.3.2 → 0.1.3.3
raw patch · 2 files changed
+169/−152 lines, 2 filesdep ~containersdep ~encodingdep ~extensible-exceptionsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: containers, encoding, extensible-exceptions, mtl, parsec, split, time, transformers
API changes (from Hackage documentation)
Files
- Data/SGF/Parse/Util.hs +160/−143
- sgf.cabal +9/−9
Data/SGF/Parse/Util.hs view
@@ -1,116 +1,126 @@ -- boilerplate {{{ module Data.SGF.Parse.Util where -import Control.Arrow-import Control.Monad.Except hiding (Error(..))+import Control.Arrow (Arrow (first, second, (&&&)))+import Control.Monad (liftM, liftM2, when, (>=>))+import Control.Monad.State (MonadState (get), MonadTrans (lift), StateT (StateT), gets, modify) import qualified Control.Monad.Trans.Except as Either-import Control.Monad.State hiding (State(..))-import Control.Monad.Writer-import Data.Char-import Data.Encoding-import Data.Function-import Data.Ix-import Data.List-import Data.Maybe-import Data.Map (Map(..), fromList, keys)-import Data.Ord+import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell), WriterT)+import Data.Char (isDigit, isSpace, toLower)+import Data.Encoding (DynEncoding)+import Data.Function (on)+import Data.Ix (Ix (range))+import Data.List (groupBy, isPrefixOf, nub, partition, sortBy)+import Data.Map (Map (..), fromList, keys)+import Data.Maybe (fromJust, listToMaybe)+import Data.Ord (comparing)+import Data.SGF.Parse.Encodings (decodeWordStringExplicit)+import Data.SGF.Parse.Raw (Property (..), enum)+import Data.SGF.Types (Color (..), Emphasis (..), Judgment, Mark, PartialDate, Point) import Data.Set (Set)-import Data.Tree-import Data.Word-import Text.Parsec hiding (State(..), choice, newline)+import Data.Tree (Tree (rootLabel))+import Data.Word (Word8)+import Text.Parsec (SourcePos) -import Data.SGF.Parse.Encodings-import Data.SGF.Parse.Raw-import Data.SGF.Types hiding (name) -- }}} -- new types {{{ -- Header {{{-data Header = Header {- format :: Integer,+data Header = Header+ { format :: Integer, encoding :: DynEncoding-}+ }+ -- }}} -- Error {{{--- |+ data ErrorType- = UnknownEncoding- | AmbiguousEncoding- | FormatUnsupported- | GameUnsupported- | OutOfBounds- | BadlyFormattedValue- | BadlyEncodedValue- | ConcurrentMoveAndSetup- | ConcurrentBlackAndWhiteMove- | ConcurrentAnnotations- | ExtraMoveAnnotations- deriving (Eq, Ord, Show, Read, Bounded, Enum)+ = UnknownEncoding+ | AmbiguousEncoding+ | FormatUnsupported+ | GameUnsupported+ | OutOfBounds+ | BadlyFormattedValue+ | BadlyEncodedValue+ | ConcurrentMoveAndSetup+ | ConcurrentBlackAndWhiteMove+ | ConcurrentAnnotations+ | ExtraMoveAnnotations+ deriving (Eq, Ord, Show, Read, Bounded, Enum) -- Errors signify unrecoverable errors. data Error- = KnownError { errorType :: ErrorType, errorPosition :: SourcePos }- | UnknownError { errorDescription :: Maybe String }- deriving (Eq, Ord, Show)+ = KnownError {errorType :: ErrorType, errorPosition :: SourcePos}+ | UnknownError {errorDescription :: Maybe String}+ deriving (Eq, Ord, Show) -die :: Error -> Translator a-dieWithPos :: ErrorType -> SourcePos -> Translator a-dieWith :: ErrorType -> Property -> Translator a+die :: Error -> Translator a+dieWithPos :: ErrorType -> SourcePos -> Translator a+dieWith :: ErrorType -> Property -> Translator a dieWithJust :: ErrorType -> Maybe Property -> Translator a+die = lift . StateT . const . Left -die = lift . StateT . const . Left-dieWithPos e = die . KnownError e-dieWith e = dieWithPos e . position+dieWithPos e = die . KnownError e++dieWith e = dieWithPos e . position+ dieWithJust e = dieWith e . fromJust+ -- }}} -- Warning {{{ -- by convention, a warning that does not end in a verb just "did the right thing" to correct the problem+ -- | -- Warnings signify recoverable errors. data Warning- = DuplicatePropertyOmitted Property- | SquareSizeSpecifiedAsRectangle SourcePos- | DanglingEscapeCharacterOmitted SourcePos- | PropValueForNonePropertyOmitted Property- | UnknownPropertyPreserved String- | PointSpecifiedAsPointRange Property- | DuplicatePointsOmitted Property [Point]- | InvalidDatesClipped (Set PartialDate)- | AnnotationWithNoMoveOmitted Property- | ExtraGameInfoOmitted Property- | NestedRootPropertyOmitted Property- | MovelessAnnotationOmitted Property- | DuplicateSetupOperationsOmitted [Point]- | ExtraPositionalJudgmentOmitted (Judgment, Emphasis)- | DuplicateMarkupOmitted (Mark, Point)- | ExtraPropertyValuesOmitted Property- | DuplicateLabelOmitted (Point, String)- | UnknownNumberingIgnored Integer- deriving (Eq, Ord, Show)+ = DuplicatePropertyOmitted Property+ | SquareSizeSpecifiedAsRectangle SourcePos+ | DanglingEscapeCharacterOmitted SourcePos+ | PropValueForNonePropertyOmitted Property+ | UnknownPropertyPreserved String+ | PointSpecifiedAsPointRange Property+ | DuplicatePointsOmitted Property [Point]+ | InvalidDatesClipped (Set PartialDate)+ | AnnotationWithNoMoveOmitted Property+ | ExtraGameInfoOmitted Property+ | NestedRootPropertyOmitted Property+ | MovelessAnnotationOmitted Property+ | DuplicateSetupOperationsOmitted [Point]+ | ExtraPositionalJudgmentOmitted (Judgment, Emphasis)+ | DuplicateMarkupOmitted (Mark, Point)+ | ExtraPropertyValuesOmitted Property+ | DuplicateLabelOmitted (Point, String)+ | UnknownNumberingIgnored Integer+ deriving (Eq, Ord, Show)+ -- }}} -- State, Translator a, PTranslator a {{{ type State = Tree [Property]-type Translator a = WriterT [Warning] (StateT State (Either Error)) a++type Translator a = WriterT [Warning] (StateT State (Either Error)) a+ type PTranslator a = Property -> Translator a transMap, transMapMulti :: PTranslator a -> String -> Translator (Maybe a)-transMap f = consumeSingle >=> transMap' f-transMapMulti f = consume >=> transMap' f+transMap f = consumeSingle >=> transMap' f+transMapMulti f = consume >=> transMap' f transMap' :: (a -> Translator b) -> (Maybe a -> Translator (Maybe b)) transMap' f = maybe (return Nothing) (liftM Just . f) transMapList :: PTranslator [a] -> String -> Translator [a] transMapList f = consume >=> maybe (return []) f+ -- }}} -- }}} -- handy Translators {{{ -- helper functions {{{-duplicatesOn :: Ord b => (a -> b) -> [a] -> [a]-duplicatesOn f = map fst- . concatMap (drop 1)- . groupBy ((==) `on` snd)- . sortBy (comparing snd)- . map (id &&& f)+duplicatesOn :: (Ord b) => (a -> b) -> [a] -> [a]+duplicatesOn f =+ map fst+ . concatMap (drop 1)+ . groupBy ((==) `on` snd)+ . sortBy (comparing snd)+ . map (id &&& f) duplicateProperties :: State -> [Warning] duplicateProperties = map DuplicatePropertyOmitted . duplicatesOn name . rootLabel@@ -120,53 +130,56 @@ readNumber :: String -> SourcePos -> Translator Integer readNumber "" _ = return 0-readNumber s pos | all isDigit s = return (read s)- | otherwise = dieWithPos BadlyFormattedValue pos+readNumber s pos+ | all isDigit s = return (read s)+ | otherwise = dieWithPos BadlyFormattedValue pos newline :: a -> (String -> a) -> (Char -> String -> a) -> String -> a newline empty with without xs = case xs of- '\r':'\n':xs -> with xs- '\n':'\r':xs -> with xs- '\r': xs -> with xs- '\n': xs -> with xs- x : xs -> without x xs- [] -> empty+ '\r' : '\n' : xs -> with xs+ '\n' : '\r' : xs -> with xs+ '\r' : xs -> with xs+ '\n' : xs -> with xs+ x : xs -> without x xs+ [] -> empty trim :: Char -> Char trim x = if isSpace x then ' ' else x descape :: Char -> SourcePos -> String -> Translator String descape hard pos s = case s of- ('\\':xs) -> newline' (tell [DanglingEscapeCharacterOmitted pos]) id xs- xs -> newline' (return ()) (hard:) xs- where- newline' warn prefix = newline (warn >> return "") (fmap prefix . descape hard pos) (\c -> fmap (trim c:) . descape hard pos)+ ('\\' : xs) -> newline' (tell [DanglingEscapeCharacterOmitted pos]) id xs+ xs -> newline' (return ()) (hard :) xs+ where+ newline' warn prefix = newline (warn >> return "") (fmap prefix . descape hard pos) (\c -> fmap (trim c :) . descape hard pos) decodeAndDescape :: Char -> Header -> PTranslator String-decodeAndDescape hard (Header { encoding = e }) (Property { values = v:_, position = pos }) =- case decodeWordStringExplicit e v of- Left exception -> dieWithPos BadlyEncodedValue pos- Right decoded -> descape hard pos decoded+decodeAndDescape hard (Header {encoding = e}) (Property {values = v : _, position = pos}) =+ case decodeWordStringExplicit e v of+ Left exception -> dieWithPos BadlyEncodedValue pos+ Right decoded -> descape hard pos decoded -splitColon :: [Word8] -> Maybe ( [Word8] , [Word8] )+splitColon :: [Word8] -> Maybe ([Word8], [Word8]) splitColons :: [[Word8]] -> Maybe ([[Word8]], [[Word8]])- splitColons = fmap unzip . mapM splitColon splitColon xs- | null xs = Nothing- | [enum ':' ] `isPrefixOf` xs = Just ([], drop 1 xs)- | [enum '\\'] `isPrefixOf` xs = continue 2- | otherwise = continue 1- where+ | null xs = Nothing+ | [enum ':'] `isPrefixOf` xs = Just ([], drop 1 xs)+ | [enum '\\'] `isPrefixOf` xs = continue 2+ | otherwise = continue 1+ where continue n = fmap (first (take n xs ++)) (splitColon (drop n xs)) warnAboutDuplicatePoints :: Property -> [Point] -> Translator [Point]-warnAboutDuplicatePoints p ps = let ds = duplicatesOn id ps in do- when (not $ null ds) (tell [DuplicatePointsOmitted p ds])- return (nub ps)+warnAboutDuplicatePoints p ps =+ let ds = duplicatesOn id ps+ in do+ when (not $ null ds) (tell [DuplicatePointsOmitted p ds])+ return (nub ps) checkPointList :: (PTranslator [Point] -> PTranslator [[Point]]) -> (PTranslator Point -> PTranslator [Point]) checkPointList listType a p = listType (mayBeCompoundPoint a) p >>= warnAboutDuplicatePoints p . concat+ -- }}} -- low-level {{{ has :: String -> Translator Bool@@ -177,86 +190,90 @@ consume :: String -> Translator (Maybe Property) consume s = do- (v, rest) <- gets (partition ((== s) . name) . rootLabel)- modify (\s -> s { rootLabel = rest })- return (listToMaybe v)+ (v, rest) <- gets (partition ((== s) . name) . rootLabel)+ modify (\s -> s {rootLabel = rest})+ return (listToMaybe v) consumeSingle :: String -> Translator (Maybe Property) consumeSingle s = do- maybeProperty <- consume s- case maybeProperty of- Just p@(Property { values = (v:_:_) }) -> do- tell [ExtraPropertyValuesOmitted p]- return (Just p { values = [v] })- _ -> return maybeProperty+ maybeProperty <- consume s+ case maybeProperty of+ Just p@(Property {values = (v : _ : _)}) -> do+ tell [ExtraPropertyValuesOmitted p]+ return (Just p {values = [v]})+ _ -> return maybeProperty unknownProperties :: Translator (Map String [[Word8]]) unknownProperties = do- m <- gets (fromList . map (name &&& values) . rootLabel)- tell [UnknownPropertyPreserved name | name <- keys m]- return m+ m <- gets (fromList . map (name &&& values) . rootLabel)+ tell [UnknownPropertyPreserved name | name <- keys m]+ return m+ -- }}} -- PTranslators and combinators {{{ number :: PTranslator Integer-number p@(Property { values = v:_ })- | enum '.' `elem` v = dieWith BadlyFormattedValue p- | otherwise = fmap floor (real p)+number p@(Property {values = v : _})+ | enum '.' `elem` v = dieWith BadlyFormattedValue p+ | otherwise = fmap floor (real p) real :: PTranslator Rational-real (Property { values = v:_, position = pos })- | [enum '+'] `isPrefixOf` v = result 1- | [enum '-'] `isPrefixOf` v = fmap negate (result 1)- | otherwise = result 0- where- split i = second (drop 1) . break (== '.') . map enum . drop i $ v- result i = let (n, d) = split i in do- whole <- readNumber n pos- fract <- readNumber d pos- return (fromInteger whole + fromInteger fract / 10 ^ length d)+real (Property {values = v : _, position = pos})+ | [enum '+'] `isPrefixOf` v = result 1+ | [enum '-'] `isPrefixOf` v = fmap negate (result 1)+ | otherwise = result 0+ where+ split i = second (drop 1) . break (== '.') . map enum . drop i $ v+ result i =+ let (n, d) = split i+ in do+ whole <- readNumber n pos+ fract <- readNumber d pos+ return (fromInteger whole + fromInteger fract / 10 ^ length d) simple :: Header -> PTranslator String-text :: Header -> PTranslator String-+text :: Header -> PTranslator String simple = decodeAndDescape ' '-text = decodeAndDescape '\n' +text = decodeAndDescape '\n'+ none :: PTranslator ()-none (Property { values = [[]] }) = return ()+none (Property {values = [[]]}) = return () none p = tell [PropValueForNonePropertyOmitted p] choice :: [([Word8], a)] -> PTranslator a-choice vs p@(Property { values = [] }) = dieWith BadlyFormattedValue p -- can't happen-choice vs p@(Property { values = v:_ }) = maybe (dieWith BadlyFormattedValue p) return (lookup v vs)+choice vs p@(Property {values = []}) = dieWith BadlyFormattedValue p -- can't happen+choice vs p@(Property {values = v : _}) = maybe (dieWith BadlyFormattedValue p) return (lookup v vs) choice' :: [(String, a)] -> PTranslator a choice' vs = choice [(map enum k, v) | (k', v) <- vs, k <- [k', map toLower k']] double :: PTranslator Emphasis-color :: PTranslator Color+color :: PTranslator Color double = choice' [("1", Normal), ("2", Strong)]-color = choice' [("B", Black), ("W", White)] +color = choice' [("B", Black), ("W", White)]+ compose :: PTranslator a -> PTranslator b -> PTranslator (a, b)-compose a b p@(Property { values = vs }) = case splitColons vs of- Nothing -> dieWith BadlyFormattedValue p- Just (as, bs) -> liftM2 (,) (a p { values = as }) (b p { values = bs })+compose a b p@(Property {values = vs}) = case splitColons vs of+ Nothing -> dieWith BadlyFormattedValue p+ Just (as, bs) -> liftM2 (,) (a p {values = as}) (b p {values = bs}) listOf :: PTranslator a -> PTranslator [a]-listOf a p@(Property { values = vs }) = mapM a [p { values = [v] } | v <- vs]+listOf a p@(Property {values = vs}) = mapM a [p {values = [v]} | v <- vs] elistOf :: PTranslator a -> PTranslator [a]-elistOf _ (Property { values = [[]] }) = return []+elistOf _ (Property {values = [[]]}) = return [] elistOf a p = listOf a p mayBeCompoundPoint, listOfPoint, elistOfPoint :: PTranslator Point -> PTranslator [Point]-mayBeCompoundPoint a p@(Property { values = v:_ }) = case splitColon v of- Nothing -> fmap return $ a p- Just {} -> do- pointRange <- compose a a p { values = [v] }- when (uncurry (==) pointRange) (tell [PointSpecifiedAsPointRange p])- return (range pointRange)--listOfPoint = checkPointList listOf+mayBeCompoundPoint a p@(Property {values = v : _}) = case splitColon v of+ Nothing -> return <$> a p+ Just {} -> do+ pointRange <- compose a a p {values = [v]}+ when (uncurry (==) pointRange) (tell [PointSpecifiedAsPointRange p])+ return (range pointRange)+listOfPoint = checkPointList listOf elistOfPoint = checkPointList elistOf+ -- }}} -- }}}
sgf.cabal view
@@ -1,5 +1,5 @@ name: sgf-version: 0.1.3.2+version: 0.1.3.3 author: Daniel Wagner daniel@wagner-home.com maintainer: Toni Cebrián ancechu@gmail.com homepage: https://github.com/tonicebrian/sgf@@ -26,14 +26,14 @@ Data.SGF.Parse.Raw Data.SGF.Parse.Util build-depends: base >=3 && < 5,- containers,- extensible-exceptions,- mtl>=1,- time>=1,- parsec>=3,- split,- encoding>=0.8,- transformers>=0.4+ containers >= 0.6.7 && < 0.7,+ encoding >= 0.8.9 && < 0.9,+ extensible-exceptions >= 0.1.1 && < 0.2,+ mtl >= 2.2.2,+ transformers >= 0.5.6,+ time >= 1.12.2 && < 1.13,+ split >= 0.2.5,+ parsec >= 3.1.16 && < 3.2 source-repository head type: git