diff --git a/CHANGELOG.txt b/CHANGELOG.txt index 43bcb419..2414e33a 100644 --- a/CHANGELOG.txt +++ b/CHANGELOG.txt @@ -11,6 +11,7 @@ Changelog ideas-1.7 => ideas-1.8 * extending derivation interface (in Ideas.Common.Derivation) * refactoring logging interface and database name * new general Decoding module in utils; refactored encoders/decoders +* moving unicode decoding from parseXML/parseJSON to Main.Default Changelog ideas-1.6 => ideas.1.7 diff --git a/src/Ideas/Common/Derivation.hs b/src/Ideas/Common/Derivation.hs index 584ed57c..cdf35ecf 100644 --- a/src/Ideas/Common/Derivation.hs +++ b/src/Ideas/Common/Derivation.hs @@ -50,7 +50,7 @@ instance Functor (Derivation s) where instance BiFunctor Derivation where biMap f g (D a xs) = D (g a) (fmap (biMap f g) xs) -instance (IsTerm s, IsTerm a) => IsTerm (Derivation s a) where +instance (IsTerm s, IsTerm a) => IsTerm (Derivation s a) where toTerm = TList . derivationToList toTerm toTerm fromTerm (TList xs) = derivationFromList fromTerm fromTerm xs fromTerm _ = fail "not a derivation" @@ -75,7 +75,6 @@ mergeBy eq d@(D a xs) (D b ys) | eq (lastTerm d) b = Just $ D a (xs <> ys) | otherwise = Nothing - mergeStep :: Derivation s a -> s -> Derivation s a -> Derivation s a mergeStep (D a xs) s (D b ys) = D a (xs <> ((s, b) S.<| ys)) @@ -83,7 +82,7 @@ mergeStep (D a xs) s (D b ys) = D a (xs <> ((s, b) S.<| ys)) -- Conversion to/from list derivationToList :: (s -> b) -> (a -> b) -> Derivation s a -> [b] -derivationToList f g d = +derivationToList f g d = g (firstTerm d) : concat [ [f s, g a] | (_, s, a) <- triples d ] derivationFromList :: Monad m => (b -> m s) -> (b -> m a) -> [b] -> m (Derivation s a) @@ -143,7 +142,7 @@ derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m () derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) (F.toList xs) splitStep :: (s -> Bool) -> Derivation s a -> Maybe (Derivation s a, s, Derivation s a) -splitStep p (D a xs) = +splitStep p (D a xs) = case S.viewl xs2 of S.EmptyL -> Nothing (s, b) S.:< ys -> Just (D a xs1, s, D b ys) diff --git a/src/Ideas/Common/Examples.hs b/src/Ideas/Common/Examples.hs index 9c4a3352..cc04a8e0 100644 --- a/src/Ideas/Common/Examples.hs +++ b/src/Ideas/Common/Examples.hs @@ -9,27 +9,27 @@ -- Portability : portable (depends on ghc) -- -- * This module provides an interface to structure a collection of examples. --- Examples can be taken from (lists of) concrete values, or from random +-- Examples can be taken from (lists of) concrete values, or from random -- generators. Both types can be marked as test items. Examples can be assigned -- a level of difficulty (ranging from very easy to very difficult). Test items -- do not have a difficulty level. Examples can be grouped into sub-collections --- and assigned an identifier. Use the @Monoid@ operations for combining +-- and assigned an identifier. Use the @Monoid@ operations for combining -- examples. --- +-- ----------------------------------------------------------------------------- module Ideas.Common.Examples - ( -- * Examples type + ( -- * Examples type Examples - -- * Constructing examples + -- * Constructing examples , example, exampleList, examplesFor, examplesWithDifficulty , random, group, forTesting -- * Assigning difficulty , difficulty, veryEasy, easy, medium, difficult, veryDifficult - -- * Transformations and queries + -- * Transformations and queries , isEmpty, size, flatten, groups , topLevelExamples, topLevelRandoms, topLevelTests, topLevelRandomTests - , allExamples, allRandoms, allTests, allRandomTests + , allExamples, allRandoms, allTests, allRandomTests -- * Difficulty type , Difficulty(..), readDifficulty ) where @@ -112,28 +112,28 @@ forTesting = changeItems f -- | Top-level examples topLevelExamples :: Examples a -> [(Maybe Difficulty, a)] -topLevelExamples = collectItems f +topLevelExamples = collectItems f where f (Example md a) = Just (md, a) f _ = Nothing -- | Top-level random generators topLevelRandoms :: Examples a -> [(Maybe Difficulty, Gen a)] -topLevelRandoms = collectItems f +topLevelRandoms = collectItems f where f (Random md g) = Just (md, g) f _ = Nothing -- | Top-level test cases topLevelTests :: Examples a -> [a] -topLevelTests = collectItems f +topLevelTests = collectItems f where f (Test a) = Just a f _ = Nothing -- | Top-level test generators topLevelRandomTests :: Examples a -> [Gen a] -topLevelRandomTests = collectItems f +topLevelRandomTests = collectItems f where f (RandomTest g) = Just g f _ = Nothing @@ -217,7 +217,7 @@ readDifficulty s = where normal = filter isAlpha . map toLower p = (== normal s) . normal . show - + veryEasy, easy, medium, difficult, veryDifficult :: Examples a -> Examples a veryEasy = difficulty VeryEasy easy = difficulty Easy diff --git a/src/Ideas/Common/Exercise.hs b/src/Ideas/Common/Exercise.hs index 042afdfd..75c90f48 100644 --- a/src/Ideas/Common/Exercise.hs +++ b/src/Ideas/Common/Exercise.hs @@ -288,7 +288,7 @@ randomTerms :: QCGen -> Exercise a -> Maybe Difficulty -> [a] randomTerms rng ex mdif = rec rng where rec a = maybe id (:) (randomTerm a ex mdif) (rec (snd (next a))) - + -- | An exercise generator for testing purposes (including corner cases); first generator only. testGenerator :: Exercise a -> Maybe (Gen a) testGenerator = listToMaybe . allRandomTests . examples diff --git a/src/Ideas/Common/ExerciseTests.hs b/src/Ideas/Common/ExerciseTests.hs index 6bbd3382..cf65b3e8 100644 --- a/src/Ideas/Common/ExerciseTests.hs +++ b/src/Ideas/Common/ExerciseTests.hs @@ -73,7 +73,7 @@ exerciseTestSuite qcgen ex = suite ("Exercise " ++ show (exerciseId ex)) $ where rs = randomTerms qcgen ex Nothing xs | null rs = examplesAsList ex - | otherwise = take 10 rs + | otherwise = take 10 rs data ShowAs a = S {showS :: a -> String, fromS :: a} diff --git a/src/Ideas/Common/Rewriting/AutoTerm.hs b/src/Ideas/Common/Rewriting/AutoTerm.hs index afad3239..5e67b6f9 100644 --- a/src/Ideas/Common/Rewriting/AutoTerm.hs +++ b/src/Ideas/Common/Rewriting/AutoTerm.hs @@ -18,7 +18,7 @@ import Ideas.Common.Rewriting.Term import Ideas.Utils.Prelude (headM) toTermG :: Data a => a -> Term -toTermG a = +toTermG a = case constrRep constr of IntConstr n -> TNum n -- for Int and Integer FloatConstr r -> TFloat (fromRational r) -- for Double and Float @@ -30,14 +30,14 @@ toTermG a = where op (M xs) x = M (xs ++ [toTermG x]) e _ = M [] - constr = toConstr a + constr = toConstr a newtype M a = M [Term] -- test for list constructors makeTerm :: Constr -> M a -> Term makeTerm c (M xs) = - case xs of + case xs of [y, TList ys] | isCons -> TList (y:ys) [] | isNil -> TList [] _ -> TCon (constrSymbol c) xs @@ -45,7 +45,7 @@ makeTerm c (M xs) = txt = showConstr c isNil = txt == "[]" isCons = txt == "(:)" - + isTuple :: String -> Bool isTuple ('(':xs) = rec xs where @@ -56,7 +56,7 @@ isTuple _ = False ------------------------------------------------------------------------ -constrSymbol :: Constr -> Symbol +constrSymbol :: Constr -> Symbol constrSymbol c | txt == "[]" = nilSymbol | txt == "(:)" = consSymbol @@ -77,7 +77,7 @@ constructors = dataTypeConstrs . dataTypeOf . fromProxy fromProxy = error "fromProxy" findConstr :: (Monad m, Data a) => Proxy a -> Symbol -> m Constr -findConstr p s = +findConstr p s = headM [ c | c <- constructors p, s == constrSymbol c ] fromTermG :: (MonadPlus m, Data a) => Term -> m a @@ -95,7 +95,7 @@ fromTermG term = nil = symbol nilSymbol castM :: (Monad m, Typeable a, Typeable b) => a -> m b -castM = maybe (fail "fromTermG") return . cast +castM = maybe (fail "fromTermG") return . cast doubleToFloat :: Double -> Float doubleToFloat = fromRational . toRational diff --git a/src/Ideas/Common/Strategy/Traversal.hs b/src/Ideas/Common/Strategy/Traversal.hs index 00f06db9..a91b9eb0 100644 --- a/src/Ideas/Common/Strategy/Traversal.hs +++ b/src/Ideas/Common/Strategy/Traversal.hs @@ -31,7 +31,6 @@ module Ideas.Common.Strategy.Traversal ) where import Data.Monoid hiding ((<>)) -import qualified Data.Semigroup as Sem import Data.Semigroup ((<>)) import Ideas.Common.Classes import Ideas.Common.Rule @@ -39,6 +38,7 @@ import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Combinators import Ideas.Common.Traversal.Navigator import Prelude hiding (repeat, not, traverse) +import qualified Data.Semigroup as Sem import qualified Prelude ---------------------------------------------------------------------- diff --git a/src/Ideas/Encoding/Encoder.hs b/src/Ideas/Encoding/Encoder.hs index 84756785..ab128da9 100644 --- a/src/Ideas/Encoding/Encoder.hs +++ b/src/Ideas/Encoding/Encoder.hs @@ -38,7 +38,7 @@ import Ideas.Service.FeedbackScript.Parser (Script) import Ideas.Service.Types import Ideas.Text.JSON hiding (String) import Ideas.Text.Latex -import Ideas.Utils.Decoding +import Ideas.Utils.Decoding import Test.QuickCheck.Random import qualified Ideas.Common.Rewriting.Term as Term import qualified Ideas.Text.JSON as JSON diff --git a/src/Ideas/Encoding/EncoderHTML.hs b/src/Ideas/Encoding/EncoderHTML.hs index a484e098..74a05510 100644 --- a/src/Ideas/Encoding/EncoderHTML.hs +++ b/src/Ideas/Encoding/EncoderHTML.hs @@ -40,8 +40,8 @@ import Ideas.Text.HTML.W3CSS hiding (tag, ul, top, table, content) import Ideas.Text.OpenMath.FMP import Ideas.Text.OpenMath.Object import Ideas.Text.XML hiding (content) -import Ideas.Utils.TestSuite import Ideas.Utils.Prelude (munless, mwhen) +import Ideas.Utils.TestSuite import System.IO.Unsafe import qualified Ideas.Text.HTML.W3CSS as W3 @@ -151,12 +151,12 @@ encodeConst dr tv@(val ::: tp) = Term -> text val Context -> encodeContext val String -> string val - Result -> exerciseHeader (encodeResult val) + Result -> exerciseHeader (encodeResult val) _ -> text tv encodeContext :: Context a -> HTMLEncoder a encodeContext ctx = (\ex -> string (prettyPrinterContext ex ctx)) <$> getExercise - + encodeIndex :: DomainReasoner -> HTMLEncoder a encodeIndex dr = return $ mconcat [ htmlDescription "Domain reasoner" dr @@ -177,7 +177,7 @@ encodeIndex dr = return $ mconcat ]) ] -encodeServiceList :: [Service] -> HTMLEncoder a +encodeServiceList :: [Service] -> HTMLEncoder a encodeServiceList srvs = do lm <- getLinkManager return $ @@ -262,8 +262,8 @@ productType tp = _ -> [Some tp] encodeExercise :: Exercise a -> HTMLEncoder a -encodeExercise ex = do - lm <- getLinkManager +encodeExercise ex = do + lm <- getLinkManager return $ mconcat [ generalInfo lm , h2 "Example exercises" @@ -392,7 +392,7 @@ showRating lm = rec (5::Int) | a == 1 = "star_2.png" | otherwise = "star_3.png" -encodeRuleList :: [Rule (Context a)] -> HTMLEncoder a +encodeRuleList :: [Rule (Context a)] -> HTMLEncoder a encodeRuleList rs = withExercise $ \ex -> do lm <- getLinkManager let (rs1, rs2) = partition isBuggy rs @@ -444,7 +444,7 @@ encodeRule r = withExercise $ \ex -> ] encodeExampleList :: [(Difficulty, Context a)] -> HTMLEncoder a -encodeExampleList pairs = withExercise $ \ex -> do +encodeExampleList pairs = withExercise $ \ex -> do lm <- getLinkManager return $ mconcat $ h2 "Examples" : @@ -490,7 +490,7 @@ htmlDerivation d = withExercise $ \ex -> do return $ htmlDerivationWith before forStep forTerm (diffEnvironment d) htmlState :: State a -> HTMLEncoder a -htmlState state = do +htmlState state = do lm <- getLinkManager return $ para $ container $ background LightGray $ para $ stateLink lm state @@ -586,8 +586,8 @@ htmlDerivationWith before forStep forTerm d = before : forTerm (firstTerm d) : [ forStep s <> forTerm a | (_, s, a) <- triples d ] -htmlFirsts :: [(StepInfo a, State a)] -> HTMLEncoder a -htmlFirsts xs = +htmlFirsts :: [(StepInfo a, State a)] -> HTMLEncoder a +htmlFirsts xs = h2 "Firsts" <> ul [ keyValueTable [ ("Rule", string $ showId r) diff --git a/src/Ideas/Encoding/EncoderJSON.hs b/src/Ideas/Encoding/EncoderJSON.hs index 4c2ed2bd..7d9658a5 100644 --- a/src/Ideas/Encoding/EncoderJSON.hs +++ b/src/Ideas/Encoding/EncoderJSON.hs @@ -19,8 +19,8 @@ import Control.Applicative hiding (Const) import Data.Maybe import Ideas.Common.Library hiding (exerciseId) import Ideas.Encoding.Encoder -import Ideas.Service.State import Ideas.Encoding.Request +import Ideas.Service.State import Ideas.Service.Types hiding (String) import Ideas.Text.JSON import Ideas.Utils.Prelude (distinct) @@ -101,7 +101,7 @@ encodeContext ctx = f . useJSONTerm <$> getRequest <*> getExercise f False ex = String $ prettyPrinterContext ex ctx encodeState :: State a -> JSONEncoder a -encodeState st = +encodeState st = let ctx = stateContext st get f = String (fromMaybe "" (f st)) make pp env = Array $ diff --git a/src/Ideas/Encoding/EncoderXML.hs b/src/Ideas/Encoding/EncoderXML.hs index 1bb13527..38095e16 100644 --- a/src/Ideas/Encoding/EncoderXML.hs +++ b/src/Ideas/Encoding/EncoderXML.hs @@ -25,11 +25,11 @@ import Data.Monoid import Ideas.Common.Library hiding (exerciseId) import Ideas.Encoding.Encoder import Ideas.Encoding.OpenMathSupport +import Ideas.Encoding.Request hiding (XML) import Ideas.Encoding.RulesInfo (rulesInfoXML) import Ideas.Encoding.StrategyInfo import Ideas.Service.Diagnose import Ideas.Service.FeedbackScript.Syntax -import Ideas.Encoding.Request hiding (XML) import Ideas.Service.State import Ideas.Service.Types import Ideas.Text.OpenMath.Object @@ -135,7 +135,7 @@ buildExpression useOM ex where msg s = error ("Error encoding term in OpenMath: " ++ s) -encodeLocation :: Location -> XMLEncoder a +encodeLocation :: Location -> XMLEncoder a encodeLocation loc = "location" .=. show loc encodeEnvironment :: HasEnvironment env => env -> XMLEncoder a @@ -189,7 +189,7 @@ encodeText txt = do _ -> text item encodeMessage :: FeedbackText.Message -> XMLEncoder a -encodeMessage msg = +encodeMessage msg = element "message" [ case FeedbackText.accept msg of Just b -> "accept" .=. showBool b diff --git a/src/Ideas/Encoding/Logging.hs b/src/Ideas/Encoding/Logging.hs index 3f3132f2..2d7bf1a0 100644 --- a/src/Ideas/Encoding/Logging.hs +++ b/src/Ideas/Encoding/Logging.hs @@ -239,4 +239,4 @@ selectFrom database table columns f = do xs <- mapM (f . map fromSql) rows disconnect con return xs -#endif +#endif \ No newline at end of file diff --git a/src/Ideas/Main/Default.hs b/src/Ideas/Main/Default.hs index eace778b..89e5b1f0 100644 --- a/src/Ideas/Main/Default.hs +++ b/src/Ideas/Main/Default.hs @@ -35,6 +35,7 @@ import Ideas.Service.DomainReasoner import Ideas.Service.FeedbackScript.Analysis import Ideas.Service.ServiceList import Ideas.Service.Types (Service) +import Ideas.Text.XML.Unicode (decoding) import Ideas.Utils.BlackBoxTests import Ideas.Utils.Prelude import Ideas.Utils.TestSuite @@ -65,7 +66,7 @@ defaultCGI options dr = CGI.run $ \req respond -> do -- query environment let script = fromMaybe "" (findHeader "CGI-Script-Name" req) -- get name of binary addr = fromMaybe "" (findHeader "REMOTE_ADDR" req) -- the IP address of the remote host - input <- inputOrDefault req + input <- inputOrDefault req >>= decoding -- process request (preq, txt, ctp) <- process (optionCgiBin script options) dr input @@ -121,7 +122,7 @@ defaultCommandLine options dr cmdLineOptions = do processDatabase dr database InputFile file -> withBinaryFile file ReadMode $ \h -> do - input <- hGetContents h + input <- hGetContents h >>= decoding (req, txt, _) <- process options dr input putStrLn txt when (PrintLog `elem` cmdLineOptions) $ do @@ -166,7 +167,7 @@ process options dr input = do makeTestRunner :: DomainReasoner -> String -> IO String makeTestRunner dr input = do - (_, out, _) <- process mempty dr input + (_, out, _) <- decoding input >>= process mempty dr return out addVersion :: DomainReasoner -> DomainReasoner diff --git a/src/Ideas/Main/Revision.hs b/src/Ideas/Main/Revision.hs index 26f82428..ced13197 100644 --- a/src/Ideas/Main/Revision.hs +++ b/src/Ideas/Main/Revision.hs @@ -8,4 +8,4 @@ ideasRevision :: String ideasRevision = "6ed63bb8d0f08b17fcedc033b06da0d3fc2018a1" ideasLastChanged :: String -ideasLastChanged = "Wed Aug 14 14:52:07 2019 +0200" +ideasLastChanged = "Wed Aug 14 14:52:07 2019 +0200" \ No newline at end of file diff --git a/src/Ideas/Text/HTML.hs b/src/Ideas/Text/HTML.hs index fcdcfe43..58a4856a 100644 --- a/src/Ideas/Text/HTML.hs +++ b/src/Ideas/Text/HTML.hs @@ -35,8 +35,8 @@ import Data.List import Data.Monoid import Ideas.Text.XML import Prelude hiding (div) -import qualified Ideas.Text.XML as XML import qualified Data.Map as M +import qualified Ideas.Text.XML as XML type HTMLBuilder = XMLBuilder @@ -60,7 +60,7 @@ instance ToHTML () where instance (ToHTML a, ToHTML b) => ToHTML (a, b) where toHTML (a, b) = toHTML a <#> toHTML b - + instance (ToHTML a, ToHTML b, ToHTML c) => ToHTML (a, b, c) where toHTML (a, b, c) = toHTML a <#> toHTML b <#> toHTML c @@ -157,13 +157,13 @@ ttText :: BuildXML a => String -> a ttText = tt . string ul :: BuildXML a => [a] -> a -ul xs +ul xs | null xs = mempty | otherwise = element "ul" (map (tag "li") xs) -- | First argument indicates whether the table has a header or not table :: BuildXML a => Bool -> [[a]] -> a -table b rows +table b rows | null rows = mempty | otherwise = element "table" $ ("border" .=. "1") : @@ -216,7 +216,7 @@ highlightXML nice f [] = mempty f ('<':'/':xs) = g " f xs + f (x:xs) = string [x] <> f xs -- find > g start acc [] = string (start ++ reverse acc) @@ -239,7 +239,7 @@ highlightXML nice orange a = tag "font" ("color" .=. "orange" <> a) green a = tag "font" ("color" .=. "green" <> a) - {- + {- f [] = [] f list@(x:xs) diff --git a/src/Ideas/Text/JSON.hs b/src/Ideas/Text/JSON.hs index bf8bf832..5f1e38f1 100644 --- a/src/Ideas/Text/JSON.hs +++ b/src/Ideas/Text/JSON.hs @@ -163,7 +163,7 @@ parseJSON = parseSimple json , Boolean True <$ P.reserved lexer "true" , Boolean False <$ P.reserved lexer "false" , Number . either I D <$> naturalOrFloat -- redefined in Ideas.Text.Parsing - , String . fromMaybe [] . UTF8.decodeM <$> P.stringLiteral lexer + , String <$> P.stringLiteral lexer , Array <$> P.brackets lexer (sepBy json (P.comma lexer)) , Object <$> P.braces lexer (sepBy keyValue (P.comma lexer)) ] diff --git a/src/Ideas/Text/MathML.hs b/src/Ideas/Text/MathML.hs index dbfb77cc..fd216b49 100644 --- a/src/Ideas/Text/MathML.hs +++ b/src/Ideas/Text/MathML.hs @@ -77,20 +77,20 @@ xml2mathml = rec "mtext" -> return (MText (getData xml)) "mroot" -> case children xml of [c, d] -> MRoot <$> rec c <*> rec d - _ -> fail "invalid mroot" + _ -> fail "invalid mroot" "msup" -> case children xml of [c, d] -> MSup <$> rec c <*> rec d _ -> fail "invalid msup" "msub" -> case children xml of [c, d] -> MSub <$> rec c <*> rec d _ -> fail "invalid msub" - "msubsup" -> case children xml of + "msubsup" -> case children xml of [c, d, e] -> MSubSup <$> rec c <*> rec d <*> rec e _ -> fail "invalid msubsup" - "mfrac" -> case children xml of + "mfrac" -> case children xml of [c, d] -> MFrac <$> rec c <*> rec d _ -> fail "invalid mfrac" - "mfenced" -> case children xml of + "mfenced" -> case children xml of [c] -> MFenced (fromMaybe "(" (findAttribute "open" xml)) (fromMaybe ")" (findAttribute "close" xml)) <$> rec c _ -> fail "invalid mfenced" "mspace" -> return MSpace diff --git a/src/Ideas/Text/OpenMath/Object.hs b/src/Ideas/Text/OpenMath/Object.hs index 4cbcdaae..f2eeeab4 100644 --- a/src/Ideas/Text/OpenMath/Object.hs +++ b/src/Ideas/Text/OpenMath/Object.hs @@ -85,7 +85,7 @@ xml2omobj xmlTop s <- findAttribute "name" xml return (OMV s) - "OMBIND" -> + "OMBIND" -> case children xml of [x1, x2, x3] -> do y1 <- rec x1 diff --git a/src/Ideas/Text/XML.hs b/src/Ideas/Text/XML.hs index f3bc5e97..423240f3 100644 --- a/src/Ideas/Text/XML.hs +++ b/src/Ideas/Text/XML.hs @@ -44,17 +44,17 @@ import Data.String import Ideas.Text.XML.Document (escape, Name, prettyElement) import Ideas.Text.XML.Parser (document) import Ideas.Text.XML.Unicode -import Ideas.Utils.Parsing (parseSimple) import Ideas.Utils.Decoding +import Ideas.Utils.Parsing (parseSimple) +import System.IO import qualified Data.Map as M import qualified Data.Sequence as Seq import qualified Ideas.Text.XML.Document as D -import System.IO ------------------------------------------------------------------------------- -- XML types --- invariants content: no two adjacent Lefts, no Left with empty string, +-- invariants content: no two adjacent Lefts, no Left with empty string, -- valid tag/attribute names data XML = Tag { name :: Name @@ -75,8 +75,7 @@ data Attribute = Name := String -- Parsing XML parseXML :: String -> Either String XML -parseXML xs = do - input <- decoding xs +parseXML input = do doc <- parseSimple document input return (fromXMLDoc doc) @@ -90,7 +89,7 @@ fromXMLDoc doc = fromElement (D.root doc) where fromElement (D.Element n as c) = makeXML n (fromAttributes as <> fromContent c) - + fromAttributes = mconcat . map fromAttribute fromAttribute (n D.:= v) = @@ -177,7 +176,7 @@ isName :: String -> Bool isName [] = False isName (x:xs) = (isLetter x || x `elem` "_:") && all isNameChar xs -isNameChar :: Char -> Bool +isNameChar :: Char -> Bool isNameChar c = any ($ c) [isLetter, isDigit, isCombiningChar, isExtender, (`elem` ".-_:")] -- local helper: merge attributes, but preserve order @@ -232,7 +231,6 @@ findAttribute s (Tag _ as _) = children :: XML -> [XML] children e = [ c | Right c <- content e ] - findChildren :: String -> XML -> [XML] findChildren s = filter ((==s) . name) . children @@ -268,7 +266,7 @@ decodeAttribute s = get >>= \xml -> hasName (n := _) = n == s decodeChild :: Name -> Decoder env XML a -> Decoder env XML a -decodeChild s p = get >>= \xml -> +decodeChild s p = get >>= \xml -> case break hasName (content xml) of (xs, Right y:ys) -> do put y @@ -280,7 +278,7 @@ decodeChild s p = get >>= \xml -> hasName = either (const False) ((==s) . name) decodeFirstChild :: Name -> Decoder env XML a -> Decoder env XML a -decodeFirstChild s p = get >>= \xml -> +decodeFirstChild s p = get >>= \xml -> case content xml of Right y:ys | name y == s -> do put y @@ -306,7 +304,7 @@ instance ToXML a => ToXML (Maybe a) where builderXML :: (ToXML a, BuildXML b) => a -> b builderXML = builder . toXML - + class ToXML a => InXML a where fromXML :: Monad m => XML -> m a listFromXML :: Monad m => XML -> m [a] @@ -353,15 +351,15 @@ fromBuilder m = _runTests :: IO () _runTests = do - forM_ [testDataP, testAttrP, testDataB, testAttrB] $ \f -> + forM_ [testDataP, testAttrP, testDataB, testAttrB] $ \f -> pp $ map f tests - forM_ [mkPD, mkPA, mkBD, mkBA] $ \f -> + forM_ [mkPD, mkPA, mkBD, mkBA] $ \f -> pp $ map (testXML . f) tests where pp = putStrLn . map (\b -> if b then '.' else 'X') tests :: [String] - tests = + tests = [ "input" , "<>&"'" , "<>&'\"" @@ -378,7 +376,7 @@ _runTests = do testAttrB s = let xml = mkBA s in findAttribute "a" xml == Just s testXML :: XML -> Bool - testXML xml = + testXML xml = case parseXML (compactXML xml) of Left msg -> error msg Right a -> a == xml diff --git a/src/Ideas/Text/XML/Parser.hs b/src/Ideas/Text/XML/Parser.hs index 884d78f0..bde4bb46 100644 --- a/src/Ideas/Text/XML/Parser.hs +++ b/src/Ideas/Text/XML/Parser.hs @@ -131,7 +131,7 @@ attValue = doubleQuoted (p "<&\"") <|> singleQuoted (p "<&'") -- [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") systemLiteral :: Parser String systemLiteral = doubleQuoted (p "\"") <|> singleQuoted (p "'") - where + where p :: String -> Parser String p s = many (noneOf s) diff --git a/src/Ideas/Utils/Decoding.hs b/src/Ideas/Utils/Decoding.hs index 50a34aaf..5292a383 100644 --- a/src/Ideas/Utils/Decoding.hs +++ b/src/Ideas/Utils/Decoding.hs @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -module Ideas.Utils.Decoding +module Ideas.Utils.Decoding ( Decoder, runDecoder, symbol , Encoder, runEncoder , Error, runError, runErrorM @@ -21,8 +21,8 @@ module Ideas.Utils.Decoding import Control.Applicative import Control.Monad -import Control.Monad.State import Control.Monad.Reader +import Control.Monad.State import Data.Semigroup as Sem ------------------------------------------------------------------- diff --git a/src/Ideas/Utils/QuickCheck.hs b/src/Ideas/Utils/QuickCheck.hs index 8b7d3b91..d2c4615e 100644 --- a/src/Ideas/Utils/QuickCheck.hs +++ b/src/Ideas/Utils/QuickCheck.hs @@ -25,8 +25,8 @@ module Ideas.Utils.QuickCheck import Control.Arrow import Control.Monad -import Data.Semigroup as Sem import Data.Ratio +import Data.Semigroup as Sem import Test.QuickCheck ---------------------------------------------------------