sgf 0.1.3.1 → 0.1.3.2

raw patch · 3 files changed

+556/−334 lines, 3 filesdep ~encodingPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: encoding

API changes (from Hackage documentation)

Files

• Data/SGF/Parse.hs +518/−309
• Data/SGF/Parse/Encodings.hs +34/−18
• sgf.cabal +4/−7

@@ -1,21 +1,29 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+ -- TODO: check that every occurrence of "die" should really be a death, and not just a "fix-it-up-and-warn" -- boilerplate {{{-{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}-module Data.SGF.Parse (-    collection,-    clipDate,-    PropertyType(..),-    properties,-    extraProperties,-    Property(..),-    Warning(..),-    ErrorType(..),-    Error(..)-) where+-- TODO: check that every occurrence of "die" should really be a death, and not just a "fix-it-up-and-warn"+-- boilerplate {{{+module Data.SGF.Parse+    ( collection+    , clipDate+    , PropertyType(..)+    , properties+    , extraProperties+    , Property(..)+    , Warning(..)+    , ErrorType(..)+    , Error(..)+    ) where  import Control.Applicative import Control.Arrow import Control.Monad+import Control.Monad.Fail import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer@@ -25,32 +33,40 @@ import Data.Function import Data.List import Data.List.Split+import qualified Data.Map as Map import Data.Maybe import Data.Ord+import Data.SGF.Parse.Encodings+import Data.SGF.Parse.Raw hiding (collection)+import qualified Data.SGF.Parse.Raw as Raw+import Data.SGF.Parse.Util+import Data.SGF.Types (Game(Game), GameNode(GameNode))+import Data.SGF.Types hiding+    ( Game(..)+    , GameInfo(..)+    , GameNode(..)+    , Move(..)+    , Setup(..)+    )+import qualified Data.SGF.Types as T+import qualified Data.Set as Set import Data.Time.Calendar import Data.Tree import Data.Word-import Prelude     hiding (round)+import Prelude hiding (round) import Text.Parsec hiding (newline)-import Text.Parsec.Pos    (newPos)+import Text.Parsec.Pos (newPos) -import qualified Data.Map as Map-import qualified Data.Set as Set+instance MonadFail (Either Error) where+    fail :: String -> Either Error a+    fail msg = Left (UnknownError (Just msg)) -import Data.SGF.Parse.Encodings-import Data.SGF.Parse.Raw hiding (collection)-import Data.SGF.Types     hiding (Game(..), GameInfo(..), GameNode(..), Setup(..), Move(..))-import Data.SGF.Types     (Game(Game), GameNode(GameNode))-import Data.SGF.Parse.Util-import qualified Data.SGF.Parse.Raw as Raw-import qualified Data.SGF.Types     as T--- }}}--- top level/testing {{{-translate trans state = case runStateT (runWriterT trans) state of-    Left (UnknownError Nothing ) -> fail ""-    Left (UnknownError (Just e)) -> fail e-    Left e                       -> setPosition (errorPosition e) >> fail (show e)-    Right ((a, warnings), _)     -> return (a, warnings)+translate trans state =+    case runStateT (runWriterT trans) state of+        Left (UnknownError Nothing) -> fail ""+        Left (UnknownError (Just e)) -> fail e+        Left e -> setPosition (errorPosition e) >> fail (show e)+        Right ((a, warnings), _) -> return (a, warnings)  -- TODO: delete "test" test = runParser collection () "<interactive>" . map enum@@ -62,7 +78,9 @@ -- accumulated in the ['Warning'] return) and unrecoverable ones (which will -- result in parse errors). collection :: Stream s m Word8 => ParsecT s u m (Collection, [Warning])-collection = second concat . unzip <$> (mapM (translate gameTree) =<< Raw.collection)+collection =+    second concat . unzip <$> (mapM (translate gameTree) =<< Raw.collection)+ gameTree = do     hea <- parseHeader     app <- application hea@@ -70,162 +88,212 @@     var <- variationType     siz <- size gam     fmap (Game app var siz) (parse hea gam siz False)-    where-    parse h g s = case g of-        Go            -> fmap TreeGo            . nodeGo h s-        Backgammon    -> fmap TreeBackgammon    . nodeBackgammon h-        LinesOfAction -> fmap TreeLinesOfAction . nodeLinesOfAction h-        Hex           -> gameHex h-        Octi          -> fmap TreeOcti          . nodeOcti h-        other         -> fmap (TreeOther other) . nodeOther h+  where+    parse h g s =+        case g of+            Go -> fmap TreeGo . nodeGo h s+            Backgammon -> fmap TreeBackgammon . nodeBackgammon h+            LinesOfAction -> fmap TreeLinesOfAction . nodeLinesOfAction h+            Hex -> gameHex h+            Octi -> fmap TreeOcti . nodeOcti h+            other -> fmap (TreeOther other) . nodeOther h+ -- }}}-warnAll     w ps = mapM_ (\p -> maybe (return ()) (tell . (:[]) . w) =<< consume p) ps-dieEarliest e ps = dieWith e . head . sortBy (comparing position) . catMaybes =<< mapM consume ps+warnAll w ps =+    mapM_ (\p -> maybe (return ()) (tell . (: []) . w) =<< consume p) ps++dieEarliest e ps =+    dieWith e . head . sortBy (comparing position) . catMaybes =<<+    mapM consume ps+ -- game header information {{{-getFormat   = do+getFormat = do     prop <- consumeSingle "FF"-    ff   <- maybe (return 1) number prop-    when (ff /= 4) (dieWithPos FormatUnsupported (maybe (newPos "FF_missing" 1 1) position prop))+    ff <- maybe (return 1) number prop+    when+        (ff /= 4)+        (dieWithPos+             FormatUnsupported+             (maybe (newPos "FF_missing" 1 1) position prop))     return ff  getEncoding = do     ws <- consumeSingle "CA"     case maybe [encodingFromString "latin1"] (guessEncoding . head . values) ws of-        [encoding]  -> return encoding-        []          -> dieWithJust UnknownEncoding   ws-        _           -> dieWithJust AmbiguousEncoding ws -- pretty much guaranteed not to happen+        [encoding] -> return encoding+        [] -> dieWithJust UnknownEncoding ws+        _ -> dieWithJust AmbiguousEncoding ws -- pretty much guaranteed not to happen  parseHeader = liftM2 Header getFormat getEncoding  application = flip transMap "AP" . join compose . simple-gameType    = do++gameType = do     property <- consumeSingle "GM"     gameType <- maybe (return 1) number property-    if enum (minBound :: GameType) <= gameType && gameType <= enum (maxBound :: GameType)+    if enum (minBound :: GameType) <= gameType &&+       gameType <= enum (maxBound :: GameType)         then return (enum gameType)         else dieWithJust OutOfBounds property-variationType = transMap (\p -> number p >>= variationType' p) "ST" where-    variationType' property 0 = return (T.Children, True )-    variationType' property 1 = return (T.Siblings, True )++variationType = transMap (\p -> number p >>= variationType' p) "ST"+  where+    variationType' property 0 = return (T.Children, True)+    variationType' property 1 = return (T.Siblings, True)     variationType' property 2 = return (T.Children, False)     variationType' property 3 = return (T.Siblings, False)     variationType' property _ = dieWith OutOfBounds property+ size gameType = do     property <- consumeSingle "SZ"     case property of         Nothing -> return $ lookup gameType defaultSize-        Just p  -> if enum ':' `elem` head (values p)-            then do-                (m, n) <- join compose number p-                when (m == n) . tell . return . SquareSizeSpecifiedAsRectangle . position $ p-                checkValidity gameType m n property-            else do-                m <- number p-                checkValidity gameType m m property-    where-    invalid       t m n   = or [t == Go && (m > 52 || n > 52), m < 1, n < 1]-    checkValidity t m n p = when (invalid t m n) (dieWithJust OutOfBounds p) >> return (Just (m, n))+        Just p ->+            if enum ':' `elem` head (values p)+                then do+                    (m, n) <- join compose number p+                    when (m == n) .+                        tell .+                        return . SquareSizeSpecifiedAsRectangle . position $+                        p+                    checkValidity gameType m n property+                else do+                    m <- number p+                    checkValidity gameType m m property+  where+    invalid t m n = or [t == Go && (m > 52 || n > 52), m < 1, n < 1]+    checkValidity t m n p =+        when (invalid t m n) (dieWithJust OutOfBounds p) >> return (Just (m, n))+ -- }}} -- game-info properties {{{ gameInfo header =-        consumeFreeformGameInfo header-    >>= consumeUpdateGameInfo      rank   (\g v -> g { T.rankBlack = v }) "BR" header-    >>= consumeUpdateGameInfo      rank   (\g v -> g { T.rankWhite = v }) "WR" header-    >>= consumeUpdateGameInfo      round  (\g v -> g { T.round     = v }) "RO" header-    >>= consumeUpdateGameInfoMaybe result (\g v -> g { T.result    = v }) "RE" header-    >>= consumeUpdateGameInfoMaybe date   dateUpdate                      "DT" header-    >>= warnClipDate-    >>= timeLimit+    consumeFreeformGameInfo header >>=+    consumeUpdateGameInfo rank (\g v -> g {T.rankBlack = v}) "BR" header >>=+    consumeUpdateGameInfo rank (\g v -> g {T.rankWhite = v}) "WR" header >>=+    consumeUpdateGameInfo round (\g v -> g {T.round = v}) "RO" header >>=+    consumeUpdateGameInfoMaybe result (\g v -> g {T.result = v}) "RE" header >>=+    consumeUpdateGameInfoMaybe date dateUpdate "DT" header >>=+    warnClipDate >>=+    timeLimit -freeformGameInfo = [-    ("AN", T.Annotator       ),-    ("BT", T.TeamName Black  ),-    ("CP", T.Copyright       ),-    ("EV", T.Event           ),-    ("GN", T.GameName        ),-    ("GC", T.Context         ),-    ("ON", T.Opening         ),-    ("OT", T.Overtime        ),-    ("PB", T.PlayerName Black),-    ("PC", T.Location        ),-    ("PW", T.PlayerName White),-    ("SO", T.Source          ),-    ("US", T.User            ),-    ("WT", T.TeamName White  )+freeformGameInfo =+    [ ("AN", T.Annotator)+    , ("BT", T.TeamName Black)+    , ("CP", T.Copyright)+    , ("EV", T.Event)+    , ("GN", T.GameName)+    , ("GC", T.Context)+    , ("ON", T.Opening)+    , ("OT", T.Overtime)+    , ("PB", T.PlayerName Black)+    , ("PC", T.Location)+    , ("PW", T.PlayerName White)+    , ("SO", T.Source)+    , ("US", T.User)+    , ("WT", T.TeamName White)     ]-consumeFreeformGameInfo header = fmap gameInfo tagValues where++consumeFreeformGameInfo header = fmap gameInfo tagValues+  where     (tags, types) = unzip freeformGameInfo-    tagValues     = mapM (transMap (simple header)) tags-    gameInfo vals = (\m -> emptyGameInfo { T.freeform = m })-                  . Map.fromList . catMaybes-                  $ zipWith (fmap . (,)) types vals+    tagValues = mapM (transMap (simple header)) tags+    gameInfo vals =+        (\m -> emptyGameInfo {T.freeform = m}) . Map.fromList . catMaybes $+        zipWith (fmap . (,)) types vals  consumeUpdateGameInfo = consumeUpdateGameInfoMaybe . (return .)+ consumeUpdateGameInfoMaybe fromString update property header gameInfo = do-    maybeProp   <- consumeSingle property+    maybeProp <- consumeSingle property     maybeString <- transMap' (simple header) maybeProp     case (maybeProp, maybeString >>= fromString) of         (Nothing, _) -> return gameInfo         (_, Nothing) -> dieWithJust BadlyFormattedValue maybeProp-        (_, v)       -> return (update gameInfo v)+        (_, v) -> return (update gameInfo v)  abbreviateList xs = xs >>= \(n, v) -> [(n, v), (take 1 n, v)]+ -- TODO: can we unify this with the other implementation of reading a rational?-readRational s = liftM3 (\s n d -> s * (fromInteger n + d)) maybeSign maybeNum maybeDen where-    (sign, rest)       = span (`elem` "+-") s+readRational s =+    liftM3 (\s n d -> s * (fromInteger n + d)) maybeSign maybeNum maybeDen+  where+    (sign, rest) = span (`elem` "+-") s     (numerator, rest') = span isDigit rest-    denominator'       = drop 1 rest' ++ "0"-    denominator        = fromInteger (read denominator') / 10 ^ length denominator'-+    denominator' = drop 1 rest' ++ "0"+    denominator = fromInteger (read denominator') / 10 ^ length denominator'     maybeSign = lookup sign [("", 1), ("+", 1), ("-", -1)]-    maybeNum  = listToMaybe numerator >> return (read numerator)-    maybeDen  = guard (take 1 rest' `isPrefixOf` "." && all isDigit denominator') >> return denominator+    maybeNum = listToMaybe numerator >> return (read numerator)+    maybeDen =+        guard (take 1 rest' `isPrefixOf` "." && all isDigit denominator') >>+        return denominator -rank s = fromMaybe (OtherRank s) maybeRanked where-    (rank, rest)        = span isDigit s-    (scale, certainty)  = span isAlpha rest-    maybeRank           = listToMaybe rank >> return (read rank)-    maybeScale          = lookup (map toLower scale) scales-    maybeCertainty      = lookup certainty certainties+rank s = fromMaybe (OtherRank s) maybeRanked+  where+    (rank, rest) = span isDigit s+    (scale, certainty) = span isAlpha rest+    maybeRank = listToMaybe rank >> return (read rank)+    maybeScale = lookup (map toLower scale) scales+    maybeCertainty = lookup certainty certainties     maybeRanked = liftM3 Ranked maybeRank maybeScale maybeCertainty     certainties = [("", Nothing), ("?", Just Uncertain), ("*", Just Certain)]-    scales      = abbreviateList [("kyu", Kyu), ("dan", Dan), ("pro", Pro)]--result (c:'+':score) = liftM2 Win maybeColor maybeWinType where-    maybeColor   = lookup (toLower c) [('b', Black), ('w', White)]-    maybeWinType = lookup (map toLower score) winTypes `mplus` fmap Score (readRational score)-    winTypes     = abbreviateList [("", OtherWinType), ("forfeit", Forfeit), ("time", Time), ("resign", Resign)]+    scales = abbreviateList [("kyu", Kyu), ("dan", Dan), ("pro", Pro)] -result s = lookup (map toLower s) [("0", Draw), ("draw", Draw), ("void", Void), ("?", Unknown)]+result (c:'+':score) = liftM2 Win maybeColor maybeWinType+  where+    maybeColor = lookup (toLower c) [('b', Black), ('w', White)]+    maybeWinType =+        lookup (map toLower score) winTypes `mplus`+        fmap Score (readRational score)+    winTypes =+        abbreviateList+            [ ("", OtherWinType)+            , ("forfeit", Forfeit)+            , ("time", Time)+            , ("resign", Resign)+            ]+result s =+    lookup+        (map toLower s)+        [("0", Draw), ("draw", Draw), ("void", Void), ("?", Unknown)] -timeLimit gameInfo = fmap (\v -> gameInfo { T.timeLimit = v }) (transMap real "TM")+timeLimit gameInfo =+    fmap (\v -> gameInfo {T.timeLimit = v}) (transMap real "TM") -date = expect [] . splitWhen (== ',') where+date = expect [] . splitWhen (== ',')+  where     expect parsers [] = return []     expect parsers (pd:pds) = do-        parsed <- msum . sequence ([parseYMD, parseYM, parseY] ++ parsers) . splitWhen (== '-') $ pd-        liftM (parsed:) . ($ pds) $ case parsed of-            Year  {}                        -> expect []-            Month { year = y }              -> expect [parseMD y, parseM y]-            Day   { year = y, month = m }   -> expect [parseMD y, parseD y m]-+        parsed <-+            msum .+            sequence ([parseYMD, parseYM, parseY] ++ parsers) .+            splitWhen (== '-') $+            pd+        liftM (parsed :) . ($ pds) $+            case parsed of+                Year {} -> expect []+                Month {year = y} -> expect [parseMD y, parseM y]+                Day {year = y, month = m} -> expect [parseMD y, parseD y m]     ensure p x = guard (p x) >> return x-    hasLength n xs = n >= 0 && hasLength' n xs where-        hasLength' n []     = n == 0+    hasLength n xs = n >= 0 && hasLength' n xs+      where+        hasLength' n [] = n == 0         hasLength' 0 (x:xs) = False-        hasLength' n (x:xs) = hasLength' (n-1) xs+        hasLength' n (x:xs) = hasLength' (n - 1) xs     ensureLength = ensure . hasLength--    parseYMD    ss = ensureLength 3 ss >>= \[y, m, d] -> liftM3 Day   (checkY y) (checkMD m) (checkMD d)-    parseYM     ss = ensureLength 2 ss >>= \[y, m   ] -> liftM2 Month (checkY y) (checkMD m)-    parseY      ss = ensureLength 1 ss >>= \[y      ] -> liftM  Year  (checkY y)-    parseMD y   ss = ensureLength 2 ss >>= \[   m, d] -> liftM2 (Day y)          (checkMD m) (checkMD d)-    parseM  y   ss = ensureLength 1 ss >>= \[   m   ] -> liftM  (Month y)        (checkMD m)-    parseD  y m ss = ensureLength 1 ss >>= \[      d] -> liftM  (Day y m)                    (checkMD d)--    checkY  y  = ensureLength 4 y  >>= readM+    parseYMD ss =+        ensureLength 3 ss >>= \[y, m, d] ->+            liftM3 Day (checkY y) (checkMD m) (checkMD d)+    parseYM ss =+        ensureLength 2 ss >>= \[y, m] -> liftM2 Month (checkY y) (checkMD m)+    parseY ss = ensureLength 1 ss >>= \[y] -> liftM Year (checkY y)+    parseMD y ss =+        ensureLength 2 ss >>= \[m, d] -> liftM2 (Day y) (checkMD m) (checkMD d)+    parseM y ss = ensureLength 1 ss >>= \[m] -> liftM (Month y) (checkMD m)+    parseD y m ss = ensureLength 1 ss >>= \[d] -> liftM (Day y m) (checkMD d)+    checkY y = ensureLength 4 y >>= readM     checkMD md = ensureLength 2 md >>= readM-    readM      = listToMaybe . map fst . filter (null . snd) . reads+    readM = listToMaybe . map fst . filter (null . snd) . reads  -- | -- Clip to a valid, representable date.  Years are clipped to the 0000-9999@@ -235,65 +303,102 @@ -- -- If a parsed date is changed by this function, a warning is emitted. clipDate :: PartialDate -> PartialDate-clipDate (y@Year  {}) = Year . min 9999 . max 0 . year $ y-clipDate (Month { year = y, month = m }) = Month {-    year  = year . clipDate . Year $ y,-    month = min 12 . max 1 $ m-    }-clipDate (Day { year = y, month = m, day = d }) = let m' = clipDate (Month y m) in Day {-    year = year m', month = month m',-    day  = max 1 . min (fromIntegral (gregorianMonthLength (year m') (fromIntegral (month m')))) $ d-    }+clipDate (y@Year {}) = Year . min 9999 . max 0 . year $ y+clipDate (Month {year = y, month = m}) =+    Month {year = year . clipDate . Year $ y, month = min 12 . max 1 $ m}+clipDate (Day {year = y, month = m, day = d}) =+    let m' = clipDate (Month y m)+     in Day+            { year = year m'+            , month = month m'+            , day =+                  max 1 .+                  min+                      (fromIntegral+                           (gregorianMonthLength+                                (year m')+                                (fromIntegral (month m')))) $+                  d+            } -warnClipDate gameInfo@(T.GameInfo { T.date = d }) = let d' = Set.map clipDate d in do-    when (d /= d') (tell [InvalidDatesClipped d])-    return gameInfo { T.date = d' }+warnClipDate gameInfo@(T.GameInfo {T.date = d}) =+    let d' = Set.map clipDate d+     in do when (d /= d') (tell [InvalidDatesClipped d])+           return gameInfo {T.date = d'} -dateUpdate g v = g { T.date = maybe Set.empty Set.fromList v }+dateUpdate g v = g {T.date = maybe Set.empty Set.fromList v} -round s = case words s of-    [roundNumber@(_:_)]                | all isDigit roundNumber-        -> SimpleRound (read roundNumber)-    [roundNumber@(_:_), '(':roundType] | all isDigit roundNumber && last roundType == ')'-        -> FormattedRound (read roundNumber) (init roundType)-    _   -> OtherRound s+round s =+    case words s of+        [roundNumber@(_:_)]+            | all isDigit roundNumber -> SimpleRound (read roundNumber)+        [roundNumber@(_:_), '(':roundType]+            | all isDigit roundNumber && last roundType == ')' ->+                FormattedRound (read roundNumber) (init roundType)+        _ -> OtherRound s+ -- }}} -- move properties {{{ move move = do-    color_                                              <- mapM has ["B", "W"]-    [number_, overtimeMovesBlack_, overtimeMovesWhite_] <- mapM (transMap number) ["MN", "OB", "OW"]-    [timeBlack_, timeWhite_]                            <- mapM (transMap real  ) ["BL", "WL"]-    let partialMove = emptyMove {-            T.number                = number_,-            T.timeBlack             = timeBlack_,-            T.timeWhite             = timeWhite_,-            T.overtimeMovesBlack    = overtimeMovesBlack_,-            T.overtimeMovesWhite    = overtimeMovesWhite_-            }+    color_ <- mapM has ["B", "W"]+    [number_, overtimeMovesBlack_, overtimeMovesWhite_] <-+        mapM (transMap number) ["MN", "OB", "OW"]+    [timeBlack_, timeWhite_] <- mapM (transMap real) ["BL", "WL"]+    let partialMove =+            emptyMove+                { T.number = number_+                , T.timeBlack = timeBlack_+                , T.timeWhite = timeWhite_+                , T.overtimeMovesBlack = overtimeMovesBlack_+                , T.overtimeMovesWhite = overtimeMovesWhite_+                }     case color_ of-        [False, False] -> warnAll MovelessAnnotationOmitted ["KO", "BM", "DO", "IT", "TE"] >> return partialMove-        [True , True ] -> dieEarliest ConcurrentBlackAndWhiteMove ["B", "W"]-        [black, white] -> let color = if black then Black else White in do-            Just move   <- fmap msum . mapM (transMap move) $ ["B", "W"]-            illegal     <- fmap (maybe Possibly (const Definitely)) (transMap none "KO")-            annotations <- mapM has ["BM", "DO", "IT", "TE"]-            quality     <- case annotations of-                [False, False, False, False] -> return Nothing-                [True , False, False, False] -> fmap (fmap Bad ) (transMap double "BM")-                [False, False, False, True ] -> fmap (fmap Good) (transMap double "TE")-                [False, True , False, False] -> transMap none "DO" >> return (Just Doubtful   )-                [False, False, True , False] -> transMap none "IT" >> return (Just Interesting)-                _                            -> dieEarliest ConcurrentAnnotations ["BM", "DO", "IT", "TE"]-            return partialMove { T.move = Just (color, move), T.illegal = illegal, T.quality = quality }+        [False, False] ->+            warnAll MovelessAnnotationOmitted ["KO", "BM", "DO", "IT", "TE"] >>+            return partialMove+        [True, True] -> dieEarliest ConcurrentBlackAndWhiteMove ["B", "W"]+        [black, white] ->+            let color =+                    if black+                        then Black+                        else White+             in do Just move <- fmap msum . mapM (transMap move) $ ["B", "W"]+                   illegal <-+                       fmap+                           (maybe Possibly (const Definitely))+                           (transMap none "KO")+                   annotations <- mapM has ["BM", "DO", "IT", "TE"]+                   quality <-+                       case annotations of+                           [False, False, False, False] -> return Nothing+                           [True, False, False, False] ->+                               fmap (fmap Bad) (transMap double "BM")+                           [False, False, False, True] ->+                               fmap (fmap Good) (transMap double "TE")+                           [False, True, False, False] ->+                               transMap none "DO" >> return (Just Doubtful)+                           [False, False, True, False] ->+                               transMap none "IT" >> return (Just Interesting)+                           _ ->+                               dieEarliest+                                   ConcurrentAnnotations+                                   ["BM", "DO", "IT", "TE"]+                   return+                       partialMove+                           { T.move = Just (color, move)+                           , T.illegal = illegal+                           , T.quality = quality+                           }+ -- }}} -- setup properties {{{ setupPoint point = do     points <- mapM (transMapList (listOfPoint point)) ["AB", "AW", "AE"]     let [addBlack, addWhite, remove] = map Set.fromList points-        allPoints  = addBlack `Set.union` addWhite `Set.union` remove+        allPoints = addBlack `Set.union` addWhite `Set.union` remove         duplicates = concat points \\ Set.elems allPoints-        addWhite'  = addWhite  Set.\\ addBlack-        remove'    = remove    Set.\\ (addBlack `Set.union` addWhite')+        addWhite' = addWhite Set.\\ addBlack+        remove' = remove Set.\\ (addBlack `Set.union` addWhite')     unless (null duplicates) (tell [DuplicateSetupOperationsOmitted duplicates])     setupFinish addBlack addWhite' remove' @@ -301,72 +406,81 @@ -- addWhite, and remove specify disjoint sets of points -- TODO: what, really, cannot?  even if we allow ourselves a class constraint or something? setupPointStone point stone = do-    addBlack <- transMapList (listOf      stone) "AB"-    addWhite <- transMapList (listOf      stone) "AW"-    remove   <- transMapList (listOfPoint point) "AE"-    setupFinish (Set.fromList addBlack) (Set.fromList addWhite) (Set.fromList remove)+    addBlack <- transMapList (listOf stone) "AB"+    addWhite <- transMapList (listOf stone) "AW"+    remove <- transMapList (listOfPoint point) "AE"+    setupFinish+        (Set.fromList addBlack)+        (Set.fromList addWhite)+        (Set.fromList remove)  setupFinish addBlack addWhite remove =     liftM (T.Setup addBlack addWhite remove) (transMap color "PL")+ -- }}} -- none properties {{{ annotation header = do-    comment     <- transMap (text   header) "C"-    name        <- transMap (simple header) "N"-    hotspot     <- transMap double          "HO"-    value       <- transMap real            "V"-    judgments'  <- mapM (transMap double) ["GW", "GB", "DM", "UC"]+    comment <- transMap (text header) "C"+    name <- transMap (simple header) "N"+    hotspot <- transMap double "HO"+    value <- transMap real "V"+    judgments' <- mapM (transMap double) ["GW", "GB", "DM", "UC"]     let judgments = [(j, e) | (j, Just e) <- zip [GoodForWhite ..] judgments']     tell . map ExtraPositionalJudgmentOmitted . drop 1 $ judgments-    return emptyAnnotation {-        T.comment   = comment,-        T.name      = name,-        T.hotspot   = hotspot,-        T.value     = value,-        T.judgment  = listToMaybe judgments-    }+    return+        emptyAnnotation+            { T.comment = comment+            , T.name = name+            , T.hotspot = hotspot+            , T.value = value+            , T.judgment = listToMaybe judgments+            } -addMarks marks (mark, points) = tell warning >> return result where+addMarks marks (mark, points) = tell warning >> return result+  where     (ignored, inserted) = partition (`Map.member` marks) points     warning = map (DuplicateMarkupOmitted . (,) mark) ignored-    result  = marks `Map.union` Map.fromList [(i, mark) | i <- inserted]+    result = marks `Map.union` Map.fromList [(i, mark) | i <- inserted]  markup header point = do-    markedPoints <- mapM (transMapList (listOfPoint point)) ["CR", "MA", "SL", "SQ", "TR"]-    marks        <- foldM addMarks Map.empty . zip [Circle ..] $ markedPoints-    labels       <- transMapList (listOf (compose point (simple header))) "LB"-    arrows       <- consumePointPairs "AR"-    lines        <- consumePointPairs "LN"-    dim          <- transMapMulti ( listOfPoint point) "DD"-    visible      <- transMapMulti (elistOfPoint point) "VW"-    numbering    <- transMap number "PM"-    figure       <- transMap (figurePTranslator header) "FG"-+    markedPoints <-+        mapM (transMapList (listOfPoint point)) ["CR", "MA", "SL", "SQ", "TR"]+    marks <- foldM addMarks Map.empty . zip [Circle ..] $ markedPoints+    labels <- transMapList (listOf (compose point (simple header))) "LB"+    arrows <- consumePointPairs "AR"+    lines <- consumePointPairs "LN"+    dim <- transMapMulti (listOfPoint point) "DD"+    visible <- transMapMulti (elistOfPoint point) "VW"+    numbering <- transMap number "PM"+    figure <- transMap (figurePTranslator header) "FG"     tell . map DuplicateLabelOmitted $ labels \\ nubBy (on (==) fst) labels     tell [UnknownNumberingIgnored n | Just n <- [numbering], n < 0 || n > 2]-    -- TODO: some kind of warning when omitting arrows and lines--    return Markup {-        T.marks     = marks,-        T.labels    = Map.fromList labels,-        T.arrows    = prune arrows,-        T.lines     = prune . map canonicalize $ lines,-        T.dim       = fmap Set.fromList dim,-        T.visible   = fmap Set.fromList visible,-        T.numbering = numbering >>= flip lookup (zip [0..] [Unnumbered ..]),-        T.figure    = figure-    }-    where+  -- TODO: some kind of warning when omitting arrows and lines+    return+        Markup+            { T.marks = marks+            , T.labels = Map.fromList labels+            , T.arrows = prune arrows+            , T.lines = prune . map canonicalize $ lines+            , T.dim = fmap Set.fromList dim+            , T.visible = fmap Set.fromList visible+            , T.numbering =+                  numbering >>= flip lookup (zip [0 ..] [Unnumbered ..])+            , T.figure = figure+            }+  where     consumePointPairs = transMapList (listOf (join compose point))     prune = Set.fromList . filter (uncurry (/=))     canonicalize (x, y) = (min x y, max x y) -figurePTranslator header (Property { values = [[]] }) = return DefaultFigure+figurePTranslator header (Property {values = [[]]}) = return DefaultFigure figurePTranslator header p = do     (flags, name) <- compose number (simple header) p-    return $ if testBit flags 16-             then NamedDefaultFigure name-             else NamedFigure name (not . testBit flags . fromEnum)+    return $+        if testBit flags 16+            then NamedDefaultFigure name+            else NamedFigure name (not . testBit flags . fromEnum)+ -- }}} -- known properties list {{{ -- |@@ -376,128 +490,223 @@     | Setup     | Root     | GameInfo-    | Inherit -- ^-              -- Technically, these properties have type \"none\" and-              -- /attribute/ \"inherit\", but the property index lists them as-              -- properties of type \"inherit\" with no attributes, so we-              -- follow that lead.+    -- |+    -- Technically, these properties have type \"none\" and+    -- /attribute/ \"inherit\", but the property index lists them as+    -- properties of type \"inherit\" with no attributes, so we+    -- follow that lead.+    | Inherit     | None     deriving (Eq, Ord, Show, Read, Enum, Bounded)  -- | -- All properties of each type listed in the SGF specification. properties :: GameType -> PropertyType -> [String]-properties = liftM2 (++) properties' . extraProperties where-    properties' Move     = ["B", "KO", "MN", "W", "BM", "DO", "IT", "TE", "BL", "OB", "OW", "WL"]-    properties' Setup    = ["AB", "AE", "AW", "PL"]-    properties' Root     = ["AP", "CA", "FF", "GM", "ST", "SZ"]-    properties' GameInfo = ["AN", "BR", "BT", "CP", "DT", "EV", "GN", "GC", "ON", "OT", "PB", "PC", "PW", "RE", "RO", "RU", "SO", "TM", "US", "WR", "WT"]-    properties' Inherit  = ["DD", "PM", "VW"]-    properties' None     = ["C", "DM", "GB", "GW", "HO", "N", "UC", "V", "AR", "CR", "LB", "LN", "MA", "SL", "SQ", "TR", "FG"]+properties = liftM2 (++) properties' . extraProperties+  where+    properties' Move =+        ["B", "KO", "MN", "W", "BM", "DO", "IT", "TE", "BL", "OB", "OW", "WL"]+    properties' Setup = ["AB", "AE", "AW", "PL"]+    properties' Root = ["AP", "CA", "FF", "GM", "ST", "SZ"]+    properties' GameInfo =+        [ "AN"+        , "BR"+        , "BT"+        , "CP"+        , "DT"+        , "EV"+        , "GN"+        , "GC"+        , "ON"+        , "OT"+        , "PB"+        , "PC"+        , "PW"+        , "RE"+        , "RO"+        , "RU"+        , "SO"+        , "TM"+        , "US"+        , "WR"+        , "WT"+        ]+    properties' Inherit = ["DD", "PM", "VW"]+    properties' None =+        [ "C"+        , "DM"+        , "GB"+        , "GW"+        , "HO"+        , "N"+        , "UC"+        , "V"+        , "AR"+        , "CR"+        , "LB"+        , "LN"+        , "MA"+        , "SL"+        , "SQ"+        , "TR"+        , "FG"+        ]+ -- }}} -- game-specific stuff {{{-defaultSize = [-    (Go             , (19, 19)),-    (Chess          , ( 8,  8)),-    (LinesOfAction  , ( 8,  8)),-    (Hex            , (11, 11)),-    (Amazons        , (10, 10)),-    (Gess           , (20, 20))+defaultSize =+    [ (Go, (19, 19))+    , (Chess, (8, 8))+    , (LinesOfAction, (8, 8))+    , (Hex, (11, 11))+    , (Amazons, (10, 10))+    , (Gess, (20, 20))     ] -ruleSetLookup rs  = flip lookup rs . map toLower-ruleSetGo         = ruleSetLookup [-    ("aga"                      , AGA),-    ("goe"                      , GOE),-    ("chinese"                  , Chinese),-    ("japanese"                 , Japanese),-    ("nz"                       , NewZealand)-    ]-ruleSetBackgammon = ruleSetLookup [-    ("crawford"                 , Crawford),-    ("crawford:crawfordgame"    , CrawfordGame),-    ("jacoby"                   , Jacoby)-    ]-ruleSetOcti s = case break (== ':') s of-    (major, ':':minors) -> liftM  (flip OctiRuleSet (minorVariations minors       )) (majorVariation major        )-    (majorOrMinors, "") -> liftM  (flip OctiRuleSet (Set.empty                    )) (majorVariation majorOrMinors)-                   `mplus` return (OctiRuleSet Full (minorVariations majorOrMinors))-    where-    majorVariation      = ruleSetLookup [("full", Full), ("fast", Fast), ("kids", Kids)]-    minorVariation    s = fromMaybe (OtherMinorVariation s) . ruleSetLookup [("edgeless", Edgeless), ("superprong", Superprong)] $ s-    minorVariations     = Set.fromList . map minorVariation . splitWhen (== ',')+ruleSetLookup rs = flip lookup rs . map toLower +ruleSetGo =+    ruleSetLookup+        [ ("aga", AGA)+        , ("goe", GOE)+        , ("chinese", Chinese)+        , ("japanese", Japanese)+        , ("nz", NewZealand)+        ]++ruleSetBackgammon =+    ruleSetLookup+        [ ("crawford", Crawford)+        , ("crawford:crawfordgame", CrawfordGame)+        , ("jacoby", Jacoby)+        ]++ruleSetOcti s =+    case break (== ':') s of+        (major, ':':minors) ->+            liftM+                (flip OctiRuleSet (minorVariations minors))+                (majorVariation major)+        (majorOrMinors, "") ->+            liftM (flip OctiRuleSet (Set.empty)) (majorVariation majorOrMinors) `mplus`+            return (OctiRuleSet Full (minorVariations majorOrMinors))+  where+    majorVariation =+        ruleSetLookup [("full", Full), ("fast", Fast), ("kids", Kids)]+    minorVariation s =+        fromMaybe (OtherMinorVariation s) .+        ruleSetLookup [("edgeless", Edgeless), ("superprong", Superprong)] $+        s+    minorVariations = Set.fromList . map minorVariation . splitWhen (== ',')+ ruleSet read maybeDefault header = do     maybeRulesetString <- transMap (simple header) "RU"-    return $ case (maybeRulesetString, maybeRulesetString >>= read) of-        (Nothing, _      ) -> fmap Known maybeDefault-        (Just s , Nothing) -> Just (OtherRuleSet s)-        (_      , Just rs) -> Just (Known rs)+    return $+        case (maybeRulesetString, maybeRulesetString >>= read) of+            (Nothing, _) -> fmap Known maybeDefault+            (Just s, Nothing) -> Just (OtherRuleSet s)+            (_, Just rs) -> Just (Known rs)  ruleSetDefault = ruleSet (const Nothing) Nothing  -- | -- Just the properties associated with specific games. extraProperties :: GameType -> PropertyType -> [String]-extraProperties Go            GameInfo = ["HA", "KM"]-extraProperties Go            None     = ["TB", "TW"]-extraProperties Backgammon    Setup    = ["CO", "CV", "DI"]-extraProperties Backgammon    GameInfo = ["MI", "RE", "RU"]+extraProperties Go GameInfo = ["HA", "KM"]+extraProperties Go None = ["TB", "TW"]+extraProperties Backgammon Setup = ["CO", "CV", "DI"]+extraProperties Backgammon GameInfo = ["MI", "RE", "RU"] extraProperties LinesOfAction GameInfo = ["IP", "IY", "SU"]-extraProperties LinesOfAction None     = ["AS", "SE"]-extraProperties Hex           Root     = ["IS"]-extraProperties Hex           GameInfo = ["IP"]-extraProperties Amazons       Setup    = ["AA"]-extraProperties Octi          Setup    = ["RP"]-extraProperties Octi          GameInfo = ["BO", "WO", "NP", "NR", "NS"]-extraProperties Octi          None     = ["AS", "CS", "MS", "SS", "TS"]-extraProperties _             _        = []+extraProperties LinesOfAction None = ["AS", "SE"]+extraProperties Hex Root = ["IS"]+extraProperties Hex GameInfo = ["IP"]+extraProperties Amazons Setup = ["AA"]+extraProperties Octi Setup = ["RP"]+extraProperties Octi GameInfo = ["BO", "WO", "NP", "NR", "NS"]+extraProperties Octi None = ["AS", "CS", "MS", "SS", "TS"]+extraProperties _ _ = []  gameInfoGo = liftM2 GameInfoGo (transMap number "HA") (transMap real "KM") -pointGo (Property { values = [[x, y]] }) | valid x && valid y = return (translate x, translate y)-    where-    valid x     = (enum 'a' <= x && x <= enum 'z') || (enum 'A' <= x && x <= enum 'Z')-    translate x = enum x - enum (if x < enum 'a' then 'A' else 'a')+pointGo (Property {values = [[x, y]]})+    | valid x && valid y = return (translate x, translate y)+  where+    valid x =+        (enum 'a' <= x && x <= enum 'z') || (enum 'A' <= x && x <= enum 'Z')+    translate x =+        enum x -+        enum+            (if x < enum 'a'+                 then 'A'+                 else 'a') pointGo p = dieWith BadlyFormattedValue p -moveGo _             (Property { values = [[]] }) = return Pass-moveGo (Just (w, h)) p                            = pointGo p >>= \v@(x, y) -> return $ if x >= w || y >= h then Pass else Play v-moveGo _             p                            = fmap Play (pointGo p)+moveGo _ (Property {values = [[]]}) = return Pass+moveGo (Just (w, h)) p =+    pointGo p >>= \v@(x, y) ->+        return $+        if x >= w || y >= h+            then Pass+            else Play v+moveGo _ p = fmap Play (pointGo p)  annotationGo = do     territories <- mapM (transMap (elistOfPoint pointGo)) ["TB", "TW"]-    return . Map.fromList $ [(c, Set.fromList t) | (c, Just t) <- zip [Black, White] territories]+    return . Map.fromList $+        [(c, Set.fromList t) | (c, Just t) <- zip [Black, White] territories]  gameHex header seenGameInfo = fmap (TreeHex []) (nodeHex header seenGameInfo)  nodeGo header size seenGameInfo = do-    [hasGameInfo, hasRoot, hasSetup, hasMove] <- mapM (hasAny . properties Go) [GameInfo, Root, Setup, Move]-    let setGameInfo       = hasGameInfo && not seenGameInfo+    [hasGameInfo, hasRoot, hasSetup, hasMove] <-+        mapM (hasAny . properties Go) [GameInfo, Root, Setup, Move]+    let setGameInfo = hasGameInfo && not seenGameInfo         duplicateGameInfo = hasGameInfo && seenGameInfo     when (hasSetup && hasMove) dieSetupAndMove     when duplicateGameInfo warnGameInfo-    when hasRoot           warnRoot--    mGameInfo       <- liftM (\x -> guard setGameInfo >> Just x) (gameInfo header)-    otherGameInfo   <- gameInfoGo-    ruleSet_        <- ruleSet ruleSetGo Nothing header-    action_         <- if hasMove then liftM Right $ move (moveGo size) else liftM Left $ setupPoint pointGo-    annotation_     <- annotation header+    when hasRoot warnRoot+    mGameInfo <- liftM (\x -> guard setGameInfo >> Just x) (gameInfo header)+    otherGameInfo <- gameInfoGo+    ruleSet_ <- ruleSet ruleSetGo Nothing header+    action_ <-+        if hasMove+            then liftM Right $ move (moveGo size)+            else liftM Left $ setupPoint pointGo+    annotation_ <- annotation header     otherAnnotation <- annotationGo-    markup_         <- markup header pointGo-    unknown_        <- unknownProperties-    children        <- gets subForest >>= mapM (\s -> put s >> nodeGo header size (seenGameInfo || hasGameInfo))+    markup_ <- markup header pointGo+    unknown_ <- unknownProperties+    children <-+        gets subForest >>=+        mapM (\s -> put s >> nodeGo header size (seenGameInfo || hasGameInfo))+    return+        (Node+             (GameNode+                  (fmap+                       (\gi ->+                            gi+                                { T.ruleSet = ruleSet_+                                , T.otherGameInfo = otherGameInfo+                                })+                       mGameInfo)+                  action_+                  annotation_ {T.otherAnnotation = otherAnnotation}+                  markup_+                  unknown_)+             children)+  where+    dieSetupAndMove =+        dieEarliest ConcurrentMoveAndSetup (properties Go =<< [Setup, Move])+    warnGameInfo = warnAll ExtraGameInfoOmitted (properties Go GameInfo)+    warnRoot = warnAll NestedRootPropertyOmitted (properties Go Root) -    return (Node (GameNode (fmap (\gi -> gi { T.ruleSet = ruleSet_, T.otherGameInfo = otherGameInfo }) mGameInfo) action_ annotation_ { T.otherAnnotation = otherAnnotation } markup_ unknown_) children)-    where-    dieSetupAndMove    = dieEarliest ConcurrentMoveAndSetup    (properties Go =<< [Setup, Move])-    warnGameInfo       = warnAll     ExtraGameInfoOmitted      (properties Go GameInfo)-    warnRoot           = warnAll     NestedRootPropertyOmitted (properties Go Root)+nodeBackgammon = nodeOther -- TODO -nodeBackgammon    = nodeOther -- TODO nodeLinesOfAction = nodeOther -- TODO-nodeHex           = nodeOther -- TODO-nodeOcti          = nodeOther -- TODO++nodeHex = nodeOther -- TODO++nodeOcti = nodeOther -- TODO+ nodeOther header seenGameInfo = return (Node emptyGameNode []) -- TODO -- }}}

@@ -1,36 +1,47 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-}-module Data.SGF.Parse.Encodings (guessEncoding, decodeWordStringExplicit) where+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-} +module Data.SGF.Parse.Encodings+    ( guessEncoding+    , decodeWordStringExplicit+    ) where++import Control.Applicative (Applicative(..)) import Control.Exception.Extensible+import Control.Monad (ap, liftM) import Control.Monad.State-import Control.Applicative (Applicative(..))-import Control.Monad (liftM,ap) import Control.Throws import Data.Encoding import Data.Word  type MyIHateGHC = MyEither DecodingException (String, [Word8])-newtype MyEither a b = MyEither (Either a b) deriving (Throws a) +newtype MyEither a b =+    MyEither (Either a b)+    deriving (Throws a)+ instance Functor (MyEither a) where     fmap = liftM  instance Applicative (MyEither a) where-    pure = return +    pure :: a2 -> MyEither a1 a2+    pure x = return x -- note that an eta reduced version of this trips the type checker for non-canonical "pure = return"+    (<*>) :: MyEither a1 (a2 -> b) -> MyEither a1 a2 -> MyEither a1 b     (<*>) = ap  instance Monad (MyEither a) where-    return = MyEither . Right     (MyEither (Right x)) >>= f = f x-    (MyEither (Left  x)) >>= f = MyEither (Left x)+    (MyEither (Left x)) >>= f = MyEither (Left x)  instance ByteSource (StateT [Word8] (MyEither DecodingException)) where     sourceEmpty = gets null-    fetchWord8  = do+    fetchWord8 = do         s <- get         case s of-            []      -> throwException UnexpectedEnd-            c:cs    -> put cs >> return c+            [] -> throwException UnexpectedEnd+            c:cs -> put cs >> return c     fetchAhead m = do         s <- get         v <- m@@ -39,10 +50,13 @@  -- some ones that we know satisfy our invariant (see SGF.Parse.Raw) encodings = map encodingFromString ["latin1", "utf-8", "ascii"]-guess ws encoding = case runStateT (decode encoding) ws :: MyIHateGHC of-    (MyEither (Right (s, []))) -> encodingFromStringExplicit s == Just encoding-    _ -> False +guess ws encoding =+    case runStateT (decode encoding) ws :: MyIHateGHC of+        (MyEither (Right (s, []))) ->+            encodingFromStringExplicit s == Just encoding+        _ -> False+ -- | -- Try decoding the given word string with each of the known-good encodings to -- see if the decoded name names the encoding used to decode.  It should be@@ -52,7 +66,9 @@  -- | -- A simple wrapper around the encoding package's 'decode' function.-decodeWordStringExplicit :: Encoding e => e -> [Word8] -> Either DecodingException String-decodeWordStringExplicit e ws = case runStateT (decode e) ws :: MyIHateGHC of-    (MyEither (Right (s,_))) -> Right s-    (MyEither (Left  ex   )) -> Left ex+decodeWordStringExplicit ::+       Encoding e => e -> [Word8] -> Either DecodingException String+decodeWordStringExplicit e ws =+    case runStateT (decode e) ws :: MyIHateGHC of+        (MyEither (Right (s, _))) -> Right s+        (MyEither (Left ex)) -> Left ex

@@ -1,5 +1,5 @@ name:               sgf-version:            0.1.3.1+version:            0.1.3.2 author:             Daniel Wagner daniel@wagner-home.com maintainer:         Toni Cebrián ancechu@gmail.com  homepage:           https://github.com/tonicebrian/sgf@@ -14,20 +14,17 @@ category:           Data license:            BSD3 license-file:       LICENSE-cabal-version:      >= 1.6+cabal-version:      >= 1.10 build-type:         Simple  library-    ghc-options:    -Werror-+    default-language:   Haskell2010     exposed-modules:    Data.SGF                         Data.SGF.Parse                         Data.SGF.Types-     other-modules:      Data.SGF.Parse.Encodings                         Data.SGF.Parse.Raw                         Data.SGF.Parse.Util-     build-depends:  base >=3 && < 5,                     containers,                     extensible-exceptions,@@ -35,7 +32,7 @@                     time>=1,                     parsec>=3,                     split,-                    encoding>=0.6,+                    encoding>=0.8,                     transformers>=0.4  source-repository head