ideas 1.8 → 1.9.1
raw patch · 89 files changed
+4132/−2678 lines, 89 filesdep ~Diffdep ~HDBCdep ~HDBC-sqlite3
Dependency ranges changed: Diff, HDBC, HDBC-sqlite3, QuickCheck, base, blaze-builder, bytestring, case-insensitive, containers, directory, filepath, http-types, mtl, network, parsec, random, streaming-commons, time, uniplate, wai, wl-pprint
Files
- CHANGELOG.txt +13/−1
- ideas.cabal +209/−191
- src/Ideas/Common/Classes.hs +2/−6
- src/Ideas/Common/Constraint.hs +40/−33
- src/Ideas/Common/Context.hs +14/−12
- src/Ideas/Common/Derivation.hs +47/−16
- src/Ideas/Common/Examples.hs +224/−225
- src/Ideas/Common/Exercise.hs +477/−421
- src/Ideas/Common/Rewriting/AutoTerm.hs +120/−123
- src/Ideas/Common/Rewriting/Confluence.hs +1/−1
- src/Ideas/Common/Rewriting/Difference.hs +1/−1
- src/Ideas/Common/Rewriting/RewriteRule.hs +5/−5
- src/Ideas/Common/Rewriting/Term.hs +7/−309
- src/Ideas/Common/Rewriting/Term/Class.hs +249/−0
- src/Ideas/Common/Rewriting/Term/Data.hs +84/−0
- src/Ideas/Common/Rewriting/Term/Decoder.hs +106/−0
- src/Ideas/Common/Rewriting/Unification.hs +9/−9
- src/Ideas/Common/Rule/Abstract.hs +4/−4
- src/Ideas/Common/Rule/Recognizer.hs +4/−4
- src/Ideas/Common/Rule/Transformation.hs +4/−1
- src/Ideas/Common/Strategy/Abstract.hs +8/−9
- src/Ideas/Common/Strategy/CyclicTree.hs +1/−2
- src/Ideas/Common/Strategy/Prefix.hs +2/−2
- src/Ideas/Common/Strategy/StrategyTree.hs +7/−7
- src/Ideas/Common/Strategy/Traversal.hs +0/−1
- src/Ideas/Common/Traversal/Tests.hs +0/−1
- src/Ideas/Common/View.hs +13/−11
- src/Ideas/Encoding/DecoderJSON.hs +76/−84
- src/Ideas/Encoding/DecoderXML.hs +61/−50
- src/Ideas/Encoding/Encoder.hs +21/−21
- src/Ideas/Encoding/EncoderHTML.hs +17/−18
- src/Ideas/Encoding/EncoderJSON.hs +37/−13
- src/Ideas/Encoding/EncoderXML.hs +38/−13
- src/Ideas/Encoding/Evaluator.hs +15/−10
- src/Ideas/Encoding/LinkManager.hs +5/−6
- src/Ideas/Encoding/Logging.hs +4/−3
- src/Ideas/Encoding/ModeJSON.hs +18/−15
- src/Ideas/Encoding/ModeXML.hs +23/−21
- src/Ideas/Encoding/NewDecoderJSON.hs +146/−0
- src/Ideas/Encoding/NewEncoderJSON.hs +159/−0
- src/Ideas/Encoding/NewModeJSON.hs +127/−0
- src/Ideas/Encoding/OpenMathSupport.hs +12/−16
- src/Ideas/Encoding/Options.hs +1/−0
- src/Ideas/Encoding/Request.hs +7/−7
- src/Ideas/Encoding/RulePresenter.hs +0/−1
- src/Ideas/Encoding/RulesInfo.hs +2/−2
- src/Ideas/Encoding/StrategyInfo.hs +8/−7
- src/Ideas/Main/CGI.hs +1/−0
- src/Ideas/Main/CmdLineOptions.hs +11/−10
- src/Ideas/Main/Default.hs +19/−17
- src/Ideas/Main/Revision.hs +3/−3
- src/Ideas/Service/Apply.hs +108/−0
- src/Ideas/Service/BasicServices.hs +14/−65
- src/Ideas/Service/Diagnose.hs +40/−25
- src/Ideas/Service/DomainReasoner.hs +12/−9
- src/Ideas/Service/FeedbackScript/Analysis.hs +2/−2
- src/Ideas/Service/FeedbackScript/Parser.hs +0/−1
- src/Ideas/Service/FeedbackScript/Run.hs +1/−1
- src/Ideas/Service/FeedbackText.hs +5/−4
- src/Ideas/Service/ServiceList.hs +10/−9
- src/Ideas/Service/State.hs +7/−4
- src/Ideas/Service/Submit.hs +1/−1
- src/Ideas/Service/Types.hs +5/−3
- src/Ideas/Text/HTML.hs +28/−11
- src/Ideas/Text/HTML/Templates.hs +21/−3
- src/Ideas/Text/HTML/W3CSS.hs +8/−1
- src/Ideas/Text/JSON.hs +10/−281
- src/Ideas/Text/JSON/Builder.hs +66/−0
- src/Ideas/Text/JSON/Class.hs +95/−0
- src/Ideas/Text/JSON/Data.hs +152/−0
- src/Ideas/Text/JSON/Decoder.hs +147/−0
- src/Ideas/Text/JSON/RPC.hs +97/−0
- src/Ideas/Text/MathML.hs +39/−54
- src/Ideas/Text/OpenMath/Object.hs +23/−52
- src/Ideas/Text/OpenMath/Tests.hs +8/−1
- src/Ideas/Text/UTF8.hs +28/−37
- src/Ideas/Text/XML.hs +111/−222
- src/Ideas/Text/XML/Attributes.hs +64/−0
- src/Ideas/Text/XML/Builder.hs +78/−0
- src/Ideas/Text/XML/Data.hs +163/−0
- src/Ideas/Text/XML/Decoder.hs +58/−0
- src/Ideas/Text/XML/Document.hs +47/−14
- src/Ideas/Text/XML/Parser.hs +6/−7
- src/Ideas/Text/XML/Unicode.hs +3/−3
- src/Ideas/Utils/BlackBoxTests.hs +37/−19
- src/Ideas/Utils/Decoding.hs +131/−91
- src/Ideas/Utils/Parsing.hs +2/−2
- src/Ideas/Utils/Prelude.hs +26/−32
- src/Ideas/Utils/TestSuite.hs +17/−12
CHANGELOG.txt view
@@ -1,4 +1,16 @@-Changelog ideas-1.7 => ideas-1.8+Changelog ideas-1.9.0 => ideas-1.9.1++* updating the Cabal specification version for Hackage publishing++Changelog ideas-1.8 => ideas-1.9++* build and test with GHC 9.6.7, 9.10.3, and 9.12.4+* replacing Travis CI with GitHub Actions+* reorganizing JSON, XML, OpenMath, and term decoding modules+* adding the Apply feedback service+* converting the tutorial build to Cabal and adding Docker support+* removing the obsolete Stack configuration+* fixing OpenMath decoding of formatted XML * support for automatically generated (generic) IsTerm instances * introducing Examples data type for exercise records (unifying expr lists/generators)
ideas.cabal view
@@ -1,191 +1,209 @@-name: ideas -version: 1.8 -synopsis: Feedback services for intelligent tutoring systems -homepage: http://ideas.cs.uu.nl/ -description: - - Ideas (Interactive Domain-specific Exercise Assistants) is a joint research - project between the Open University of the Netherlands and Utrecht - University. The project's goal is to use software and compiler technology to - build state-of-the-art components for intelligent tutoring systems (ITS) and - learning environments. The 'ideas' software package provides a generic - framework for constructing the expert knowledge module (also known as a - domain reasoner) for an ITS or learning environment. Domain knowledge is - offered as a set of feedback services that are used by external tools such - as the digital mathematical environment (DME), MathDox, and the Math-Bridge - system. We have developed several domain reasoners based on this framework, - including reasoners for mathematics, linear algebra, logic, learning Haskell - (the Ask-Elle programming tutor) and evaluating Haskell expressions, and for - practicing communication skills (the serious game Communicate!). - -category: Education -copyright: (c) 2019 -license: Apache-2.0 -license-file: LICENSE.txt -author: Bastiaan Heeren, Alex Gerdes, Johan Jeuring -maintainer: bastiaan.heeren@ou.nl -stability: provisional -extra-source-files: NOTICE.txt, CHANGELOG.txt -build-type: Simple -cabal-version: >= 1.8.0.2 -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2 - -source-repository head - type: git - location: https://github.com/ideas-edu/ideas.git - -flag logging - description: enable support for logging interactions to a sqlite3 database - default: True - --------------------------------------------------------------------------------- - -Library - if flag(logging) { - cpp-options: -DDB - Build-Depends: HDBC, HDBC-sqlite3 - } - - ghc-options: -Wall - hs-source-dirs: src - Build-Depends: - base >= 4.8 && < 5, - blaze-builder >= 0.4, - bytestring, - case-insensitive, - QuickCheck >= 2.8 && < 2.12, - Diff, - containers, - directory, - filepath, - http-types, - mtl, - network, - parsec, - random, - streaming-commons < 0.2, - time, - uniplate, - wai, - wl-pprint - - if !impl(ghc >= 8.0) - Build-Depends: semigroups == 0.18.* - - Exposed-modules: - Ideas.Common.Classes - Ideas.Common.Constraint - Ideas.Common.Context - Ideas.Common.Derivation - Ideas.Common.DerivationTree - Ideas.Common.Environment - Ideas.Common.Examples - Ideas.Common.Exercise - Ideas.Common.ExerciseTests - Ideas.Common.Id - Ideas.Common.Library - Ideas.Common.Predicate - Ideas.Common.Rewriting - Ideas.Common.Rewriting.AC - Ideas.Common.Rewriting.AutoTerm - Ideas.Common.Rewriting.Confluence - Ideas.Common.Rewriting.Difference - Ideas.Common.Rewriting.RewriteRule - Ideas.Common.Rewriting.Substitution - Ideas.Common.Rewriting.Term - Ideas.Common.Rewriting.Unification - Ideas.Common.Rule - Ideas.Common.Rule.Abstract - Ideas.Common.Rule.Parameter - Ideas.Common.Rule.Recognizer - Ideas.Common.Rule.Transformation - Ideas.Common.Strategy - Ideas.Common.Strategy.Abstract - Ideas.Common.Strategy.Choice - Ideas.Common.Strategy.Combinators - Ideas.Common.Strategy.Configuration - Ideas.Common.Strategy.CyclicTree - Ideas.Common.Strategy.Derived - Ideas.Common.Strategy.Legacy - Ideas.Common.Strategy.Location - Ideas.Common.Strategy.Prefix - Ideas.Common.Strategy.Process - Ideas.Common.Strategy.Sequence - Ideas.Common.Strategy.StrategyTree - Ideas.Common.Strategy.Symbol - Ideas.Common.Strategy.Traversal - Ideas.Common.Traversal.Iterator - Ideas.Common.Traversal.Navigator - Ideas.Common.Traversal.Tests - Ideas.Common.Traversal.Utils - Ideas.Common.View - Ideas.Encoding.DecoderJSON - Ideas.Encoding.DecoderXML - Ideas.Encoding.Encoder - Ideas.Encoding.EncoderHTML - Ideas.Encoding.EncoderJSON - Ideas.Encoding.EncoderXML - Ideas.Encoding.Evaluator - Ideas.Encoding.LinkManager - Ideas.Encoding.Logging - Ideas.Encoding.ModeJSON - Ideas.Encoding.ModeXML - Ideas.Encoding.OpenMathSupport - Ideas.Encoding.Options - Ideas.Encoding.Request - Ideas.Encoding.RulePresenter - Ideas.Encoding.RulesInfo - Ideas.Encoding.StrategyInfo - Ideas.Main.CGI - Ideas.Main.CmdLineOptions - Ideas.Main.Default - Ideas.Main.Revision - Ideas.Service.BasicServices - Ideas.Service.Diagnose - Ideas.Service.DomainReasoner - Ideas.Service.FeedbackScript.Analysis - Ideas.Service.FeedbackScript.Parser - Ideas.Service.FeedbackScript.Run - Ideas.Service.FeedbackScript.Syntax - Ideas.Service.FeedbackText - Ideas.Service.ProblemDecomposition - Ideas.Service.ServiceList - Ideas.Service.State - Ideas.Service.Submit - Ideas.Service.Types - Ideas.Text.HTML - Ideas.Text.HTML.Templates - Ideas.Text.HTML.W3CSS - Ideas.Text.JSON - Ideas.Text.Latex - Ideas.Text.MathML - Ideas.Text.OpenMath.Dictionary.Arith1 - Ideas.Text.OpenMath.Dictionary.Calculus1 - Ideas.Text.OpenMath.Dictionary.Fns1 - Ideas.Text.OpenMath.Dictionary.Linalg2 - Ideas.Text.OpenMath.Dictionary.List1 - Ideas.Text.OpenMath.Dictionary.Logic1 - Ideas.Text.OpenMath.Dictionary.Nums1 - Ideas.Text.OpenMath.Dictionary.Quant1 - Ideas.Text.OpenMath.Dictionary.Relation1 - Ideas.Text.OpenMath.Dictionary.Transc1 - Ideas.Text.OpenMath.FMP - Ideas.Text.OpenMath.Object - Ideas.Text.OpenMath.Symbol - Ideas.Text.OpenMath.Tests - Ideas.Text.UTF8 - Ideas.Text.XML - Ideas.Text.XML.Document - Ideas.Text.XML.Parser - Ideas.Text.XML.Unicode - Ideas.Utils.BlackBoxTests - Ideas.Utils.Decoding - Ideas.Utils.Parsing - Ideas.Utils.Prelude - Ideas.Utils.QuickCheck - Ideas.Utils.StringRef - Ideas.Utils.TestSuite - Ideas.Utils.Typeable - Ideas.Utils.Uniplate - --------------------------------------------------------------------------------- +name: ideas+version: 1.9.1+synopsis: Feedback services for intelligent tutoring systems+homepage: http://ideas.cs.uu.nl/+description:++ Ideas (Interactive Domain-specific Exercise Assistants) is a joint research+ project between the Open University of the Netherlands and Utrecht+ University. The project's goal is to use software and compiler technology to+ build state-of-the-art components for intelligent tutoring systems (ITS) and+ learning environments. The 'ideas' software package provides a generic+ framework for constructing the expert knowledge module (also known as a+ domain reasoner) for an ITS or learning environment. Domain knowledge is+ offered as a set of feedback services that are used by external tools such+ as the digital mathematical environment (DME), MathDox, and the Math-Bridge+ system. We have developed several domain reasoners based on this framework,+ including reasoners for mathematics, linear algebra, logic, learning Haskell+ (the Ask-Elle programming tutor) and evaluating Haskell expressions, and for+ practicing communication skills (the serious game Communicate!).++category: Education+copyright: (c) 2019+license: Apache-2.0+license-file: LICENSE.txt+author: Bastiaan Heeren †, Alex Gerdes, Johan Jeuring+maintainer: alexg@chalmers.se+stability: provisional+extra-source-files: NOTICE.txt, CHANGELOG.txt+build-type: Simple+cabal-version: >= 1.10+tested-with: GHC == 9.6.7, GHC == 9.10.3, GHC == 9.12.4++source-repository head+ type: git+ location: https://github.com/ideas-edu/ideas.git++flag logging+ description: enable support for logging interactions to a sqlite3 database+ default: True++--------------------------------------------------------------------------------++Library+ if flag(logging) {+ cpp-options: -DDB+ Build-Depends: HDBC >= 2.4 && < 2.5,+ HDBC-sqlite3 >= 2.3 && < 2.4+ }++ ghc-options: -Wall+ default-language: Haskell2010+ hs-source-dirs: src+ Build-Depends:+ base < 4.22,+ blaze-builder >= 0.4 && < 0.5,+ bytestring >= 0.11 && < 0.13,+ case-insensitive >= 1.2 && < 1.3,+ QuickCheck >= 2.14 && < 2.19,+ Diff >= 0.4 && < 0.6,+ containers >= 0.6 && < 0.8,+ directory >= 1.3 && < 1.4,+ filepath >= 1.4 && < 1.6,+ http-types >= 0.12 && < 0.13,+ mtl >= 2.3 && < 2.4,+ network >= 3.1 && < 3.3,+ parsec >= 3.1 && < 3.2,+ random >= 1.3 && < 1.4,+ streaming-commons >= 0.2 && < 0.3,+ time >= 1.12 && < 1.15,+ uniplate >= 1.6 && < 1.7,+ wai >= 3.2 && < 3.3,+ wl-pprint >= 1.2 && < 1.3++ if !impl(ghc >= 8.0)+ Build-Depends: semigroups == 0.18.*++ Exposed-modules:+ Ideas.Common.Classes+ Ideas.Common.Constraint+ Ideas.Common.Context+ Ideas.Common.Derivation+ Ideas.Common.DerivationTree+ Ideas.Common.Environment+ Ideas.Common.Examples+ Ideas.Common.Exercise+ Ideas.Common.ExerciseTests+ Ideas.Common.Id+ Ideas.Common.Library+ Ideas.Common.Predicate+ Ideas.Common.Rewriting+ Ideas.Common.Rewriting.AC+ Ideas.Common.Rewriting.AutoTerm+ Ideas.Common.Rewriting.Confluence+ Ideas.Common.Rewriting.Difference+ Ideas.Common.Rewriting.RewriteRule+ Ideas.Common.Rewriting.Substitution+ Ideas.Common.Rewriting.Term+ Ideas.Common.Rewriting.Term.Class+ Ideas.Common.Rewriting.Term.Data+ Ideas.Common.Rewriting.Term.Decoder+ Ideas.Common.Rewriting.Unification+ Ideas.Common.Rule+ Ideas.Common.Rule.Abstract+ Ideas.Common.Rule.Parameter+ Ideas.Common.Rule.Recognizer+ Ideas.Common.Rule.Transformation+ Ideas.Common.Strategy+ Ideas.Common.Strategy.Abstract+ Ideas.Common.Strategy.Choice+ Ideas.Common.Strategy.Combinators+ Ideas.Common.Strategy.Configuration+ Ideas.Common.Strategy.CyclicTree+ Ideas.Common.Strategy.Derived+ Ideas.Common.Strategy.Legacy+ Ideas.Common.Strategy.Location+ Ideas.Common.Strategy.Prefix+ Ideas.Common.Strategy.Process+ Ideas.Common.Strategy.Sequence+ Ideas.Common.Strategy.StrategyTree+ Ideas.Common.Strategy.Symbol+ Ideas.Common.Strategy.Traversal+ Ideas.Common.Traversal.Iterator+ Ideas.Common.Traversal.Navigator+ Ideas.Common.Traversal.Tests+ Ideas.Common.Traversal.Utils+ Ideas.Common.View+ Ideas.Encoding.DecoderJSON+ Ideas.Encoding.DecoderXML+ Ideas.Encoding.Encoder+ Ideas.Encoding.EncoderHTML+ Ideas.Encoding.EncoderJSON+ Ideas.Encoding.EncoderXML+ Ideas.Encoding.Evaluator+ Ideas.Encoding.LinkManager+ Ideas.Encoding.Logging+ Ideas.Encoding.ModeJSON+ Ideas.Encoding.ModeXML+ Ideas.Encoding.NewModeJSON+ Ideas.Encoding.NewEncoderJSON+ Ideas.Encoding.NewDecoderJSON+ Ideas.Encoding.OpenMathSupport+ Ideas.Encoding.Options+ Ideas.Encoding.Request+ Ideas.Encoding.RulePresenter+ Ideas.Encoding.RulesInfo+ Ideas.Encoding.StrategyInfo+ Ideas.Main.CGI+ Ideas.Main.CmdLineOptions+ Ideas.Main.Default+ Ideas.Main.Revision+ Ideas.Service.Apply+ Ideas.Service.BasicServices+ Ideas.Service.Diagnose+ Ideas.Service.DomainReasoner+ Ideas.Service.FeedbackScript.Analysis+ Ideas.Service.FeedbackScript.Parser+ Ideas.Service.FeedbackScript.Run+ Ideas.Service.FeedbackScript.Syntax+ Ideas.Service.FeedbackText+ Ideas.Service.ProblemDecomposition+ Ideas.Service.ServiceList+ Ideas.Service.State+ Ideas.Service.Submit+ Ideas.Service.Types+ Ideas.Text.HTML+ Ideas.Text.HTML.Templates+ Ideas.Text.HTML.W3CSS+ Ideas.Text.JSON+ Ideas.Text.JSON.Builder+ Ideas.Text.JSON.Class+ Ideas.Text.JSON.Data+ Ideas.Text.JSON.Decoder+ Ideas.Text.JSON.RPC+ Ideas.Text.Latex+ Ideas.Text.MathML+ Ideas.Text.OpenMath.Dictionary.Arith1+ Ideas.Text.OpenMath.Dictionary.Calculus1+ Ideas.Text.OpenMath.Dictionary.Fns1+ Ideas.Text.OpenMath.Dictionary.Linalg2+ Ideas.Text.OpenMath.Dictionary.List1+ Ideas.Text.OpenMath.Dictionary.Logic1+ Ideas.Text.OpenMath.Dictionary.Nums1+ Ideas.Text.OpenMath.Dictionary.Quant1+ Ideas.Text.OpenMath.Dictionary.Relation1+ Ideas.Text.OpenMath.Dictionary.Transc1+ Ideas.Text.OpenMath.FMP+ Ideas.Text.OpenMath.Object+ Ideas.Text.OpenMath.Symbol+ Ideas.Text.OpenMath.Tests+ Ideas.Text.UTF8+ Ideas.Text.XML+ Ideas.Text.XML.Attributes+ Ideas.Text.XML.Builder+ Ideas.Text.XML.Data+ Ideas.Text.XML.Decoder+ Ideas.Text.XML.Document+ Ideas.Text.XML.Parser+ Ideas.Text.XML.Unicode+ Ideas.Utils.BlackBoxTests+ Ideas.Utils.Decoding+ Ideas.Utils.Parsing+ Ideas.Utils.Prelude+ Ideas.Utils.QuickCheck+ Ideas.Utils.StringRef+ Ideas.Utils.TestSuite+ Ideas.Utils.Typeable+ Ideas.Utils.Uniplate++--------------------------------------------------------------------------------
src/Ideas/Common/Classes.hs view
@@ -14,7 +14,7 @@ module Ideas.Common.Classes ( -- * Type class Apply - Apply(applyAll), apply, applicable, applyD, applyM, applyList + Apply(applyAll), apply, applicable, applyD, applyList -- * Type class Container , Container(singleton, getSingleton) -- * Type class BiArrow @@ -54,12 +54,8 @@ applyD :: Apply t => t a -> a -> a applyD ta a = fromMaybe a (apply ta a) --- | Same as apply, except that the result (at most one) is returned in some monad -applyM :: (Apply t, Monad m) => t a -> a -> m a -applyM ta = maybe (fail "applyM") return . apply ta - applyList :: Apply t => [t a] -> a -> Maybe a -applyList xs a = foldl (\m r -> m >>= applyM r) (Just a) xs +applyList xs a = foldl (\m r -> m >>= apply r) (Just a) xs ----------------------------------------------------------- -- Type class Container
src/Ideas/Common/Constraint.hs view
@@ -15,11 +15,11 @@ module Ideas.Common.Constraint ( Constraint, makeConstraint , isRelevant, isSatisfied, isViolated, getResult - , Result(..), relevance + , Result(..), violation, relevance + , subConstraints ) where -import Control.Applicative -import Control.Monad +import Data.List import Ideas.Common.Id import Ideas.Common.View @@ -44,8 +44,8 @@ getId = constraintId changeId f r = r { constraintId = f (constraintId r) } -instance LiftView Constraint where - liftViewIn v (C n f) = C n (maybe Irrelevant (f . fst) . match v) +instance Lift Constraint where + liftWithM f (C n p) = C n (maybe Irrelevant (p . fst) . f) makeConstraint :: IsId n => n -> (a -> Result ()) -> Constraint a makeConstraint = C . newId @@ -68,47 +68,54 @@ isViolated :: Constraint a -> a -> Maybe String isViolated p a = case getResult p a of - Error s -> Just s - _ -> Nothing + Violation s -> Just s + _ -> Nothing --------------------------------------------------------------------------- -- Result -data Result a = Irrelevant | Error String | Ok a +data Result a = Irrelevant | Violation String | Ok a deriving Show instance Functor Result where - fmap _ Irrelevant = Irrelevant - fmap _ (Error msg) = Error msg - fmap f (Ok a) = Ok (f a) + fmap _ Irrelevant = Irrelevant + fmap _ (Violation msg) = Violation msg + fmap f (Ok a) = Ok (f a) instance Applicative Result where pure = Ok - Irrelevant <*> _ = Irrelevant - Error msg <*> _ = Error msg - Ok _ <*> Irrelevant = Irrelevant - Ok _ <*> Error msg = Error msg - Ok f <*> Ok a = Ok (f a) - -instance Alternative Result where - empty = Error "" - Irrelevant <|> r = r - Error msg <|> Error _ = Error msg -- left-biased - Error _ <|> r = r - Ok a <|> _ = Ok a + Irrelevant <*> _ = Irrelevant + Violation msg <*> _ = Violation msg + Ok _ <*> Irrelevant = Irrelevant + Ok _ <*> Violation msg = Violation msg + Ok f <*> Ok a = Ok (f a) instance Monad Result where - return = Ok - fail = Error - Irrelevant >>= _ = Irrelevant - Error msg >>= _ = Error msg - Ok a >>= f = f a + Irrelevant >>= _ = Irrelevant + Violation msg >>= _ = Violation msg + Ok a >>= f = f a -instance MonadPlus Result where - mzero = empty - mplus = (<|>) +violation :: String -> Result a +violation = Violation -- | Turn errors into irrelevant results relevance :: Result a -> Result a -relevance (Error _) = Irrelevant -relevance r = r+relevance (Violation _) = Irrelevant +relevance r = r + +-- to do: +-- * alle errors teruggeven +-- * locatie van error bijhouden +subConstraints :: IsId n => (b -> [(String, a)]) -> n -> Constraint a -> Constraint b +subConstraints f n c = makeConstraint n $ \p -> do + let results = [ (loc, getResult c a) | (loc, a) <- f p ] + case filter isError results of + [] | any isOk results -> Ok () + | otherwise -> Irrelevant + errs -> violation $ intercalate "," [ showId c ++ "." ++ loc ++ ":" ++ msg | (loc, Violation msg) <- errs ] + where + isError (_, Violation _) = True + isError _ = False + + isOk (_, Ok _) = True + isOk _ = False
src/Ideas/Common/Context.hs view
@@ -27,6 +27,7 @@ , liftToContext, contextView , use, useC, applyTop , currentTerm, changeTerm, replaceInContext, currentInContext, changeInContext + , setLocation ) where import Data.Maybe @@ -47,14 +48,13 @@ , getNavigator :: ContextNavigator a } -fromContext :: Monad m => Context a -> m a -fromContext = maybe (fail "fromContext") return . - currentNavigator . getNavigator . top +fromContext :: Context a -> Maybe a +fromContext = currentNavigator . getNavigator . top -fromContextWith :: Monad m => (a -> b) -> Context a -> m b +fromContextWith :: (a -> b) -> Context a -> Maybe b fromContextWith f = fmap f . fromContext -fromContextWith2 :: Monad m => (a -> b -> c) -> Context a -> Context b -> m c +fromContextWith2 :: (a -> b -> c) -> Context a -> Context b -> Maybe c fromContextWith2 f a b = f <$> fromContext a <*> fromContext b instance Eq a => Eq (Context a) where @@ -100,8 +100,7 @@ Simple :: Uniplate a => UniplateNavigator a -> ContextNavigator a NoNav :: a -> ContextNavigator a -liftCN :: Monad m => (forall b . Navigator b => b -> m b) - -> Context a -> m (Context a) +liftCN :: (forall b . Navigator b => b -> Maybe b) -> Context a -> Maybe (Context a) liftCN f (C env (TermNav a)) = C env . TermNav <$> f a liftCN f (C env (Simple a)) = C env . Simple <$> f a liftCN _ (C _ (NoNav _)) = fail "noNavigator" @@ -112,7 +111,7 @@ navLocation (NoNav _) = mempty currentNavigator :: ContextNavigator a -> Maybe a -currentNavigator (TermNav a) = matchM termView (current a) +currentNavigator (TermNav a) = match termView (current a) currentNavigator (Simple a) = Just (current a) currentNavigator (NoNav a) = Just a @@ -143,7 +142,7 @@ g = uncurry replaceInContext -- | Lift a rule to operate on a term in a context -liftToContext :: LiftView f => f a -> f (Context a) +liftToContext :: Lift f => f a -> f (Context a) liftToContext = liftViewIn contextView -- | Apply a function at top-level. Afterwards, try to return the focus @@ -152,10 +151,10 @@ applyTop f c = navigateTowards (location c) (changeInContext f (top c)) -use :: (LiftView f, IsTerm a, IsTerm b) => f a -> f (Context b) +use :: (Lift f, IsTerm a, IsTerm b) => f a -> f (Context b) use = useC . liftToContext -useC :: (LiftView f, IsTerm a, IsTerm b) => f (Context a) -> f (Context b) +useC :: (Lift f, IsTerm a, IsTerm b) => f (Context a) -> f (Context b) useC = liftViewIn (makeView f g) where f old@(C env a) = castT a >>= \b -> return (C env b, old) @@ -176,4 +175,7 @@ changeInContext f (C env a) = C env (changeNavigator f a) replaceInContext :: a -> Context a -> Context a -replaceInContext = changeInContext . const+replaceInContext = changeInContext . const + +setLocation :: Location -> Context a -> Context a +setLocation loc c = fromMaybe c (navigateTo loc c)
src/Ideas/Common/Derivation.hs view
@@ -20,15 +20,18 @@ , emptyDerivation, prepend, extend , merge, mergeBy, mergeStep -- * Conversion to/from list - , derivationToList, derivationFromList + , derivationToList, derivationFromList, derivationDecoder + -- * Equality + , eqDerivationBy -- * Querying a derivation , isEmpty, derivationLength, terms, steps, triples , firstTerm, lastTerm, lastStep, withoutLast + , updateFirstTerm, updateLastTerm , updateSteps, derivationM, splitStep ) where +import Control.Applicative import Data.Maybe -import Data.Monoid import Ideas.Common.Classes import Ideas.Common.Rewriting import qualified Data.Foldable as F @@ -52,8 +55,7 @@ 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" + termDecoder = tListWith (derivationDecoder termDecoder termDecoder) ----------------------------------------------------------------------------- -- Constructing a derivation @@ -68,12 +70,18 @@ extend (D a xs) p = D a (xs S.|> p) merge :: Eq a => Derivation s a -> Derivation s a -> Maybe (Derivation s a) -merge = mergeBy (==) +merge = mergeBy True (==) -mergeBy :: (a -> a -> Bool) -> Derivation s a -> Derivation s a -> Maybe (Derivation s a) -mergeBy eq d@(D a xs) (D b ys) - | eq (lastTerm d) b = Just $ D a (xs <> ys) - | otherwise = Nothing +-- the 'keepUpper' boolean indicates whether to keep the upper term in the middle (or the lower term) +mergeBy :: Bool -> (a -> a -> Bool) -> Derivation s a -> Derivation s a -> Maybe (Derivation s a) +mergeBy keepUpper eq d@(D a xs) d2@(D b ys) + | not (eq (lastTerm d) b) = Nothing + | keepUpper = Just $ D a (xs <> ys) + | otherwise = Just $ + case S.viewr xs of + S.EmptyR -> d2 + xs' S.:> (s, _) -> mergeStep (D a xs') s d2 + 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)) @@ -85,14 +93,27 @@ 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) +derivationFromList :: (b -> Maybe s) -> (b -> Maybe a) -> [b] -> Maybe (Derivation s a) derivationFromList f g = rec where - rec [] = fail "derivationFromList" + rec [] = Nothing rec [b] = emptyDerivation <$> g b rec (b1:b2:bs) = curry prepend <$> g b1 <*> f b2 <*> rec bs +derivationDecoder :: Alternative f => f s -> f a -> f (Derivation s a) +derivationDecoder tStep tTerm = f <$> tTerm <*> tSteps + where + f = foldl extend . emptyDerivation + tSteps = many ((,) <$> tStep <*> tTerm) + ----------------------------------------------------------------------------- +-- Equality + +eqDerivationBy :: Eq s => (a -> a -> Bool) -> Derivation s a -> Derivation s a -> Bool +eqDerivationBy f d1 d2 = + and (zipWith f (terms d1) (terms d2)) && steps d1 == steps d2 + +----------------------------------------------------------------------------- -- Querying a derivation -- | Tests whether the derivation is empty @@ -131,11 +152,21 @@ S.EmptyR -> d ys S.:> _ -> D a ys +updateFirstTerm :: (a -> a) -> Derivation s a -> Derivation s a +updateFirstTerm f (D a xs) = D (f a) xs + +updateLastTerm :: (a -> a) -> Derivation s a -> Derivation s a +updateLastTerm f (D a xs) = + case S.viewr xs of + S.EmptyR -> D (f a) S.empty + ys S.:> (s, b) -> D a (ys S.|> (s, f b)) + updateSteps :: (a -> s -> a -> t) -> Derivation s a -> Derivation t a -updateSteps f d = - let ts = [ f a b c | (a, b, c) <- triples d ] - x:xs = terms d - in D x (S.fromList (zip ts xs)) +updateSteps f d = case terms d of + [] -> error "Derivation.hs: the impossible has happened" + x:xs -> D x (S.fromList (zip ts xs)) + where + ts = [ f a b c | (a, b, c) <- triples d ] -- | Apply a monadic function to each term, and to each step derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m () @@ -147,4 +178,4 @@ S.EmptyL -> Nothing (s, b) S.:< ys -> Just (D a xs1, s, D b ys) where - (xs1, xs2) = S.breakl (p . fst) xs+ (xs1, xs2) = S.breakl (p . fst) xs
src/Ideas/Common/Examples.hs view
@@ -1,226 +1,225 @@------------------------------------------------------------------------------ --- Copyright 2019, Ideas project team. This file is distributed under the --- terms of the Apache License 2.0. For more information, see the files --- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- 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 --- 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 --- examples. --- ------------------------------------------------------------------------------ - -module Ideas.Common.Examples - ( -- * Examples type - Examples - -- * Constructing examples - , example, exampleList, examplesFor, examplesWithDifficulty - , random, group, forTesting - -- * Assigning difficulty - , difficulty, veryEasy, easy, medium, difficult, veryDifficult - -- * Transformations and queries - , isEmpty, size, flatten, groups - , topLevelExamples, topLevelRandoms, topLevelTests, topLevelRandomTests - , allExamples, allRandoms, allTests, allRandomTests - -- * Difficulty type - , Difficulty(..), readDifficulty - ) where - -import Data.Char -import Data.Maybe -import Data.Semigroup -import Ideas.Common.Id -import Test.QuickCheck - ------------------------------------------------------------------------------ --- Examples - -data Examples a = Examples - { groups :: [(Id, Examples a)] -- ^ Top-level groups - , items :: [Item a] - } - -instance Semigroup (Examples a) where - xs <> ys = Examples (groups xs <> groups ys) (items xs <> items ys) - -instance Monoid (Examples a) where - mempty = Examples [] [] - mappend = (<>) - -instance Functor Examples where - fmap f (Examples xs ys) = Examples [ (n, fmap f g) | (n, g) <- xs ] (map (fmap f) ys) - -data Item a = Example (Maybe Difficulty) a - | Random (Maybe Difficulty) (Gen a) - | Test a - | RandomTest (Gen a) - -instance Functor Item where - fmap f (Example d a) = Example d (f a) - fmap f (Test a) = Test (f a) - fmap f (Random d g) = Random d (fmap f g) - fmap f (RandomTest g) = RandomTest (fmap f g) - --- | One example -example :: a -> Examples a -example = single . Example Nothing - --- | List of examples -exampleList :: [a] -> Examples a -exampleList = Examples [] . map (Example Nothing) - --- | List of examples with the same difficulty -examplesFor :: Difficulty -> [a] -> Examples a -examplesFor d = examplesWithDifficulty . zip (repeat d) - --- | List of examples with their own difficulty -examplesWithDifficulty :: [(Difficulty, a)] -> Examples a -examplesWithDifficulty = Examples [] . map (uncurry (Example . Just)) - --- | Use a random generator (from QuickCheck) as example generator -random :: Gen a -> Examples a -random = single . Random Nothing - -group :: Id -> Examples a -> Examples a -group n xs = Examples [(n, xs)] [] - --- | Assign difficulty (to all items without a difficulty level) -difficulty :: Difficulty -> Examples a -> Examples a -difficulty d = changeItems f - where - f (Example Nothing a) = Example (Just d) a - f (Random Nothing a) = Random (Just d) a - f x = x - --- | Turn examples (and random generators) into tests (and test generators) -forTesting :: Examples a -> Examples a -forTesting = changeItems f - where - f (Example _ a) = Test a - f (Random _ a) = RandomTest a - f x = x - --- Querying - --- | Top-level examples -topLevelExamples :: Examples a -> [(Maybe Difficulty, a)] -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 - where - f (Random md g) = Just (md, g) - f _ = Nothing - --- | Top-level test cases -topLevelTests :: Examples a -> [a] -topLevelTests = collectItems f - where - f (Test a) = Just a - f _ = Nothing - --- | Top-level test generators -topLevelRandomTests :: Examples a -> [Gen a] -topLevelRandomTests = collectItems f - where - f (RandomTest g) = Just g - f _ = Nothing - --- | All examples (also in groups) -allExamples :: Examples a -> [(Maybe Difficulty, a)] -allExamples = topLevelExamples . flatten - --- | All random generators (also in groups) -allRandoms :: Examples a -> [(Maybe Difficulty, Gen a)] -allRandoms = topLevelRandoms . flatten - --- | All test cases (also in groups) -allTests :: Examples a -> [a] -allTests = topLevelTests . flatten - --- | All test generators (also in groups) -allRandomTests :: Examples a -> [Gen a] -allRandomTests = topLevelRandomTests . flatten - --- | Flatten examples into one collection without subgroups -flatten :: Examples a -> Examples a -flatten = Examples [] . getItems - --- | Number of examples, including those in subgroups -size :: Examples a -> Int -size = length . getItems - --- | Tests if there ar no examples -isEmpty :: Examples a -> Bool -isEmpty = null . getItems - --- local helpers -single :: Item a -> Examples a -single x = Examples [] [x] - -getItems :: Examples a -> [Item a] -getItems xs = concatMap (getItems . snd) (groups xs) ++ items xs - -changeItems :: (Item a -> Item a) -> Examples a -> Examples a -changeItems f = rec - where - rec xs = Examples (map g (groups xs)) (map f (items xs)) - g (n, ys) = (n, rec ys) - -collectItems :: (Item a -> Maybe b) -> Examples a -> [b] -collectItems f = mapMaybe f . items - ------------------------------------------------------------------------------ --- Difficulty - -data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult - deriving (Eq, Ord, Enum) - -instance Show Difficulty where - show = (xs !!) . fromEnum - where - xs = ["very_easy", "easy", "medium", "difficult", "very_difficult"] - -instance Read Difficulty where - readsPrec _ s = - case concatMap f txt of - "veryeasy" -> [(VeryEasy, xs)] - "easy" -> [(Easy, xs)] - "medium" -> [(Medium, xs)] - "difficult" -> [(Difficult, xs)] - "verydifficult" -> [(VeryDifficult, xs)] - _ -> [] - where - (txt, xs) = span p (dropWhile isSpace s) - p c = isAlpha c || c `elem` "_-" - f c = [toLower c | c `notElem` "_-"] - --- | Parser for difficulty levels, which ignores non-alpha charactes (including --- spaces) and upper/lower case distinction. -readDifficulty :: String -> Maybe Difficulty -readDifficulty s = - case filter p [VeryEasy .. VeryDifficult] of - [a] -> Just a - _ -> Nothing - 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 -medium = difficulty Medium -difficult = difficulty Difficult +-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- 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+-- 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+-- examples.+--+-----------------------------------------------------------------------------++module Ideas.Common.Examples+ ( -- * Examples type+ Examples+ -- * Constructing examples+ , example, exampleList, examplesFor, examplesWithDifficulty+ , random, group, forTesting+ -- * Assigning difficulty+ , difficulty, veryEasy, easy, medium, difficult, veryDifficult+ -- * Transformations and queries+ , isEmpty, size, flatten, groups+ , topLevelExamples, topLevelRandoms, topLevelTests, topLevelRandomTests+ , allExamples, allRandoms, allTests, allRandomTests+ -- * Difficulty type+ , Difficulty(..), readDifficulty+ ) where++import Data.Char+import Data.Maybe+import Ideas.Common.Id+import Test.QuickCheck++-----------------------------------------------------------------------------+-- Examples++data Examples a = Examples+ { groups :: [(Id, Examples a)] -- ^ Top-level groups+ , items :: [Item a]+ }++instance Semigroup (Examples a) where+ xs <> ys = Examples (groups xs <> groups ys) (items xs <> items ys)++instance Monoid (Examples a) where+ mempty = Examples [] []+ mappend = (<>)++instance Functor Examples where+ fmap f (Examples xs ys) = Examples [ (n, fmap f g) | (n, g) <- xs ] (map (fmap f) ys)++data Item a = Example (Maybe Difficulty) a+ | Random (Maybe Difficulty) (Gen a)+ | Test a+ | RandomTest (Gen a)++instance Functor Item where+ fmap f (Example d a) = Example d (f a)+ fmap f (Test a) = Test (f a)+ fmap f (Random d g) = Random d (fmap f g)+ fmap f (RandomTest g) = RandomTest (fmap f g)++-- | One example+example :: a -> Examples a+example = single . Example Nothing++-- | List of examples+exampleList :: [a] -> Examples a+exampleList = Examples [] . map (Example Nothing)++-- | List of examples with the same difficulty+examplesFor :: Difficulty -> [a] -> Examples a+examplesFor d = examplesWithDifficulty . zip (repeat d)++-- | List of examples with their own difficulty+examplesWithDifficulty :: [(Difficulty, a)] -> Examples a+examplesWithDifficulty = Examples [] . map (uncurry (Example . Just))++-- | Use a random generator (from QuickCheck) as example generator+random :: Gen a -> Examples a+random = single . Random Nothing++group :: Id -> Examples a -> Examples a+group n xs = Examples [(n, xs)] []++-- | Assign difficulty (to all items without a difficulty level)+difficulty :: Difficulty -> Examples a -> Examples a+difficulty d = changeItems f+ where+ f (Example Nothing a) = Example (Just d) a+ f (Random Nothing a) = Random (Just d) a+ f x = x++-- | Turn examples (and random generators) into tests (and test generators)+forTesting :: Examples a -> Examples a+forTesting = changeItems f+ where+ f (Example _ a) = Test a+ f (Random _ a) = RandomTest a+ f x = x++-- Querying++-- | Top-level examples+topLevelExamples :: Examples a -> [(Maybe Difficulty, a)]+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+ where+ f (Random md g) = Just (md, g)+ f _ = Nothing++-- | Top-level test cases+topLevelTests :: Examples a -> [a]+topLevelTests = collectItems f+ where+ f (Test a) = Just a+ f _ = Nothing++-- | Top-level test generators+topLevelRandomTests :: Examples a -> [Gen a]+topLevelRandomTests = collectItems f+ where+ f (RandomTest g) = Just g+ f _ = Nothing++-- | All examples (also in groups)+allExamples :: Examples a -> [(Maybe Difficulty, a)]+allExamples = topLevelExamples . flatten++-- | All random generators (also in groups)+allRandoms :: Examples a -> [(Maybe Difficulty, Gen a)]+allRandoms = topLevelRandoms . flatten++-- | All test cases (also in groups)+allTests :: Examples a -> [a]+allTests = topLevelTests . flatten++-- | All test generators (also in groups)+allRandomTests :: Examples a -> [Gen a]+allRandomTests = topLevelRandomTests . flatten++-- | Flatten examples into one collection without subgroups+flatten :: Examples a -> Examples a+flatten = Examples [] . getItems++-- | Number of examples, including those in subgroups+size :: Examples a -> Int+size = length . getItems++-- | Tests if there ar no examples+isEmpty :: Examples a -> Bool+isEmpty = null . getItems++-- local helpers+single :: Item a -> Examples a+single x = Examples [] [x]++getItems :: Examples a -> [Item a]+getItems xs = concatMap (getItems . snd) (groups xs) ++ items xs++changeItems :: (Item a -> Item a) -> Examples a -> Examples a+changeItems f = rec+ where+ rec xs = Examples (map g (groups xs)) (map f (items xs))+ g (n, ys) = (n, rec ys)++collectItems :: (Item a -> Maybe b) -> Examples a -> [b]+collectItems f = mapMaybe f . items++-----------------------------------------------------------------------------+-- Difficulty++data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult+ deriving (Eq, Ord, Enum)++instance Show Difficulty where+ show = (xs !!) . fromEnum+ where+ xs = ["very_easy", "easy", "medium", "difficult", "very_difficult"]++instance Read Difficulty where+ readsPrec _ s =+ case concatMap f txt of+ "veryeasy" -> [(VeryEasy, xs)]+ "easy" -> [(Easy, xs)]+ "medium" -> [(Medium, xs)]+ "difficult" -> [(Difficult, xs)]+ "verydifficult" -> [(VeryDifficult, xs)]+ _ -> []+ where+ (txt, xs) = span p (dropWhile isSpace s)+ p c = isAlpha c || c `elem` "_-"+ f c = [toLower c | c `notElem` "_-"]++-- | Parser for difficulty levels, which ignores non-alpha charactes (including+-- spaces) and upper/lower case distinction.+readDifficulty :: String -> Maybe Difficulty+readDifficulty s =+ case filter p [VeryEasy .. VeryDifficult] of+ [a] -> Just a+ _ -> Nothing+ 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+medium = difficulty Medium+difficult = difficulty Difficult veryDifficult = difficulty VeryDifficult
src/Ideas/Common/Exercise.hs view
@@ -1,421 +1,477 @@-{-# LANGUAGE Rank2Types, ExistentialQuantification #-} ------------------------------------------------------------------------------ --- Copyright 2019, Ideas project team. This file is distributed under the --- terms of the Apache License 2.0. For more information, see the files --- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- The 'Exercise' record defines all the components that are needed for --- calculating feedback for one class of exercises. The fields of an exercise --- have to be consistent; consistency can be checked with the --- "Ideas.Common.ExerciseTests" module. --- ------------------------------------------------------------------------------ - -module Ideas.Common.Exercise - ( -- * Exercise record - Exercise(..), emptyExercise, makeExercise - -- * Convenience functions - , prettyPrinterContext, isReady, isSuitable - , ruleset, getRule, ruleOrderingWith, violations - -- * Status - , Status(..), isPublic, isPrivate - -- * Examples - , Examples, Difficulty(..), readDifficulty - , examplesFor, examplesWithDifficulty, examplesContext, examplesAsList - , testGenerator, randomTerm, randomTerms - -- * Context - , inContext, withoutContext - -- * Type casting - , useTypeable, castFrom, castTo - -- * Exercise properties - , setProperty, getProperty, setPropertyF, getPropertyF - -- * Derivations - , showDerivation, showDerivations, printDerivation, printDerivations - , diffEnvironment, defaultDerivation, allDerivations - ) where - -import Data.List -import Data.Maybe -import Data.Ord -import Ideas.Common.Classes -import Ideas.Common.Constraint -import Ideas.Common.Context -import Ideas.Common.Derivation -import Ideas.Common.Environment -import Ideas.Common.Examples -import Ideas.Common.Id -import Ideas.Common.Predicate -import Ideas.Common.Rewriting -import Ideas.Common.Rule -import Ideas.Common.Strategy hiding (not, fail, repeat, replicate) -import Ideas.Common.View -import Ideas.Utils.Prelude (ShowString(..)) -import Ideas.Utils.Typeable -import System.Random -import Test.QuickCheck hiding (label) -import Test.QuickCheck.Gen -import Test.QuickCheck.Random (QCGen) -import qualified Data.Map as M -import qualified Ideas.Common.Strategy as S - ------------------------------------------------------------------------------ --- Exercise record - --- | For constructing an empty exercise, use function 'emptyExercise' or --- 'makeExercise'. -data Exercise a = - NewExercise - { -- | Identifier that uniquely determines the exercise: see 'HasId' for - -- how to use values with identifiers. - exerciseId :: Id - -- | The status of the exercise. - , status :: Status - -- | Parser for expressions of the exercise class, which either results - -- in an error ('Left') or a result ('Right'). - , parser :: String -> Either String a - -- | Pretty-printer for expressions of the exercise class. Pretty-printing - -- should be the inverse of parsing. - , prettyPrinter :: a -> String - -- | Tests wether two expressions (with their contexts) are semantically - -- equivalent. Use 'withoutContext' for defining the equivalence check - -- when the context is not relevant. - , equivalence :: Context a -> Context a -> Bool - -- | Tests wether two expressions (with their contexts) are syntactically - -- the same, or nearly so. Expressions that are similar must also be - -- equivalent. Use 'withoutContext' if the context is not relevant for the - -- similarity check. - , similarity :: Context a -> Context a -> Bool - -- | Predicate suitable identifies which expressions can be solved by the - -- strategy of the exercise class. It acts as the pre-condition of the - -- strategy. - , suitable :: Predicate a - -- | Predicate ready checks if an expression is in a solved form (accepted - -- as a final solution). It acts as the post-condition of the strategy. - , ready :: Predicate a - -- | The rewrite strategy that specifies how to solve an exercise. - , strategy :: LabeledStrategy (Context a) - -- | Is it possible to restart the rewrite strategy at any point in time? - -- Restarting the strategy is needed when a student deviates from the - -- strategy (detour). By default, restarting is assumed to be possible. - , canBeRestarted :: Bool - -- | Are there extra rules, possibly buggy, that do not appear in the - -- strategy? Use 'ruleset' to get all rules. - , extraRules :: [Rule (Context a)] - -- | The rule ordering is a tiebreaker in situations where more than one - -- rule can be used (e.g. feedback services onefirst and derivation; other - -- feedback services return all possible rules). - , ruleOrdering :: Rule (Context a) -> Rule (Context a) -> Ordering - -- | Constraints for constraint-based tutors. A constraint contains a - -- relevance condition and a satisfaction condition. - , constraints :: [Constraint (Context a)] - -- | A navigator is needed for traversing the expression and for using the - -- traversal strategy combinators. By default, an exercise has no - -- navigator. - , navigation :: a -> ContextNavigator a - -- | A finite list of examples, each with an assigned difficulty. - , examples :: Examples a - -- | Conversion to and from the (generic) 'Term' datatype. Needed for - -- representing the expression in the OpenMath standard. - , hasTermView :: Maybe (View Term a) - -- | Representation of the type of expression: this provides a back door - -- for exercise-specific functionality. - , hasTypeable :: Maybe (IsTypeable a) - -- | Extra exercise-specific properties, not used by the default - -- feedback services. - , properties :: M.Map Id (Dynamic a) -- extra, domain-specific properties - } - -instance Eq (Exercise a) where - e1 == e2 = getId e1 == getId e2 - -instance Ord (Exercise a) where - compare = comparing getId - -instance Apply Exercise where - applyAll ex = mapMaybe fromContext . applyAll (strategy ex) . inContext ex - -instance HasId (Exercise a) where - getId = exerciseId - changeId f ex = ex { exerciseId = f (exerciseId ex) } - --- | The 'emptyExercise' constructor function provides sensible defaults for --- all fields of the 'Exercise' record. -emptyExercise :: Exercise a -emptyExercise = NewExercise - { -- identification and meta-information - exerciseId = mempty - , status = Experimental - -- parsing and pretty-printing - , parser = const (Left "<<no parser>>") - , prettyPrinter = const "<<no pretty-printer>>" - -- syntactic and semantic checks - , equivalence = \_ _ -> True - , similarity = \_ _ -> True - , ready = true - , suitable = true - , hasTermView = Nothing - , hasTypeable = Nothing - , properties = M.empty - -- strategies and rules - , strategy = label "Fail" S.fail - , constraints = [] - , navigation = noNavigator - , canBeRestarted = True - , extraRules = [] - , ruleOrdering = compareId - -- examples - , examples = mempty - } - --- | In addition to the defaults of 'emptyExercise', this constructor sets --- the fields 'prettyPrinter', 'similarity', and 'hasTermView'. -makeExercise :: (Show a, Eq a, IsTerm a) => Exercise a -makeExercise = emptyExercise - { prettyPrinter = show - , similarity = (==) - , hasTermView = Just termView - } - ------------------------------------------------------------------------------ --- Convenience functions - --- | Pretty print a value in its context. -prettyPrinterContext :: Exercise a -> Context a -> String -prettyPrinterContext ex = - maybe "<<invalid term>>" (prettyPrinter ex) . fromContext - --- | Checks if an expression is in a solved form. -isReady :: Exercise a -> a -> Bool -isReady = evalPredicate . ready - --- | Checks if the expression is suitable and can be solved by the strategy. -isSuitable :: Exercise a -> a -> Bool -isSuitable = evalPredicate . suitable - --- | Returns a sorted list of rules, without duplicates. -ruleset :: Exercise a -> [Rule (Context a)] -ruleset ex = nub (sortBy (ruleOrdering ex) list) - where - list = extraRules ex ++ rulesInStrategy (strategy ex) - --- | Finds a rule of an exercise based on its identifier. -getRule :: Monad m => Exercise a -> Id -> m (Rule (Context a)) -getRule ex a = - case filter ((a ==) . getId) (ruleset ex) of - [hd] -> return hd - [] -> fail $ "Could not find ruleid " ++ showId a - _ -> fail $ "Ambiguous ruleid " ++ showId a - --- | Makes a rule ordering based on a list of values with identifiers (e.g., --- a list of rules). Rules with identifiers that are not in the list are --- considered after the rules in the list, and are sorted based on their --- identifier. -ruleOrderingWith :: HasId b => [b] -> Rule a -> Rule a -> Ordering -ruleOrderingWith bs r1 r2 = - let xs = map getId bs in - case (elemIndex (getId r1) xs, elemIndex (getId r2) xs) of - (Just i, Just j ) -> i `compare` j - (Just _, Nothing) -> LT - (Nothing, Just _ ) -> GT - (Nothing, Nothing) -> compareId r1 r2 - --- | Get all constraint violations -violations :: Exercise a -> Context a -> [(Constraint (Context a), String)] -violations ex ctx = - [ (c, msg) - | c <- constraints ex - , msg <- maybeToList (isViolated c ctx) - ] - ------------------------------------------------------------------------------ --- Status - --- | The status of an exercise class. -data Status - = Stable -- ^ A released exercise that has undergone some thorough testing - | Provisional -- ^ A released exercise, possibly with some deficiencies - | Alpha -- ^ An exercise that is under development - | Experimental -- ^ An exercise for experimentation purposes only - deriving (Show, Eq) - --- | An exercise with the status 'Stable' or 'Provisional' -isPublic :: Exercise a -> Bool -isPublic ex = status ex `elem` [Stable, Provisional] - --- | An exercise that is not public -isPrivate :: Exercise a -> Bool -isPrivate = not . isPublic - ------------------------------------------------------------------------------ --- Examples - --- | Returns the examples of an exercise class lifted to a context. -examplesContext :: Exercise a -> Examples (Context a) -examplesContext ex = fmap (inContext ex) (examples ex) - -examplesAsList :: Exercise a -> [a] -examplesAsList = map snd . allExamples . examples - -fromGen :: QCGen -> Gen a -> a -fromGen rng (MkGen f) = a - where - (sz, r) = randomR (0, 100) rng - a = f r sz - --- | Returns a random exercise of a certain difficulty with some random --- number generator. The field 'randomExercise' is used; if this is not --- defined (i.e., Nothing), one of the examples is used instead. -randomTerm :: QCGen -> Exercise a -> Maybe Difficulty -> Maybe a -randomTerm rng ex mdif = - case filter ((== mdif) . fst) (allRandoms (examples ex)) of - (_, g):_ -> Just (fromGen rng g) - [] - | null xs -> Nothing - | otherwise -> Just (snd (xs !! i)) - where - xs = filter p (allExamples (examples ex)) -- improve - p (Just d, _) = maybe True (==d) mdif - p _ = False - i = fst (randomR (0, length xs - 1) rng) - --- | Returns a list of randomly generated terms of a certain difficulty. -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 - ------------------------------------------------------------------------------ --- Context - --- | Puts a value into a context with an empty environment. -inContext :: Exercise a -> a -> Context a -inContext ex = newContext . navigation ex - --- | Function for defining equivalence or similarity without taking --- the context into account. -withoutContext :: (a -> a -> Bool) -> Context a -> Context a -> Bool -withoutContext f a b = fromMaybe False (fromContextWith2 f a b) - ------------------------------------------------------------------------------ --- Type casting - -instance HasTypeable Exercise where - getTypeable = hasTypeable - --- | Encapsulates a type representation (use for 'hasTypeable' field). -useTypeable :: Typeable a => Maybe (IsTypeable a) -useTypeable = Just typeable - ------------------------------------------------------------------------------ --- Exercise-specific properties - --- | Set an exercise-specific property (with a dynamic type) -setProperty :: (IsId n, Typeable val) => n -> val -> Exercise a -> Exercise a -setProperty key a = insertProperty key (Dyn (cast a)) - --- | Set an exercise-specific property (with a dynamic type) that is --- parameterized over the exercise term. -setPropertyF :: (IsId n, Typeable f) => n -> f a -> Exercise a -> Exercise a -setPropertyF key a = insertProperty key (DynF (castF a)) - -insertProperty :: IsId n => n -> Dynamic a -> Exercise a -> Exercise a -insertProperty key d ex = - ex { properties = M.insert (newId key) d (properties ex) } - --- | Get an exercise-specific property (of a dynamic type) -getProperty :: (IsId n, Typeable val) => n -> Exercise a -> Maybe val -getProperty key ex = lookupProperty key ex >>= \d -> - case d of - Dyn m -> m - _ -> Nothing - --- | Get an exercise-specific property (of a dynamic type) that is --- parameterized over the exercise term. -getPropertyF :: (IsId n, Typeable f) => n -> Exercise a -> Maybe (f a) -getPropertyF key ex = lookupProperty key ex >>= \d -> - case d of - DynF m -> m - _ -> Nothing - -lookupProperty :: IsId n => n -> Exercise a -> Maybe (Dynamic a) -lookupProperty key = M.lookup (newId key) . properties - --- | Values with a dynamic type that is parameterized over the exercise term. -data Dynamic a = Dyn (forall b . Typeable b => Maybe b) - | DynF (forall f . Typeable f => Maybe (f a)) - -castF :: (Typeable f, Typeable g) => f a -> Maybe (g a) -castF = fmap fromIdentity . gcast1 . Identity - -newtype Identity a = Identity { fromIdentity :: a} - ---------------------------------------------------------------- --- Derivations - --- | Shows the default derivation for a given start term. The specified rule ordering --- is used for selection. -showDerivation :: Exercise a -> a -> String -showDerivation ex a = - case defaultDerivation ex a of - Just d -> showThisDerivation d ex - Nothing -> "no derivation" - --- | Shows all derivations for a given start term. Warning: there can be many --- derivations. -showDerivations :: Exercise a -> a -> String -showDerivations ex a = unlines - [ "Derivation #" ++ show i ++ "\n" ++ showThisDerivation d ex - | (i, d) <- zip [1::Int ..] (allDerivations ex a) - ] - --- | Prints the default derivation for a given start term. The specified rule ordering --- is used for selection. -printDerivation :: Exercise a -> a -> IO () -printDerivation ex = putStrLn . showDerivation ex - --- | Prints all derivations for a given start term. Warning: there can be many --- derivations. -printDerivations :: Exercise a -> a -> IO () -printDerivations ex = putStrLn . showDerivations ex - --- also pass derivation as an argument -showThisDerivation :: Derivation (Rule b, Environment) (Context a) -> Exercise a -> String -showThisDerivation d ex = show (present der) ++ extra - where - der = diffEnvironment d - extra = - case fromContext (lastTerm der) of - Nothing -> "<<invalid term>>" - Just b | isReady ex b -> "" - | otherwise -> "<<not ready>>" - present = biMap (ShowString . f) (ShowString . prettyPrinterContext ex) - f ((r, local), global) = showId r ++ part local ++ part global - where - newl = "\n " - part env | noBindings env = "" - | otherwise = newl ++ show env - --- | Adds the difference of the environments in a derivation to the steps. --- Bindings with identifier @location@ are ignored. This utility function is --- useful for printing derivations. -diffEnvironment :: HasEnvironment a => Derivation s a -> Derivation (s, Environment) a -diffEnvironment = updateSteps $ \old a new -> - let keep x = not (getId x == newId "location" || x `elem` list) - list = bindings old - in (a, makeEnvironment $ filter keep $ bindings new) - -defaultDerivation :: Exercise a -> a -> Maybe (Derivation (Rule (Context a), Environment) (Context a)) -defaultDerivation ex = listToMaybe . allDerivations ex - -allDerivations :: Exercise a -> a -> [Derivation (Rule (Context a), Environment) (Context a)] -allDerivations ex = - derivationList (ruleOrdering ex) (strategy ex) . inContext ex+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}++-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------++{- |+Maintainer : bastiaan.heeren@ou.nl+Stability : provisional+Portability : portable (depends on ghc)++The 'Exercise' record defines all the components that are needed for+calculating feedback for one class of exercises. The fields of an exercise+have to be consistent; consistency can be checked with the+"Ideas.Common.ExerciseTests" module.+-}+module Ideas.Common.Exercise+ ( -- * Exercise record+ Exercise (..)+ , emptyExercise+ , makeExercise++ -- * Convenience functions+ , prettyPrinterContext+ , isReady+ , isSuitable+ , ruleset+ , getRule+ , ruleOrderingWith+ , violations++ -- * Status+ , Status (..)+ , isPublic+ , isPrivate++ -- * Examples+ , Examples+ , Difficulty (..)+ , readDifficulty+ , examplesFor+ , examplesWithDifficulty+ , examplesContext+ , examplesAsList+ , testGenerator+ , randomTerm+ , randomTerms++ -- * Context+ , inContext+ , withoutContext++ -- * Type casting+ , useTypeable+ , castFrom+ , castTo++ -- * Exercise properties+ , setProperty+ , getProperty+ , setPropertyF+ , getPropertyF++ -- * Derivations+ , showDerivation+ , showDerivations+ , printDerivation+ , printDerivations+ , diffEnvironment+ , defaultDerivation+ , allDerivations+ ) where++import Data.List+import qualified Data.Map as M+import Data.Maybe+import Data.Ord+import System.Random+import Test.QuickCheck hiding (label)+import Test.QuickCheck.Gen+import Test.QuickCheck.Random (QCGen)++import Ideas.Common.Classes+import Ideas.Common.Constraint+import Ideas.Common.Context+import Ideas.Common.Derivation+import Ideas.Common.Environment+import Ideas.Common.Examples+import Ideas.Common.Id+import Ideas.Common.Predicate+import Ideas.Common.Rewriting+import Ideas.Common.Rule+import Ideas.Common.Strategy hiding (fail, not, repeat, replicate)+import qualified Ideas.Common.Strategy as S+import Ideas.Common.View+import Ideas.Utils.Prelude (ShowString (..))+import Ideas.Utils.Typeable++-----------------------------------------------------------------------------+-- Exercise record++-- | For constructing an empty exercise, use function 'emptyExercise' or+-- 'makeExercise'.+data Exercise a+ = NewExercise+ { exerciseId :: Id+ -- ^ Identifier that uniquely determines the exercise: see 'HasId' for+ -- how to use values with identifiers.+ , status :: Status+ -- ^ The status of the exercise.+ , parser :: String -> Either String a+ -- ^ Parser for expressions of the exercise class, which either results+ -- in an error ('Left') or a result ('Right').+ , prettyPrinter :: a -> String+ -- ^ Pretty-printer for expressions of the exercise class. Pretty-printing+ -- should be the inverse of parsing.+ , equivalence :: Context a -> Context a -> Bool+ -- ^ Tests wether two expressions (with their contexts) are semantically+ -- equivalent. Use 'withoutContext' for defining the equivalence check+ -- when the context is not relevant.+ , similarity :: Context a -> Context a -> Bool+ -- ^ Tests wether two expressions (with their contexts) are syntactically+ -- the same, or nearly so. Expressions that are similar must also be+ -- equivalent. Use 'withoutContext' if the context is not relevant for the+ -- similarity check.+ , suitable :: Predicate a+ -- ^ Predicate suitable identifies which expressions can be solved by the+ -- strategy of the exercise class. It acts as the pre-condition of the+ -- strategy.+ , ready :: Predicate a+ -- ^ Predicate ready checks if an expression is in a solved form (accepted+ -- as a final solution). It acts as the post-condition of the strategy.+ , strategy :: LabeledStrategy (Context a)+ -- ^ The rewrite strategy that specifies how to solve an exercise.+ , canBeRestarted :: Bool+ -- ^ Is it possible to restart the rewrite strategy at any point in time?+ -- Restarting the strategy is needed when a student deviates from the+ -- strategy (detour). By default, restarting is assumed to be possible.+ , extraRules :: [Rule (Context a)]+ -- ^ Are there extra rules, possibly buggy, that do not appear in the+ -- strategy? Use 'ruleset' to get all rules.+ , ruleOrdering :: Rule (Context a) -> Rule (Context a) -> Ordering+ -- ^ The rule ordering is a tiebreaker in situations where more than one+ -- rule can be used (e.g. feedback services onefirst and derivation; other+ -- feedback services return all possible rules).+ , constraints :: [Constraint (Context a)]+ -- ^ Constraints for constraint-based tutors. A constraint contains a+ -- relevance condition and a satisfaction condition.+ , navigation :: a -> ContextNavigator a+ -- ^ A navigator is needed for traversing the expression and for using the+ -- traversal strategy combinators. By default, an exercise has no+ -- navigator.+ , examples :: Examples a+ -- ^ A finite list of examples, each with an assigned difficulty.+ , hasTermView :: Maybe (View Term a)+ -- ^ Conversion to and from the (generic) 'Term' datatype. Needed for+ -- representing the expression in the OpenMath standard.+ , hasTypeable :: Maybe (IsTypeable a)+ -- ^ Representation of the type of expression: this provides a back door+ -- for exercise-specific functionality.+ , properties :: M.Map Id (Dynamic a) -- extra, domain-specific properties++ -- ^ Extra exercise-specific properties, not used by the default+ -- feedback services.+ }++instance Eq (Exercise a) where+ e1 == e2 = getId e1 == getId e2++instance Ord (Exercise a) where+ compare = comparing getId++instance Apply Exercise where+ applyAll ex = mapMaybe fromContext . applyAll (strategy ex) . inContext ex++instance HasId (Exercise a) where+ getId = exerciseId+ changeId f ex = ex{exerciseId = f (exerciseId ex)}++-- | The 'emptyExercise' constructor function provides sensible defaults for+-- all fields of the 'Exercise' record.+emptyExercise :: Exercise a+emptyExercise =+ NewExercise+ { -- identification and meta-information+ exerciseId = mempty+ , status = Experimental+ , -- parsing and pretty-printing+ parser = const (Left "<<no parser>>")+ , prettyPrinter = const "<<no pretty-printer>>"+ , -- syntactic and semantic checks+ equivalence = \_ _ -> True+ , similarity = \_ _ -> True+ , ready = true+ , suitable = true+ , hasTermView = Nothing+ , hasTypeable = Nothing+ , properties = M.empty+ , -- strategies and rules+ strategy = label "Fail" S.fail+ , constraints = []+ , navigation = noNavigator+ , canBeRestarted = True+ , extraRules = []+ , ruleOrdering = compareId+ , -- examples+ examples = mempty+ }++-- | In addition to the defaults of 'emptyExercise', this constructor sets+-- the fields 'prettyPrinter', 'similarity', and 'hasTermView'.+makeExercise :: (Eq a, IsTerm a, Show a) => Exercise a+makeExercise =+ emptyExercise+ { prettyPrinter = show+ , similarity = (==)+ , hasTermView = Just termView+ }++-----------------------------------------------------------------------------+-- Convenience functions++-- | Pretty print a value in its context.+prettyPrinterContext :: Exercise a -> Context a -> String+prettyPrinterContext ex =+ maybe "<<invalid term>>" (prettyPrinter ex) . fromContext++-- | Checks if an expression is in a solved form.+isReady :: Exercise a -> a -> Bool+isReady = evalPredicate . ready++-- | Checks if the expression is suitable and can be solved by the strategy.+isSuitable :: Exercise a -> a -> Bool+isSuitable = evalPredicate . suitable++-- | Returns a sorted list of rules, without duplicates.+ruleset :: Exercise a -> [Rule (Context a)]+ruleset ex = nub (sortBy (ruleOrdering ex) list)+ where+ list = extraRules ex ++ rulesInStrategy (strategy ex)++-- | Finds a rule of an exercise based on its identifier.+getRule :: Exercise a -> Id -> Maybe (Rule (Context a))+getRule ex a =+ case filter ((a ==) . getId) (ruleset ex) of+ [hd] -> Just hd+ _ -> Nothing++-- | Makes a rule ordering based on a list of values with identifiers (e.g.,+-- a list of rules). Rules with identifiers that are not in the list are+-- considered after the rules in the list, and are sorted based on their+-- identifier.+ruleOrderingWith :: HasId b => [b] -> Rule a -> Rule a -> Ordering+ruleOrderingWith bs r1 r2 =+ let xs = map getId bs+ in case (elemIndex (getId r1) xs, elemIndex (getId r2) xs) of+ (Just i, Just j) -> i `compare` j+ (Just _, Nothing) -> LT+ (Nothing, Just _) -> GT+ (Nothing, Nothing) -> compareId r1 r2++-- | Get all constraint violations+violations :: Exercise a -> Context a -> [(Constraint (Context a), String)]+violations ex ctx =+ [ (c, msg)+ | c <- constraints ex+ , msg <- maybeToList (isViolated c ctx)+ ]++-----------------------------------------------------------------------------+-- Status++-- | The status of an exercise class.+data Status+ = -- | A released exercise that has undergone some thorough testing+ Stable+ | -- | A released exercise, possibly with some deficiencies+ Provisional+ | -- | An exercise that is under development+ Alpha+ | -- | An exercise for experimentation purposes only+ Experimental+ deriving (Eq, Show)++-- | An exercise with the status 'Stable' or 'Provisional'+isPublic :: Exercise a -> Bool+isPublic ex = status ex `elem` [Stable, Provisional]++-- | An exercise that is not public+isPrivate :: Exercise a -> Bool+isPrivate = not . isPublic++-----------------------------------------------------------------------------+-- Examples++-- | Returns the examples of an exercise class lifted to a context.+examplesContext :: Exercise a -> Examples (Context a)+examplesContext ex = fmap (inContext ex) (examples ex)++examplesAsList :: Exercise a -> [a]+examplesAsList = map snd . allExamples . examples++fromGen :: QCGen -> Gen a -> a+fromGen rng (MkGen f) = a+ where+ (sz, r) = randomR (0, 100) rng+ a = f r sz++-- | Returns a random exercise of a certain difficulty with some random+-- number generator. The field 'randomExercise' is used; if this is not+-- defined (i.e., Nothing), one of the examples is used instead.+randomTerm :: QCGen -> Exercise a -> Maybe Difficulty -> Maybe a+randomTerm rng ex mdif =+ case filter ((== mdif) . fst) (allRandoms (examples ex)) of+ (_, g) : _ -> Just (fromGen rng g)+ []+ | null xs -> Nothing+ | otherwise -> Just (snd (xs !! i))+ where+ xs = filter p (allExamples (examples ex)) -- improve+ p (Just d, _) = maybe True (== d) mdif+ p _ = False+ i = fst (randomR (0, length xs - 1) rng)++-- | Returns a list of randomly generated terms of a certain difficulty.+randomTerms :: QCGen -> Exercise a -> Maybe Difficulty -> [a]+randomTerms rng ex mdif = rec rng+ where+ rec a = maybe id (:) (randomTerm a ex mdif) (rec (snd (split a)))++-- | An exercise generator for testing purposes (including corner cases); first generator only.+testGenerator :: Exercise a -> Maybe (Gen a)+testGenerator = listToMaybe . allRandomTests . examples++-----------------------------------------------------------------------------+-- Context++-- | Puts a value into a context with an empty environment.+inContext :: Exercise a -> a -> Context a+inContext ex = newContext . navigation ex++-- | Function for defining equivalence or similarity without taking+-- the context into account.+withoutContext :: (a -> a -> Bool) -> Context a -> Context a -> Bool+withoutContext f a b = fromMaybe False (fromContextWith2 f a b)++-----------------------------------------------------------------------------+-- Type casting++instance HasTypeable Exercise where+ getTypeable = hasTypeable++-- | Encapsulates a type representation (use for 'hasTypeable' field).+useTypeable :: Typeable a => Maybe (IsTypeable a)+useTypeable = Just typeable++-----------------------------------------------------------------------------+-- Exercise-specific properties++-- | Set an exercise-specific property (with a dynamic type)+setProperty :: (IsId n, Typeable val) => n -> val -> Exercise a -> Exercise a+setProperty key a = insertProperty key (Dyn (cast a))++-- | Set an exercise-specific property (with a dynamic type) that is+-- parameterized over the exercise term.+setPropertyF :: (IsId n, Typeable f) => n -> f a -> Exercise a -> Exercise a+setPropertyF key a = insertProperty key (DynF (castF a))++insertProperty :: IsId n => n -> Dynamic a -> Exercise a -> Exercise a+insertProperty key d ex =+ ex{properties = M.insert (newId key) d (properties ex)}++-- | Get an exercise-specific property (of a dynamic type)+getProperty :: (IsId n, Typeable val) => n -> Exercise a -> Maybe val+getProperty key ex =+ lookupProperty key ex >>= \d ->+ case d of+ Dyn m -> m+ _ -> Nothing++-- | Get an exercise-specific property (of a dynamic type) that is+-- parameterized over the exercise term.+getPropertyF :: (IsId n, Typeable f) => n -> Exercise a -> Maybe (f a)+getPropertyF key ex =+ lookupProperty key ex >>= \d ->+ case d of+ DynF m -> m+ _ -> Nothing++lookupProperty :: IsId n => n -> Exercise a -> Maybe (Dynamic a)+lookupProperty key = M.lookup (newId key) . properties++-- | Values with a dynamic type that is parameterized over the exercise term.+data Dynamic a+ = Dyn (forall b. Typeable b => Maybe b)+ | DynF (forall f. Typeable f => Maybe (f a))++castF :: (Typeable f, Typeable g) => f a -> Maybe (g a)+castF = fmap fromIdentity . gcast1 . Identity++newtype Identity a = Identity {fromIdentity :: a}++---------------------------------------------------------------+-- Derivations++-- | Shows the default derivation for a given start term. The specified rule ordering+-- is used for selection.+showDerivation :: Exercise a -> a -> String+showDerivation ex a =+ case defaultDerivation ex a of+ Just d -> showThisDerivation d ex+ Nothing -> "no derivation"++-- | Shows all derivations for a given start term. Warning: there can be many+-- derivations.+showDerivations :: Exercise a -> a -> String+showDerivations ex a =+ unlines+ [ "Derivation #" ++ show i ++ "\n" ++ showThisDerivation d ex+ | (i, d) <- zip [1 :: Int ..] (allDerivations ex a)+ ]++-- | Prints the default derivation for a given start term. The specified rule ordering+-- is used for selection.+printDerivation :: Exercise a -> a -> IO ()+printDerivation ex = putStrLn . showDerivation ex++-- | Prints all derivations for a given start term. Warning: there can be many+-- derivations.+printDerivations :: Exercise a -> a -> IO ()+printDerivations ex = putStrLn . showDerivations ex++-- also pass derivation as an argument+showThisDerivation+ :: Derivation (Rule b, Environment) (Context a) -> Exercise a -> String+showThisDerivation d ex = show (present der) ++ extra+ where+ der = diffEnvironment d+ extra =+ case fromContext (lastTerm der) of+ Nothing -> "<<invalid term>>"+ Just b+ | isReady ex b -> ""+ | otherwise -> "<<not ready>>"+ present = biMap (ShowString . f) (ShowString . prettyPrinterContext ex)+ f ((r, localEnv), globalEnv) = showId r ++ part localEnv ++ part globalEnv+ where+ newl = "\n "+ part env+ | noBindings env = ""+ | otherwise = newl ++ show env++-- | Adds the difference of the environments in a derivation to the steps.+-- Bindings with identifier @location@ are ignored. This utility function is+-- useful for printing derivations.+diffEnvironment+ :: HasEnvironment a => Derivation s a -> Derivation (s, Environment) a+diffEnvironment = updateSteps $ \old a new ->+ let keep x = not (getId x == newId "location" || x `elem` list)+ list = bindings old+ in (a, makeEnvironment $ filter keep $ bindings new)++defaultDerivation+ :: Exercise a+ -> a+ -> Maybe (Derivation (Rule (Context a), Environment) (Context a))+defaultDerivation ex = listToMaybe . allDerivations ex++allDerivations+ :: Exercise a -> a -> [Derivation (Rule (Context a), Environment) (Context a)]+allDerivations ex =+ derivationList (ruleOrdering ex) (strategy ex) . inContext ex
src/Ideas/Common/Rewriting/AutoTerm.hs view
@@ -1,124 +1,121 @@------------------------------------------------------------------------------ --- Copyright 2019, Ideas project team. This file is distributed under the --- terms of the Apache License 2.0. For more information, see the files --- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Rewriting.AutoTerm (toTermG, fromTermG, testTermFor) where - -import Control.Monad.State -import Data.Data -import Ideas.Common.Rewriting.Term -import Ideas.Utils.Prelude (headM) - -toTermG :: Data a => a -> Term -toTermG a = - case constrRep constr of - IntConstr n -> TNum n -- for Int and Integer - FloatConstr r -> TFloat (fromRational r) -- for Double and Float - CharConstr c -> TVar [c] - AlgConstr _ -> - case cast a of - Just s -> TVar s -- for String - Nothing -> makeTerm constr (gfoldl op e a) - where - op (M xs) x = M (xs ++ [toTermG x]) - e _ = M [] - constr = toConstr a - -newtype M a = M [Term] - --- test for list constructors -makeTerm :: Constr -> M a -> Term -makeTerm c (M xs) = - case xs of - [y, TList ys] | isCons -> TList (y:ys) - [] | isNil -> TList [] - _ -> TCon (constrSymbol c) xs - where - txt = showConstr c - isNil = txt == "[]" - isCons = txt == "(:)" - -isTuple :: String -> Bool -isTuple ('(':xs) = rec xs - where - rec ")" = True - rec (',':ys) = rec ys - rec _ = False -isTuple _ = False - ------------------------------------------------------------------------- - -constrSymbol :: Constr -> Symbol -constrSymbol c - | txt == "[]" = nilSymbol - | txt == "(:)" = consSymbol - | isTuple txt = tupleSymbol - | otherwise = newSymbol (dataTypeName (constrType c) `mappend` show c) - where - txt = showConstr c - -nilSymbol, consSymbol, tupleSymbol :: Symbol -nilSymbol = newSymbol "list.nil" -consSymbol = newSymbol "list.cons" -tupleSymbol = newSymbol "tuple" - -constructors :: Data a => Proxy a -> [Constr] -constructors = dataTypeConstrs . dataTypeOf . fromProxy - where - fromProxy :: Proxy a -> a - fromProxy = error "fromProxy" - -findConstr :: (Monad m, Data a) => Proxy a -> Symbol -> m Constr -findConstr p s = - headM [ c | c <- constructors p, s == constrSymbol c ] - -fromTermG :: (MonadPlus m, Data a) => Term -> m a -fromTermG term = - case term of - TCon s xs -> fromTermTConG Proxy s xs - TVar [c] -> castM c `mplus` castM [c] - TVar s -> castM s - TList xs -> fromTermG (foldr cons nil xs) - TNum n -> castM n `mplus` castM (fromInteger n :: Int) - TFloat d -> castM d `mplus` castM (doubleToFloat d) - TMeta _ -> fail "fromTermG: found TMeta" - where - cons = binary consSymbol - nil = symbol nilSymbol - -castM :: (Monad m, Typeable a, Typeable b) => a -> m b -castM = maybe (fail "fromTermG") return . cast - -doubleToFloat :: Double -> Float -doubleToFloat = fromRational . toRational - -fromTermTConG :: (MonadPlus m, Data a) => Proxy a -> Symbol -> [Term] -> m a -fromTermTConG p s xs = do - c <- findConstr p s - evalStateT (gunfold op return c) xs - where - op m = do - f <- m - t <- pop - a <- lift (fromTermG t) - return (f a) - -pop :: Monad m => StateT [a] m a -pop = do - ts <- get - case ts of - [] -> fail "pop" - hd:tl -> put tl >> return hd - --------------- - -testTermFor :: (Data a, Eq a) => a -> Bool +-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Common.Rewriting.AutoTerm (toTermG, fromTermG, testTermFor) where++import Control.Monad (mplus)+import Control.Monad.State+import Data.Data+import Data.List+import Ideas.Common.Rewriting.Term++toTermG :: Data a => a -> Term+toTermG a =+ case constrRep constr of+ IntConstr n -> TNum n -- for Int and Integer+ FloatConstr r -> TFloat (fromRational r) -- for Double and Float+ CharConstr c -> TVar [c]+ AlgConstr _ ->+ case cast a of+ Just s -> TVar s -- for String+ Nothing -> makeTerm constr (gfoldl op e a)+ where+ op (M xs) x = M (xs ++ [toTermG x])+ e _ = M []+ constr = toConstr a++newtype M a = M [Term]++-- test for list constructors+makeTerm :: Constr -> M a -> Term+makeTerm c (M xs) =+ case xs of+ [y, TList ys] | isCons -> TList (y:ys)+ [] | isNil -> TList []+ _ -> TCon (constrSymbol c) xs+ where+ txt = showConstr c+ isNil = txt == "[]"+ isCons = txt == "(:)"++isTuple :: String -> Bool+isTuple ('(':xs) = rec xs+ where+ rec ")" = True+ rec (',':ys) = rec ys+ rec _ = False+isTuple _ = False++------------------------------------------------------------------------++constrSymbol :: Constr -> Symbol+constrSymbol c+ | txt == "[]" = nilSymbol+ | txt == "(:)" = consSymbol+ | isTuple txt = tupleSymbol+ | otherwise = newSymbol (dataTypeName (constrType c) `mappend` show c)+ where+ txt = showConstr c++nilSymbol, consSymbol, tupleSymbol :: Symbol+nilSymbol = newSymbol "list.nil"+consSymbol = newSymbol "list.cons"+tupleSymbol = newSymbol "tuple"++constructors :: Data a => Proxy a -> [Constr]+constructors = dataTypeConstrs . dataTypeOf . fromProxy+ where+ fromProxy :: Proxy a -> a+ fromProxy = error "fromProxy"++findConstr :: Data a => Proxy a -> Symbol -> Maybe Constr+findConstr p s = find (\c -> s == constrSymbol c) (constructors p)++fromTermG :: Data a => Term -> Maybe a+fromTermG term =+ case term of+ TCon s xs -> fromTermTConG Proxy s xs+ TVar [c] -> cast c `mplus` cast [c]+ TVar s -> cast s+ TList xs -> fromTermG (foldr cons nil xs)+ TNum n -> cast n `mplus` cast (fromInteger n :: Int)+ TFloat d -> cast d `mplus` cast (doubleToFloat d)+ TMeta _ -> Nothing+ where+ cons = binary consSymbol+ nil = symbol nilSymbol++doubleToFloat :: Double -> Float+doubleToFloat = fromRational . toRational++fromTermTConG :: Data a => Proxy a -> Symbol -> [Term] -> Maybe a+fromTermTConG p s xs = do+ c <- findConstr p s+ evalStateT (gunfold op return c) xs+ where+ op m = do+ f <- m+ t <- pop+ a <- lift (fromTermG t)+ return (f a)++pop :: StateT [a] Maybe a+pop = do+ ts <- get+ case ts of+ [] -> fail "pop"+ hd:tl -> put tl >> return hd++--------------++testTermFor :: (Data a, Eq a) => a -> Bool testTermFor x = fromTermG (toTermG x) == Just x
src/Ideas/Common/Rewriting/Confluence.hs view
@@ -41,7 +41,7 @@ rewriteTerm r t = do let lhs :~> rhs = ruleSpecTerm $ renumberRewriteRule (nextMetaVar t) r - sub <- match lhs t + sub <- maybeToList (match lhs t) return (sub |-> rhs) -- uniplate-like helper-functions
src/Ideas/Common/Rewriting/Difference.hs view
@@ -49,7 +49,7 @@ [one] -> Just one _ -> here -getFunctionA :: (Monad m, WithFunctions a) => a -> m (Symbol, [a]) +getFunctionA :: WithFunctions a => a -> Maybe (Symbol, [a]) getFunctionA a = f <$> getFunction a where f (s, xs) = (s, if isAssociative s then collectSym s a else xs)
src/Ideas/Common/Rewriting/RewriteRule.hs view
@@ -31,8 +31,8 @@ import Ideas.Common.Id import Ideas.Common.Rewriting.Substitution import Ideas.Common.Rewriting.Term -import Ideas.Common.Rewriting.Unification -import Ideas.Common.View hiding (match) +import Ideas.Common.Rewriting.Unification hiding (match) +import Ideas.Common.View import Ideas.Utils.Uniplate (descend) import qualified Data.IntSet as IS import qualified Data.Map as M @@ -181,7 +181,7 @@ (out, xs) <- builder term let env = mconcat (zipWith make xs [1::Int ..]) make t = flip singleBinding t . makeRef . show - b <- fromTermRR r out + b <- maybeToList (fromTermRR r out) return (b, env) ----------------------------------------------------------- @@ -214,5 +214,5 @@ toTermRR :: RewriteRule a -> a -> Term toTermRR = build . ruleTermView -fromTermRR :: Monad m => RewriteRule a -> Term -> m a -fromTermRR = matchM . ruleTermView+fromTermRR :: RewriteRule a -> Term -> Maybe a +fromTermRR = match . ruleTermView
src/Ideas/Common/Rewriting/Term.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -9,317 +8,16 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- A simple data type for term rewriting +-- Generic terms -- ----------------------------------------------------------------------------- module Ideas.Common.Rewriting.Term - ( -- * Symbols - Symbol, newSymbol - , isAssociative, makeAssociative - , nothingSymbol, trueSymbol, falseSymbol - -- * Terms - , Term(..), IsTerm(..), termView - , fromTermM, fromTermWith - -- * Functions and symbols - , WithFunctions(..), isSymbol, isFunction - , unary, binary, ternary, isUnary, isBinary - -- * Variables - , WithVars(..), isVariable - , vars, varSet, hasVar, withoutVar - , hasSomeVar, hasNoVar, variableView - -- * Meta variables - , WithMetaVars(..), isMetaVar - , metaVars, metaVarSet, hasMetaVar, nextMetaVar + ( module Ideas.Common.Rewriting.Term.Data + , module Ideas.Common.Rewriting.Term.Decoder + , module Ideas.Common.Rewriting.Term.Class ) where -import Control.Monad -import Data.Function -import Data.Maybe -import Ideas.Common.Id -import Ideas.Common.View -import Ideas.Utils.Prelude (ShowString(..)) -import Ideas.Utils.QuickCheck hiding (function) -import Ideas.Utils.Uniplate -import qualified Data.IntSet as IS -import qualified Data.Map as M -import qualified Data.Set as S - ------------------------------------------------------------ --- Symbols - -data Symbol = S { isAssociative :: Bool, symbolId :: Id } - -instance Eq Symbol where - (==) = (==) `on` getId -- without associativity property - -instance Ord Symbol where - compare = compareId -- without associativity property - -instance Show Symbol where - show = showId - -instance Read Symbol where - readsPrec n = map f . readsPrec n - where - f :: (Id, String) -> (Symbol, String) - f (a, s) = (newSymbol a, s) - -instance HasId Symbol where - getId = symbolId - changeId f (S b a) = S b (f a) - -newSymbol :: IsId a => a -> Symbol -newSymbol = S False . newId - -makeAssociative :: Symbol -> Symbol -makeAssociative (S _ a) = S True a - ------------------------------------------------------------ --- * Data type for terms - -data Term = TVar String - | TCon Symbol [Term] - | TList [Term] - | TNum Integer - | TFloat Double - | TMeta Int - deriving (Show, Read, Eq, Ord) - -instance Uniplate Term where - uniplate (TCon x xs) = plate (function x) ||* xs - uniplate (TList xs) = plate TList ||* xs - uniplate term = plate term - ------------------------------------------------------------ --- * Type class for conversion to/from terms - -class IsTerm a where - toTerm :: a -> Term - toTermList :: [a] -> Term - fromTerm :: MonadPlus m => Term -> m a - fromTermList :: MonadPlus m => Term -> m [a] - -- default implementation - toTermList = TList . map toTerm - fromTermList (TList xs) = mapM fromTerm xs - fromTermList _ = fail "fromTermList: not a list" - -termView :: IsTerm a => View Term a -termView = makeView fromTerm toTerm - -instance IsTerm Term where - toTerm = id - fromTerm = return - -instance IsTerm ShowString where - toTerm = TVar . fromShowString - fromTerm (TVar s) = return (ShowString s) - fromTerm _ = fail "fromTerm" - -instance (IsTerm a, IsTerm b) => IsTerm (a, b) where - toTerm (a, b) = TList [toTerm a, toTerm b] - fromTerm (TList [a, b]) = (,) <$> fromTerm a <*> fromTerm b - fromTerm _ = fail "fromTerm" - -instance (IsTerm a, IsTerm b, IsTerm c) => IsTerm (a, b, c) where - toTerm (a, b, c) = TList [toTerm a, toTerm b, toTerm c] - fromTerm (TList [a, b, c]) = (,,) <$> fromTerm a <*> fromTerm b <*> fromTerm c - fromTerm _ = fail "fromTerm" - -instance (IsTerm a, IsTerm b) => IsTerm (Either a b) where - toTerm = either toTerm toTerm - fromTerm expr = - fmap Left (fromTerm expr) `mplus` - fmap Right (fromTerm expr) - -instance IsTerm Int where - toTerm = TNum . fromIntegral - fromTerm = fmap fromInteger . fromTerm - -instance IsTerm Integer where - toTerm = TNum - fromTerm (TNum a) = return a - fromTerm _ = fail "fromTerm" - -instance IsTerm Double where - toTerm = TFloat - fromTerm (TFloat a) = return a - fromTerm _ = fail "fromTerm" - -instance IsTerm Char where - toTerm c = TVar [c] - toTermList = TVar - fromTerm (TVar [c]) = return c - fromTerm _ = fail "fromTerm: not a TVar" - fromTermList (TVar s) = return s - fromTermList _ = fail "fromTermList: not a TVar" - -instance IsTerm Bool where - toTerm True = symbol trueSymbol - toTerm False = symbol falseSymbol - fromTerm (TCon s []) - | s == trueSymbol = return True - | s == falseSymbol = return False - fromTerm _ = fail "fromTerm: not a Bool" - -instance IsTerm a => IsTerm [a] where - toTerm = toTermList - fromTerm = fromTermList - -instance (IsTerm a, Ord a) => IsTerm (S.Set a) where - toTerm = toTerm . S.toList - fromTerm = fmap S.fromList . fromTerm - -instance (IsTerm a, IsTerm b, Ord a) => IsTerm (M.Map a b) where - toTerm = toTerm . M.toList - fromTerm = fmap M.fromList . fromTerm - -trueSymbol, falseSymbol, nothingSymbol :: Symbol -trueSymbol = newSymbol "true" -falseSymbol = newSymbol "false" -nothingSymbol = newSymbol "Nothing" - -instance IsTerm a => IsTerm (Maybe a) where - toTerm = maybe (symbol nothingSymbol) toTerm - fromTerm (TCon s []) | s == nothingSymbol = return Nothing - fromTerm t = fmap Just (fromTerm t) - -fromTermM :: (Monad m, IsTerm a) => Term -> m a -fromTermM = maybe (fail "fromTermM") return . fromTerm - -fromTermWith :: (Monad m, IsTerm a) => (Symbol -> [a] -> m a) -> Term -> m a -fromTermWith f a = do - (s, xs) <- getFunction a - ys <- mapM fromTermM xs - f s ys - ------------------------------------------------------------ --- * Functions and symbols - -class WithFunctions a where - -- constructing - symbol :: Symbol -> a - function :: Symbol -> [a] -> a - -- matching - getSymbol :: Monad m => a -> m Symbol - getFunction :: Monad m => a -> m (Symbol, [a]) - -- default definition - symbol s = function s [] - getSymbol a = - case getFunction a of - Just (t, []) -> return t - _ -> fail "Ideas.Common.Term.getSymbol" - -instance WithFunctions Term where - function = TCon - getFunction (TCon s xs) = return (s, xs) - getFunction _ = fail "Ideas.Common.Rewriting.getFunction" - -isSymbol :: WithFunctions a => Symbol -> a -> Bool -isSymbol s = (== Just s) . getSymbol - -isFunction :: (WithFunctions a, Monad m) => Symbol -> a -> m [a] -isFunction s a = - case getFunction a of - Just (t, as) | s == t -> return as - _ -> fail "Ideas.Common.Term.isFunction" - -unary :: WithFunctions a => Symbol -> a -> a -unary s a = function s [a] - -binary :: WithFunctions a => Symbol -> a -> a -> a -binary s a b = function s [a, b] - -ternary :: WithFunctions a => Symbol -> a -> a -> a -> a -ternary s a b c = function s [a, b, c] - -isUnary :: (WithFunctions a, Monad m) => Symbol -> a -> m a -isUnary s a = - case isFunction s a of - Just [x] -> return x - _ -> fail "Ideas.Common.Term.isUnary" - -isBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a) -isBinary s a = - case isFunction s a of - Just [x, y] -> return (x, y) - _ -> fail "Ideas.Common.Term.isBinary" - ------------------------------------------------------------ --- * Variables - -class WithVars a where - variable :: String -> a - getVariable :: Monad m => a -> m String - -instance WithVars Term where - variable = TVar - getVariable (TVar s) = return s - getVariable _ = fail "Ideas.Common.Rewriting.getVariable" - -isVariable :: WithVars a => a -> Bool -isVariable = isJust . getVariable - -vars :: (Uniplate a, WithVars a) => a -> [String] -vars = concatMap getVariable . universe - -varSet :: (Uniplate a, WithVars a) => a -> S.Set String -varSet = S.fromList . vars - -hasVar :: (Uniplate a, WithVars a) => String -> a -> Bool -hasVar i = (i `elem`) . vars - -withoutVar :: (Uniplate a, WithVars a) => String -> a -> Bool -withoutVar i = not . hasVar i - -hasSomeVar :: (Uniplate a, WithVars a) => a -> Bool -hasSomeVar = not . hasNoVar - -hasNoVar :: (Uniplate a, WithVars a) => a -> Bool -hasNoVar = null . vars - -variableView :: WithVars a => View a String -variableView = makeView getVariable variable - ------------------------------------------------------------ --- * Meta variables - -class WithMetaVars a where - metaVar :: Int -> a - getMetaVar :: Monad m => a -> m Int - -instance WithMetaVars Term where - metaVar = TMeta - getMetaVar (TMeta i) = return i - getMetaVar _ = fail "Ideas.Common.Rewriting.getMetaVar" - -isMetaVar :: WithMetaVars a => a -> Bool -isMetaVar = isJust . getMetaVar - -metaVars :: (Uniplate a, WithMetaVars a) => a -> [Int] -metaVars = concatMap getMetaVar . universe - -metaVarSet :: (Uniplate a, WithMetaVars a) => a -> IS.IntSet -metaVarSet = IS.fromList . metaVars - -hasMetaVar :: (Uniplate a, WithMetaVars a) => Int -> a -> Bool -hasMetaVar i = (i `elem`) . metaVars - -nextMetaVar :: (Uniplate a, WithMetaVars a) => a -> Int -nextMetaVar a - | null is = 0 - | otherwise = maximum is + 1 - where - is = metaVars a - ------------------------------------------------------------ --- * Arbitrary term generator - -instance Arbitrary Term where - arbitrary = generators - [ constGens $ map TVar ["x", "y", "z"] - , arbGen TNum, arbGen TFloat, arbGen TMeta - , constGens $ map (symbol . newSymbol) ["a", "b"] - , unaryGens $ map (unary . newSymbol) ["h", "k"] - , binaryGens $ map (binary . newSymbol) ["f", "g"] - ]+import Ideas.Common.Rewriting.Term.Data +import Ideas.Common.Rewriting.Term.Decoder hiding (Alternative(..)) +import Ideas.Common.Rewriting.Term.Class
+ src/Ideas/Common/Rewriting/Term/Class.hs view
@@ -0,0 +1,249 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-- Generic terms+--+-----------------------------------------------------------------------------++module Ideas.Common.Rewriting.Term.Class+ ( -- * Terms+ IsTerm(..), termView+ , nothingSymbol, trueSymbol, falseSymbol+ -- * Functions and symbols+ , WithFunctions(..), isSymbol, isFunction+ , unary, binary, ternary, isUnary, isBinary+ -- * Variables+ , WithVars(..), isVariable+ , vars, varSet, hasVar, withoutVar+ , hasSomeVar, hasNoVar, variableView+ -- * Meta variables+ , WithMetaVars(..), isMetaVar+ , metaVars, metaVarSet, hasMetaVar, nextMetaVar+ ) where++import Data.Maybe+import Ideas.Common.Rewriting.Term.Data+import Ideas.Common.Rewriting.Term.Decoder+import Ideas.Common.Id+import Ideas.Common.View+import Ideas.Utils.Decoding+import Ideas.Utils.Prelude (ShowString(..))+import Ideas.Utils.Uniplate+import qualified Data.IntSet as IS+import qualified Data.Map as M+import qualified Data.Set as S++-----------------------------------------------------------+-- * Type class for conversion to/from terms++class IsTerm a where+ toTerm :: a -> Term+ toTermList :: [a] -> Term+ fromTerm :: Term -> Maybe a+ termDecoder :: TermDecoder a+ termListDecoder :: TermDecoder [a]++ {-# MINIMAL toTerm, termDecoder #-}++ -- default implementation+ toTermList = TList . map toTerm+ fromTerm t = either (const Nothing) Just (evalDecoder termDecoder () [t])+ termListDecoder = tListOf termDecoder++termView :: IsTerm a => View Term a+termView = makeView fromTerm toTerm++instance IsTerm Term where+ toTerm = id+ termDecoder = tFirst $ maybe (errorStr "not a term") return++instance IsTerm ShowString where+ toTerm = TVar . fromShowString+ termDecoder = ShowString <$> tVar++instance (IsTerm a, IsTerm b) => IsTerm (a, b) where+ toTerm (a, b) = TList [toTerm a, toTerm b]+ termDecoder = tList2 (,) termDecoder termDecoder++instance (IsTerm a, IsTerm b, IsTerm c) => IsTerm (a, b, c) where+ toTerm (a, b, c) = TList [toTerm a, toTerm b, toTerm c]+ termDecoder = tList3 (,,) termDecoder termDecoder termDecoder++instance (IsTerm a, IsTerm b) => IsTerm (Either a b) where+ toTerm = either toTerm toTerm+ termDecoder = Left <$> termDecoder <|> Right <$> termDecoder++instance IsTerm Int where+ toTerm = TNum . fromIntegral+ termDecoder = fromInteger <$> tInteger++instance IsTerm Integer where+ toTerm = TNum+ termDecoder = tInteger++instance IsTerm Double where+ toTerm = TFloat+ termDecoder = tDouble++instance IsTerm Float where+ toTerm = TFloat . realToFrac+ termDecoder = realToFrac <$> tDouble++instance IsTerm Char where+ toTerm c = TVar [c]+ toTermList = TVar+ termDecoder = tChar+ termListDecoder = tVar++instance IsTerm Bool where+ toTerm True = symbol trueSymbol+ toTerm False = symbol falseSymbol+ termDecoder = True <$ tCon0 trueSymbol <|> False <$ tCon0 falseSymbol++instance IsTerm Id where+ toTerm = toTerm . show+ termDecoder = newId <$> tVar++instance IsTerm a => IsTerm [a] where+ toTerm = toTermList+ termDecoder = termListDecoder++instance (IsTerm a, Ord a) => IsTerm (S.Set a) where+ toTerm = toTerm . S.toList+ termDecoder = S.fromList <$> termDecoder++instance (IsTerm a, IsTerm b, Ord a) => IsTerm (M.Map a b) where+ toTerm = toTerm . M.toList+ termDecoder = M.fromList <$> termDecoder++trueSymbol, falseSymbol, nothingSymbol :: Symbol+trueSymbol = newSymbol "true"+falseSymbol = newSymbol "false"+nothingSymbol = newSymbol "Nothing"++instance IsTerm a => IsTerm (Maybe a) where+ toTerm = maybe (symbol nothingSymbol) toTerm+ termDecoder = Just <$> termDecoder <|> Nothing <$ tCon0 nothingSymbol++-----------------------------------------------------------+-- * Functions and symbols++class WithFunctions a where+ -- constructing+ symbol :: Symbol -> a+ function :: Symbol -> [a] -> a+ -- matching+ getSymbol :: a -> Maybe Symbol+ getFunction :: a -> Maybe (Symbol, [a])+ -- default definition+ symbol s = function s []+ getSymbol a = fst <$> getFunction a++instance WithFunctions Term where+ function = TCon+ getFunction (TCon s xs) = Just (s, xs)+ getFunction _ = Nothing++isSymbol :: WithFunctions a => Symbol -> a -> Bool+isSymbol s = (== Just s) . getSymbol++isFunction :: WithFunctions a => Symbol -> a -> Maybe [a]+isFunction s a =+ case getFunction a of+ Just (t, as) | s == t -> Just as+ _ -> Nothing++unary :: WithFunctions a => Symbol -> a -> a+unary s a = function s [a]++binary :: WithFunctions a => Symbol -> a -> a -> a+binary s a b = function s [a, b]++ternary :: WithFunctions a => Symbol -> a -> a -> a -> a+ternary s a b c = function s [a, b, c]++isUnary :: WithFunctions a => Symbol -> a -> Maybe a+isUnary s a =+ case isFunction s a of+ Just [x] -> Just x+ _ -> Nothing++isBinary :: WithFunctions a => Symbol -> a -> Maybe (a, a)+isBinary s a =+ case isFunction s a of+ Just [x, y] -> Just (x, y)+ _ -> Nothing++-----------------------------------------------------------+-- * Variables++class WithVars a where+ variable :: String -> a+ getVariable :: a -> Maybe String++instance WithVars Term where+ variable = TVar+ getVariable (TVar s) = Just s+ getVariable _ = Nothing++isVariable :: WithVars a => a -> Bool+isVariable = isJust . getVariable++vars :: (Uniplate a, WithVars a) => a -> [String]+vars = mapMaybe getVariable . universe++varSet :: (Uniplate a, WithVars a) => a -> S.Set String+varSet = S.fromList . vars++hasVar :: (Uniplate a, WithVars a) => String -> a -> Bool+hasVar i = (i `elem`) . vars++withoutVar :: (Uniplate a, WithVars a) => String -> a -> Bool+withoutVar i = not . hasVar i++hasSomeVar :: (Uniplate a, WithVars a) => a -> Bool+hasSomeVar = not . hasNoVar++hasNoVar :: (Uniplate a, WithVars a) => a -> Bool+hasNoVar = null . vars++variableView :: WithVars a => View a String+variableView = makeView getVariable variable++-----------------------------------------------------------+-- * Meta variables++class WithMetaVars a where+ metaVar :: Int -> a+ getMetaVar :: a -> Maybe Int++instance WithMetaVars Term where+ metaVar = TMeta+ getMetaVar (TMeta i) = Just i+ getMetaVar _ = Nothing++isMetaVar :: WithMetaVars a => a -> Bool+isMetaVar = isJust . getMetaVar++metaVars :: (Uniplate a, WithMetaVars a) => a -> [Int]+metaVars = mapMaybe getMetaVar . universe++metaVarSet :: (Uniplate a, WithMetaVars a) => a -> IS.IntSet+metaVarSet = IS.fromList . metaVars++hasMetaVar :: (Uniplate a, WithMetaVars a) => Int -> a -> Bool+hasMetaVar i = (i `elem`) . metaVars++nextMetaVar :: (Uniplate a, WithMetaVars a) => a -> Int+nextMetaVar a+ | null is = 0+ | otherwise = maximum is + 1+ where+ is = metaVars a
+ src/Ideas/Common/Rewriting/Term/Data.hs view
@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-- A simple data type for term rewriting+--+-----------------------------------------------------------------------------++module Ideas.Common.Rewriting.Term.Data+ ( -- * Symbols+ Symbol, newSymbol+ , isAssociative, makeAssociative+ -- * Terms+ , Term(..)+ ) where++import Data.Function+import Ideas.Common.Id+import Ideas.Utils.QuickCheck hiding (function)+import Ideas.Utils.Uniplate++-----------------------------------------------------------+-- Symbols++data Symbol = S { isAssociative :: Bool, symbolId :: Id }++instance Eq Symbol where+ (==) = (==) `on` getId -- without associativity property++instance Ord Symbol where+ compare = compareId -- without associativity property++instance Show Symbol where+ show = showId++instance Read Symbol where+ readsPrec n = map f . readsPrec n+ where+ f :: (Id, String) -> (Symbol, String)+ f (a, s) = (newSymbol a, s)++instance HasId Symbol where+ getId = symbolId+ changeId f (S b a) = S b (f a)++newSymbol :: IsId a => a -> Symbol+newSymbol = S False . newId++makeAssociative :: Symbol -> Symbol+makeAssociative (S _ a) = S True a++-----------------------------------------------------------+-- * Data type for terms++data Term = TVar String+ | TCon Symbol [Term]+ | TList [Term]+ | TNum Integer+ | TFloat Double+ | TMeta Int+ deriving (Show, Read, Eq, Ord)++instance Uniplate Term where+ uniplate (TCon x xs) = plate (TCon x) ||* xs+ uniplate (TList xs) = plate TList ||* xs+ uniplate term = plate term++-----------------------------------------------------------+-- * Arbitrary term generator++instance Arbitrary Term where+ arbitrary = generators+ [ constGens $ map TVar ["x", "y", "z"]+ , arbGen TNum, arbGen TFloat, arbGen TMeta+ , constGens $ map (\s -> TCon (newSymbol s) []) ["a", "b"]+ , unaryGens $ map (\s x -> TCon (newSymbol s) [x]) ["h", "k"]+ , binaryGens $ map (\s x y -> TCon (newSymbol s) [x, y]) ["f", "g"]+ ]
+ src/Ideas/Common/Rewriting/Term/Decoder.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-- Generic terms+--+-----------------------------------------------------------------------------++module Ideas.Common.Rewriting.Term.Decoder+ ( TermDecoder+ , tCon, tCon0, tCon1, tCon2, tCon3, tConOf, tInteger, tDouble, tVar, tListOf, tConWithSymbol+ , tListWith, tList2, tList3, tChar, tFirst+ -- re-exports+ , Alternative(..), MonadReader(..), throwError+ ) where++import Control.Monad+import Ideas.Common.Rewriting.Term.Data+import Ideas.Utils.Decoding++-----------------------------------------------------------+-- * Type class for conversion to/from terms++type TermDecoder = Decoder () (Error Term) [Term]++tFirst :: (Maybe Term -> TermDecoder a) -> TermDecoder a+tFirst f = get >>= \xs ->+ case xs of+ t:rest -> f (Just t) <* changeLoc nextLoc <* put rest+ _ -> f Nothing++tVar :: TermDecoder String+tVar = tFirst $ \mt ->+ case mt of + Just (TVar s) -> return s+ _ -> raiseError "not a var" mt++tChar :: TermDecoder Char+tChar = tFirst $ \mt ->+ case mt of + Just (TVar [c]) -> return c+ _ -> raiseError "not a char" mt++tInteger :: TermDecoder Integer+tInteger = tFirst $ \mt ->+ case mt of + Just (TNum i) -> return i+ _ -> raiseError "not an integer" mt++tDouble :: TermDecoder Double+tDouble = tFirst $ \mt ->+ case mt of + Just (TFloat f) -> return f+ _ -> raiseError "not a double" mt++-- name tList clashes with service type+tListWith :: TermDecoder a -> TermDecoder a+tListWith p = tFirst $ \mt ->+ case mt of + Just (TList xs) -> changeLoc (LocByPos 0) >> put xs *> p <* tEmpty+ _ -> raiseError "not a list" mt++tCon :: Symbol -> TermDecoder a -> TermDecoder a+tCon s1 p = tFirst $ \mt ->+ case mt of + Just (TCon s2 xs) | s1 == s2 -> changeLoc (LocByPos 0) >> put xs *> p <* tEmpty+ _ -> raiseError ("not con '" ++ show s1 ++ "'") mt++tEmpty :: TermDecoder ()+tEmpty = get >>= \xs -> unless (null xs) (errorStr "not empty") ++tCon0 :: Symbol -> TermDecoder ()+tCon0 s = tCon s (return ())++tCon1 :: Symbol -> (a -> b) -> TermDecoder a -> TermDecoder b+tCon1 s f p = tCon s (f <$> p)++tCon2 :: Symbol -> (a -> b -> c) -> TermDecoder a -> TermDecoder b -> TermDecoder c+tCon2 s f p q = tCon s (f <$> p <*> q)++tCon3 :: Symbol -> (a -> b -> c -> d) -> TermDecoder a -> TermDecoder b -> TermDecoder c -> TermDecoder d+tCon3 s f p q r = tCon s (f <$> p <*> q <*> r)++tConOf :: Symbol -> TermDecoder a -> TermDecoder [a]+tConOf s p = tCon s (many p)++tConWithSymbol :: (Symbol -> [a] -> b) -> TermDecoder a -> TermDecoder b+tConWithSymbol f p = tFirst $ \mt ->+ case mt of + Just (TCon s xs) -> f s <$ changeLoc (LocByPos 0) <* put xs <*> many p <* tEmpty+ _ -> raiseError "not a con" mt++tList2 :: (a -> b -> c) -> TermDecoder a -> TermDecoder b -> TermDecoder c+tList2 f p q = tListWith $ f <$> p <*> q++tList3 :: (a -> b -> c -> d) -> TermDecoder a -> TermDecoder b -> TermDecoder c -> TermDecoder d+tList3 f p q r = tListWith $ f <$> p <*> q <*> r++tListOf :: TermDecoder a -> TermDecoder [a]+tListOf p = tListWith $ many p
src/Ideas/Common/Rewriting/Unification.hs view
@@ -51,30 +51,30 @@ return (s2 @@ s1) rec _ _ = fail "match: no unifier" -match :: MonadPlus m => Term -> Term -> m Substitution +match :: Term -> Term -> Maybe Substitution match term1 term2 = case (term1, term2) of (TMeta i, TMeta j) | i == j -> - return emptySubst + Just emptySubst (TMeta i, _) | not (i `hasMetaVar` term2) -> - return (singletonSubst i term2) + Just (singletonSubst i term2) (_, TMeta _) -> - fail "match: no unifier" + Nothing (TCon s xs, TCon t ys) | s == t -> rec xs ys (TList xs, TList ys) -> rec xs ys _ | term1 == term2 -> - return emptySubst - _ -> fail "match: no unifier" + Just emptySubst + _ -> Nothing where - rec [] [] = return emptySubst + rec [] [] = Just emptySubst rec (x:xs) (y:ys) = do s1 <- match x y s2 <- rec (map (s1 |->) xs) ys guard (composable s1 s2) - return (s1 @@ s2) - rec _ _ = fail "match: no unifier" + Just (s1 @@ s2) + rec _ _ = Nothing ----------------------------------------------------------- -- Matching (or: one-way unification)
src/Ideas/Common/Rule/Abstract.hs view
@@ -70,10 +70,10 @@ getId = ruleId changeId f r = r { ruleId = f (ruleId r) } -instance LiftView Rule where - liftViewIn v r = r - { getTrans = transLiftViewIn v (getTrans r) - , getRecognizer = liftViewIn v (getRecognizer r) +instance Lift Rule where + liftWithM l r = r + { getTrans = transLift l (getTrans r) + , getRecognizer = liftWithM l (getRecognizer r) } instance Recognizable Rule where
src/Ideas/Common/Rule/Recognizer.hs view
@@ -38,10 +38,10 @@ newtype Recognizer a = R { unR :: Trans (a, a) () } -instance LiftView Recognizer where - liftViewIn v r = - let f = fmap fst . match v - in R $ makeTrans f *** makeTrans f >>> unR r +instance Lift Recognizer where + liftWithM f r = + let t = makeTrans (fmap fst . f) + in R (t *** t >>> unR r) instance Sem.Semigroup (Recognizer a) where f <> g = R $ unR f `mappend` unR g
src/Ideas/Common/Rule/Transformation.hs view
@@ -25,7 +25,7 @@ , writeRef, writeRef_, writeRefMaybe -- * Lifting transformations , transUseEnvironment - , transLiftView, transLiftViewIn + , transLiftView, transLiftViewIn, transLift , transLiftContext, transLiftContextIn -- * Using transformations , transApply, transApplyWith @@ -162,6 +162,9 @@ transLiftViewIn :: View a (b, c) -> Transformation b -> Transformation a transLiftViewIn v f = makeTrans (match v) >>> first f >>^ build v + +transLift :: (a -> Maybe (b, b -> a)) -> Transformation b -> Transformation a +transLift f t = makeTrans f >>> first t >>^ (\(x, g) -> g x) transLiftContext :: Transformation a -> Transformation (Context a) transLiftContext = transLiftContextIn . transUseEnvironment
src/Ideas/Common/Strategy/Abstract.hs view
@@ -163,12 +163,11 @@ -- | Construct a prefix for a path and a labeled strategy. The third argument -- is the initial term. -replayStrategy :: (Monad m, IsStrategy f) => Path -> f a -> a -> m (a, Prefix a) -replayStrategy path s a = +replayStrategy :: IsStrategy f => Path -> f a -> a -> Maybe (a, Prefix a) +replayStrategy path s a = do let (xs, f) = replayProcess path (getProcess s) - in case applyList xs a of - Just b -> return (b, f b) - Nothing -> fail "Cannot replay strategy" + b <- applyList xs a + return (b, f b) ----------------------------------------------------------- --- Remaining functions @@ -192,11 +191,11 @@ f (LeafRule r) | isMajor r = [r] f _ = [] -instance LiftView LabeledStrategy where - liftViewIn v (LS n s) = LS n (liftViewIn v s) +instance Lift LabeledStrategy where + liftWithM f (LS n s) = LS n (liftWithM f s) -instance LiftView Strategy where - liftViewIn v = S . fmap (liftViewIn v) . toStrategyTree +instance Lift Strategy where + liftWithM f = S . fmap (liftWithM f) . toStrategyTree -- | Apply a function to all the rules that make up a labeled strategy mapRules :: (Rule a -> Rule a) -> LabeledStrategy a -> LabeledStrategy a
src/Ideas/Common/Strategy/CyclicTree.hs view
@@ -61,8 +61,7 @@ p <*> q = fold idAlg {fLeaf = (<$> q)} p instance Monad (CyclicTree d) where - return = leaf - (>>=) = flip replaceLeaf + (>>=) = flip replaceLeaf instance Foldable (CyclicTree d) where foldMap f = fold monoidAlg {fLeaf = f}
src/Ideas/Common/Strategy/Prefix.hs view
@@ -196,8 +196,8 @@ emptyPath :: Path emptyPath = Path [] -readPath :: Monad m => String -> m Path +readPath :: String -> Maybe Path readPath = fmap Path . readM -readPaths :: Monad m => String -> m [Path] +readPaths :: String -> Maybe [Path] readPaths = mapM readPath . splitsWithElem ';'
src/Ideas/Common/Strategy/StrategyTree.hs view
@@ -79,9 +79,9 @@ applyAll (LeafRule r) a = applyAll r a applyAll (LeafDyn d) a = applyAll d a -instance LiftView Leaf where - liftViewIn v (LeafRule r) = LeafRule (liftViewIn v r) - liftViewIn v (LeafDyn d) = LeafDyn (liftViewIn v d) +instance Lift Leaf where + liftWithM f (LeafRule r) = LeafRule (liftWithM f r) + liftWithM f (LeafDyn d) = LeafDyn (liftWithM f d) treeToProcess :: StrategyTree a -> Process (Leaf a) treeToProcess = foldUnwind emptyAlg @@ -128,10 +128,10 @@ instance Apply Dynamic where applyAll d a = maybe [] ((`runProcess` a) . treeToProcess) (dynamicTree d a) -instance LiftView Dynamic where - liftViewIn v d = d - { dynamicToTerm = fmap fst . match v >=> dynamicToTerm d - , dynamicFromTerm = fmap (fmap (liftViewIn v)) . dynamicFromTerm d +instance Lift Dynamic where + liftWithM f d = d + { dynamicToTerm = fmap fst . f >=> dynamicToTerm d + , dynamicFromTerm = fmap (fmap (liftWithM f)) . dynamicFromTerm d } makeDynamic :: (IsId n, IsTerm a) => n -> (a -> StrategyTree a) -> Dynamic a
src/Ideas/Common/Strategy/Traversal.hs view
@@ -31,7 +31,6 @@ ) where import Data.Monoid hiding ((<>)) -import Data.Semigroup ((<>)) import Ideas.Common.Classes import Ideas.Common.Rule import Ideas.Common.Strategy.Abstract
src/Ideas/Common/Traversal/Tests.hs view
@@ -17,7 +17,6 @@ import Control.Monad import Data.Maybe -import Data.Semigroup as Sem import Ideas.Common.Traversal.Iterator import Ideas.Common.Traversal.Navigator import Ideas.Common.Traversal.Utils
src/Ideas/Common/View.hs view
@@ -19,7 +19,7 @@ , Control.Arrow.ArrowZero(..), Control.Arrow.ArrowPlus(..) , (>>>), (<<<) -- * @IsMatch@ type class - , IsMatcher(..), matchM, belongsTo, viewEquivalent, viewEquivalentWith + , IsMatcher(..), belongsTo, viewEquivalent, viewEquivalentWith , Matcher, makeMatcher -- * @IsView@ type class , IsView(..), simplify, simplifyWith, simplifyWithM @@ -29,7 +29,7 @@ -- * Isomorphisms , Isomorphism, from, to, inverse -- * Lifting with views - , LiftView(..) + , Lift(..), liftView, liftViewIn -- * Some combinators , swapView, listView, traverseView, ($<) -- * Packaging a view @@ -56,10 +56,6 @@ match = runKleisli . unM . matcher matcher = makeMatcher . match --- |generalized monadic variant of @match@ -matchM :: (Monad m, IsMatcher f) => f a b -> a -> m b -matchM v = maybe (fail "no match") return . match v - belongsTo :: IsMatcher f => a -> f a b -> Bool belongsTo a view = isJust (match view a) @@ -236,11 +232,17 @@ ---------------------------------------------------------------------------------- -- Type class for lifting with Views -class LiftView f where - liftView :: View a b -> f b -> f a - liftViewIn :: View a (b, c) -> f b -> f a - -- default definition - liftView v = liftViewIn (v &&& identity) +liftView :: Lift f => View a b -> f b -> f a +liftView v = liftWithM $ fmap (\b -> (b, build v)) . match v + +liftViewIn :: Lift f => View a (b, c) -> f b -> f a +liftViewIn v = liftWithM $ fmap (\(b, c) -> (b, \x -> build v (x, c))) . match v + +class Lift f where + liftWith :: (a -> (b, b -> a)) -> f b -> f a + liftWithM :: (a -> Maybe (b, b -> a)) -> f b -> f a + -- default + liftWith f = liftWithM (Just . f) ---------------------------------------------------------------------------------- -- Some combinators
src/Ideas/Encoding/DecoderJSON.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs, FlexibleInstances #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -14,30 +14,32 @@ ----------------------------------------------------------------------------- module Ideas.Encoding.DecoderJSON - ( JSONDecoder, jsonDecoder + ( JSONDecoder, jsonTypeDecoder ) where -import Control.Monad.State (mplus, foldM, get, gets, put) +import Control.Monad.State (get, gets) import Data.Char import Data.Maybe import Ideas.Common.Library hiding (exerciseId, symbol) import Ideas.Common.Traversal.Navigator import Ideas.Encoding.Encoder +import Ideas.Encoding.Options import Ideas.Service.State import Ideas.Service.Types hiding (String) import Ideas.Text.JSON -import Ideas.Utils.Decoding (symbol) import qualified Ideas.Service.Types as Tp -type JSONDecoder a t = DecoderX a JSON t +type JSONDecoder a = GDecoderJSON (Exercise a, Options) -jsonDecoder :: TypedDecoder a JSON -jsonDecoder tp = get >>= \json -> - case json of - Array xs -> decodeType tp // xs - _ -> fail "expecting an array" +jsonTypeDecoder :: TypedDecoder a JSON +jsonTypeDecoder tp = do + env <- reader id + json <- get + case evalGDecoderJSON (jArray (decodeType tp)) env json of + Left err -> throwError (show err) + Right a -> return a -decodeType :: Type a t -> DecoderX a [JSON] t +decodeType :: Type a t -> JSONDecoder a t decodeType tp = case tp of Tag _ t -> decodeType t @@ -47,74 +49,71 @@ b <- decodeType t2 return (a, b) t1 :|: t2 -> - (Left <$> decodeType t1) `mplus` - (Right <$> decodeType t2) + Left <$> decodeType t1 <|> + Right <$> decodeType t2 Unit -> return () Const QCGen -> getQCGen Const Script -> getScript - Const t -> symbol >>= \a -> decodeConst t // a - _ -> fail $ "No support for argument type: " ++ show tp + Const t -> decodeConst t + _ -> errorStr $ "No support for argument type: " ++ show tp decodeConst :: Const a t -> JSONDecoder a t decodeConst tp = case tp of State -> decodeState Context -> decodeContext - Exercise -> getExercise + Exercise -> getExercise <* jSkip Environment -> decodeEnvironment Location -> decodeLocation - Term -> gets jsonToTerm - Int -> get >>= fromJSON - Tp.String -> get >>= fromJSON + Term -> gets (jsonToTerm . toJSON) + Int -> jInt + Tp.String -> jString Id -> decodeId Rule -> decodeRule - _ -> fail $ "No support for argument type: " ++ show tp + _ -> errorStr $ "No support for argument type: " ++ show tp decodeRule :: JSONDecoder a (Rule (Context a)) decodeRule = do - ex <- getExercise - get >>= \json -> - case json of - String s -> getRule ex (newId s) - _ -> fail "expecting a string for rule" + ex <- getExercise + rid <- newId <$> jString + case getRule ex rid of + Just r -> return r + Nothing -> errorStr ("unknown rule " ++ show rid) decodeId :: JSONDecoder a Id -decodeId = get >>= \json -> - case json of - String s -> return (newId s) - _ -> fail "expecting a string for id" +decodeId = newId <$> jString decodeLocation :: JSONDecoder a Location -decodeLocation = get >>= \json -> - case json of - String s -> toLocation <$> readM s - _ -> fail "expecting a string for a location" +decodeLocation = jString >>= \s -> + case readM s of + Just is -> return (toLocation is) + Nothing -> errorStr "invalid location" decodeState :: JSONDecoder a (State a) -decodeState = do - ex <- getExercise - get >>= \json -> - case json of - Array [a] -> put a >> decodeState - Array (String _code : pref : term : jsonContext : rest) -> do - pts <- decodePaths // pref - a <- decodeExpression // term - env <- decodeEnvironment // jsonContext - let loc = envToLoc env - ctx = navigateTowards loc $ deleteRef locRef $ - setEnvironment env $ inContext ex a - prfx = pts (strategy ex) ctx - case rest of - [] -> return $ makeState ex prfx ctx - [Array [String user, String session, String startterm]] -> - return (makeState ex prfx ctx) - { stateUser = Just user - , stateSession = Just session - , stateStartTerm = Just startterm - } - _ -> fail $ "invalid state" ++ show json - _ -> fail $ "invalid state" ++ show json +decodeState = jArray1 decodeState <|> jArray content + where + content = do + ex <- getExercise + _ <- jString -- exercise id + pts <- decodePaths + a <- decodeExpression + env <- decodeEnvironment + let loc = envToLoc env + ctx = navigateTowards loc $ deleteRef locRef $ + setEnvironment env $ inContext ex a + prfx = pts (strategy ex) ctx + defState = makeState ex prfx ctx + + (extra <|> id <$ jEmpty) <*> pure defState + extra = jArray3 f jString jString jString + where + f user session startterm st = st + { stateUser = Just user + , stateSession = Just session + , stateStartTerm = Just startterm + } + envToLoc :: Environment -> Location envToLoc env = toLocation $ fromMaybe [] $ locRef ? env >>= readM @@ -122,40 +121,33 @@ locRef = makeRef "location" decodePaths :: JSONDecoder a (LabeledStrategy (Context a) -> Context a -> Prefix (Context a)) -decodePaths = - get >>= \json -> - case json of - String p - | p ~= "noprefix" -> return (\_ _ -> noPrefix) - | otherwise -> replayPaths <$> readPaths p - _ -> fail "invalid prefixes" +decodePaths = jString >>= \s -> + case readPaths s of + _ | s ~= "noprefix" + -> return (\_ _ -> noPrefix) + Just ps -> return (replayPaths ps) + Nothing -> errorStr "invalid path" where x ~= y = filter isAlphaNum (map toLower x) == y decodeEnvironment :: JSONDecoder a Environment -decodeEnvironment = get >>= \json -> - case json of - String "" -> return mempty - Object xs -> foldM (flip add) mempty xs - _ -> fail $ "invalid context: " ++ show json +decodeEnvironment = foldr ($) mempty <$> jObjectWithKeys f <|> mempty <$ jString {- only accept "" -} where - add (k, String s) = return . insertRef (makeRef k) s - add (k, Number n) = return . insertRef (makeRef k) (show n) - add _ = fail "invalid item in context" + f k = g <$> jString <|> g . show <$> jInt + where + g = insertRef (makeRef k) decodeContext :: JSONDecoder a (Context a) -decodeContext = do - ex <- getExercise - inContext ex <$> decodeExpression +decodeContext = inContext <$> getExercise <*> decodeExpression decodeExpression :: JSONDecoder a a -decodeExpression = withJSONTerm $ \b -> getExercise >>= \ex -> get >>= f b ex - where - f True ex json = - case hasJSONView ex of - Just v -> matchM v json - Nothing -> fail "JSON encoding not supported by exercise" - f False ex json = - case json of - String s -> either fail return (parser ex s) - _ -> fail "Expecting a string when reading a term"+decodeExpression = withJSONTerm $ \b -> + if b + then do + mv <- hasJSONView <$> getExercise + case mv of + Just v -> jNext (maybe (Left "cannot decode expression from JSON") Right . match v) + Nothing -> errorStr "JSON encoding not supported by exercise" + else do + ex <- getExercise + jString >>= either errorStr return . parser ex
src/Ideas/Encoding/DecoderXML.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings, GADTs #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -14,10 +14,11 @@ ----------------------------------------------------------------------------- module Ideas.Encoding.DecoderXML - ( XMLDecoder, xmlDecoder + ( XMLDecoder, xmlTypeDecoder ) where import Control.Applicative hiding (Const) +import Control.Monad ((>=>), foldM, guard, unless) import Control.Monad.State hiding (State) import Data.Char import Ideas.Common.Library @@ -30,39 +31,37 @@ import Ideas.Text.MathML import Ideas.Text.OpenMath.Object import Ideas.Text.XML +import Ideas.Utils.Decoding -type XMLDecoder a t = DecoderX a XML t +type XMLDecoder a t = DecoderX a String XML t -xmlDecoder :: TypedDecoder a XML -xmlDecoder tp = +xmlTypeDecoder :: TypedDecoder a XML +xmlTypeDecoder tp = case tp of Tag s (Const String) -> - decodeChild s decodeData - `mplus` - decodeAttribute s + decodeChild s decodeData <|> decodeAttribute s Tag s t | s == "answer" -> - decodeChild "answer" (xmlDecoder t) + decodeChild "answer" (xmlTypeDecoder t) | s == "Difficulty" -> do - g <- equalM tDifficulty tp + g <- either errorStr return (equalM tDifficulty tp) a <- decodeAttribute "difficulty" - maybe (fail "unknown difficulty level") (return . g) (readDifficulty a) + maybe (errorStr "unknown difficulty level") (return . g) (readDifficulty a) | otherwise -> - decodeChild s (xmlDecoder t) - Iso p t -> from p <$> xmlDecoder t + decodeChild s (xmlTypeDecoder t) + Iso p t -> from p <$> xmlTypeDecoder t List t -> do - x <- xmlDecoder t - xs <- xmlDecoder (List t) + x <- xmlTypeDecoder t + xs <- xmlTypeDecoder (List t) return (x:xs) - `mplus` + <|> return [] Pair t1 t2 -> do - x <- xmlDecoder t1 - y <- xmlDecoder t2 + x <- xmlTypeDecoder t1 + y <- xmlTypeDecoder t2 return (x, y) t1 :|: t2 -> - (Left <$> xmlDecoder t1) `mplus` - (Right <$> xmlDecoder t2) + Left <$> xmlTypeDecoder t1 <|> Right <$> xmlTypeDecoder t2 Unit -> return () Const ctp -> case ctp of @@ -70,7 +69,7 @@ Context -> decodeContext Rule -> decodeRule Environment -> decodeArgEnvironment - Term -> get >>= (fromXML >=> fromOMOBJ) + Term -> get >>= (fromXML' >=> maybe (errorStr "invalid OpenMath") return . fromOMOBJ) Location -> decodeLocation StratCfg -> decodeConfiguration QCGen -> getQCGen @@ -82,14 +81,15 @@ MathML -> decodeMathML String -> decodeData XML -> get - _ -> fail $ "No support for argument type in XML: " ++ show tp - _ -> fail $ "No support for argument type in XML: " ++ show tp + _ -> errorStr $ "No support for argument type in XML: " ++ show tp + _ -> errorStr $ "No support for argument type in XML: " ++ show tp -- <ruleid> decodeRule :: XMLDecoder a (Rule (Context a)) decodeRule = decodeChild "ruleid" $ do - ex <- getExercise - get >>= getRule ex . newId . getData + ex <- getExercise + xml <- get + maybe (errorStr "invalid rule") return . getRule ex . newId . getData $ xml -- <location> decodeLocation :: XMLDecoder a Location @@ -108,12 +108,12 @@ -- <prefix> decodePaths :: XMLDecoder a [Path] decodePaths = do - prefixText <- gets (maybe "" getData . findChild "prefix") + prefixText <- gets (either (const "") getData . findChild "prefix") if all isSpace prefixText then return [emptyPath] else if prefixText ~= "no prefix" then return [] - else readPaths prefixText + else maybe (errorStr "invalid paths") return (readPaths prefixText) where a ~= b = g a == g b g = map toLower . filter (not . isSpace) @@ -124,9 +124,9 @@ expr <- decodeExpression env <- decodeEnvironment let ctx = setEnvironment env (inContext ex expr) - locRef = makeRef "location" + locRef = makeRef ("location" :: String) case locRef ? env of - Just s -> maybe (fail "invalid location") return $ do + Just s -> maybe (errorStr "invalid location") return $ do loc <- toLocation <$> readM s navigateTo loc (deleteRef locRef ctx) Nothing -> @@ -138,18 +138,18 @@ f True = decodeOMOBJ f False = decodeChild "expr" $ do ex <- getExercise - get >>= either fail return . parser ex . getData + get >>= either errorStr return . parser ex . getData decodeOMOBJ :: XMLDecoder a a decodeOMOBJ = decodeChild "OMOBJ" $ get >>= \xml -> do ex <- getExercise - omobj <- fromXML xml + omobj <- fromXML' xml case fromOpenMath ex omobj of Just a -> return a - Nothing -> fail "Invalid OpenMath object for this exercise" + Nothing -> errorStr "Invalid OpenMath object for this exercise" decodeMathML :: XMLDecoder a MathML -decodeMathML = decodeFirstChild "math" $ get >>= fromXML +decodeMathML = decodeFirstChild "math" $ get >>= fromXML' decodeEnvironment :: XMLDecoder a Environment decodeEnvironment = @@ -157,20 +157,22 @@ <|> return mempty where add env item = do - unless (name item == "item") $ - fail $ "expecting item tag, found " ++ name item - n <- findAttribute "name" item + unless (getName item == "item") $ + errorStr $ "expecting item tag, found " ++ show (getName item) + n <- findAttribute' "name" item req <- getRequest case findChild "OMOBJ" item of -- OpenMath object found inside item tag - Just this | useOpenMath req -> - case xml2omobj this >>= fromOMOBJ of - Left err -> fail err - Right term -> - return $ insertRef (makeRef n) (term :: Term) env + Right this | useOpenMath req -> + case xml2omobj this of + Left err -> errorStr err + Right omobj -> + case fromOMOBJ omobj of + Just term -> return $ insertRef (makeRef n) (term :: Term) env + Nothing -> errorStr "invalid openmath" -- Simple value in attribute _ -> do - value <- findAttribute "value" item + value <- findAttribute' "value" item return $ insertRef (makeRef n) value env -- <configuration> @@ -181,8 +183,8 @@ where decodeAction item = do guard (null (children item)) - action <- readM (name item) - cfgloc <- findAttribute "name" item + action <- maybe (errorStr "invalid action") return $ readM (show (getName item)) + cfgloc <- findAttribute' "name" item return (action `byName` newId cfgloc) decodeArgEnvironment :: XMLDecoder a Environment @@ -191,16 +193,25 @@ decodeBinding :: XMLDecoder a Binding decodeBinding = get >>= \xml -> do - a <- findAttribute "description" xml + a <- findAttribute' "description" xml req <- getRequest case findChild "OMOBJ" xml of -- OpenMath object found inside tag - Just this | useOpenMath req -> - case xml2omobj this >>= fromOMOBJ of - Left err -> fail err - Right term -> return (termBinding a term) + Right this | useOpenMath req -> + case xml2omobj this of + Left err -> errorStr err + Right omobj -> + case fromOMOBJ omobj of + Just term -> return (termBinding a term) + Nothing -> errorStr "invalid openmath" -- Simple value _ -> return (makeBinding (makeRef a) (getData xml)) where termBinding :: String -> Term -> Binding - termBinding = makeBinding . makeRef+ termBinding = makeBinding . makeRef + +fromXML' :: InXML a => XML -> XMLDecoder s a +fromXML' = maybe (errorStr "fromXML'") return . fromXML + +findAttribute' :: String -> XML -> XMLDecoder a String +findAttribute' s = either errorStr return . findAttribute s
src/Ideas/Encoding/Encoder.hs view
@@ -46,37 +46,37 @@ ------------------------------------------------------------------- -- Converter type class -getExercise :: DecoderX a s (Exercise a) +getExercise :: DecoderX a err s (Exercise a) getExercise = reader fst -getOptions :: DecoderX a s Options +getOptions :: DecoderX a err s Options getOptions = reader snd -getRequest :: DecoderX a s Request +getRequest :: DecoderX a err s Request getRequest = request <$> getOptions -withExercise :: (Exercise a -> DecoderX a s t) -> DecoderX a s t +withExercise :: (Exercise a -> DecoderX a err s t) -> DecoderX a err s t withExercise = (getExercise >>=) -getBaseUrl :: DecoderX a s String -getBaseUrl = fromMaybe "http://ideas.cs.uu.nl/" . baseUrl <$> getOptions +getBaseUrl :: DecoderX a err s String +getBaseUrl = fromMaybe "https://ideas.science.uu.nl/" . baseUrl <$> getOptions -getQCGen :: DecoderX a s QCGen +getQCGen :: DecoderX a err s QCGen getQCGen = fromMaybe (mkQCGen 0) . qcGen <$> getOptions -getScript :: DecoderX a s Script +getScript :: DecoderX a err s Script getScript = script <$> getOptions -withOpenMath :: (Bool -> DecoderX a s t) -> DecoderX a s t +withOpenMath :: (Bool -> DecoderX a err s t) -> DecoderX a err s t withOpenMath = (fmap useOpenMath getRequest >>=) -withJSONTerm :: (Bool -> DecoderX a s t) -> DecoderX a s t +withJSONTerm :: (Bool -> DecoderX a err s t) -> DecoderX a err s t withJSONTerm = (fmap useJSONTerm getRequest >>=) -(//) :: Decoder env s a -> s -> Decoder env s2 a +(//) :: Decoder env err s a -> s -> Decoder env err s2 a p // a = do env <- ask - runDecoder p env a + either throwError return (evalDecoder p env a) ------------------------------------------------------------------- -- JSON terms @@ -105,9 +105,9 @@ | s == objectSymbol -> Object (f ts) | otherwise -> Object [("_apply", Array (JSON.String (show s):map termToJSON ts))] TList xs -> Array (map termToJSON xs) - TNum n -> Number (I n) - TFloat d -> Number (D d) - TMeta n -> Object [("_meta", Number (I (toInteger n)))] + TNum n -> Integer n + TFloat d -> Double d + TMeta n -> Object [("_meta", Integer (toInteger n))] where f [] = [] f (TVar s:x:xs) = (s, termToJSON x) : f xs @@ -116,12 +116,12 @@ jsonToTerm :: JSON -> Term jsonToTerm json = case json of - Number (I n) -> TNum n - Number (D d) -> TFloat d + Integer n -> TNum n + Double d -> TFloat d JSON.String s -> TVar s Boolean b -> Term.symbol (if b then trueSymbol else falseSymbol) Array xs -> TList (map jsonToTerm xs) - Object [("_meta", Number (I n))] -> TMeta (fromInteger n) + Object [("_meta", Integer n)] -> TMeta (fromInteger n) Object [("_apply", Array (JSON.String s:xs))] -> TCon (newSymbol s) (map jsonToTerm xs) Object xs -> TCon objectSymbol (concatMap f xs) Null -> Term.symbol nullSymbol @@ -165,7 +165,7 @@ ------------------------------------------------------------------- -- Encoder datatype -type EncoderX a = Encoder (Exercise a, Options) +type EncoderX a = Encoder (Exercise a, Options) String type TypedEncoder a b = TypedValue (Type a) -> EncoderX a b @@ -178,11 +178,11 @@ Nothing -> q tv encodeTyped :: (t -> EncoderX a b) -> Type a t -> TypedEncoder a b -encodeTyped p t = (p, t) <?> fail "Types do not match" +encodeTyped p t1 tv@(_ ::: t2) = ((p, t1) <?> (\_ -> errorStr ("Types do not match: " ++ show t1 ++ " and " ++ show t2))) tv ------------------------------------------------------------------- -- Decoder datatype type DecoderX a = Decoder (Exercise a, Options) -type TypedDecoder a s = forall t . Type a t -> Decoder (Exercise a, Options) s t+type TypedDecoder a s = forall t . Type a t -> DecoderX a String s t
src/Ideas/Encoding/EncoderHTML.hs view
@@ -18,7 +18,6 @@ import Data.Char import Data.List import Data.Maybe -import Data.Monoid import Ideas.Common.Examples (isEmpty, size, allRandoms) import Ideas.Common.Library hiding (alternatives, isEmpty, left, right, collapse, Medium) import Ideas.Common.Strategy.Symbol @@ -39,7 +38,7 @@ 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.Text.XML import Ideas.Utils.Prelude (munless, mwhen) import Ideas.Utils.TestSuite import System.IO.Unsafe @@ -62,7 +61,6 @@ makePage :: LinkManager -> DomainReasoner -> Exercise a -> HTMLBuilder -> HTMLPage makePage lm dr ex body = (if hasLatexEncoding ex then addScript mathJaxUrl else id) $ - -- addCSS "http://ideas.cs.uu.nl/css/2007-chili-pepper.css" $ addCSS (urlForCSS lm "2007-chili-pepper.css") $ webpage myWebPage where @@ -72,7 +70,7 @@ myWebPage = WebPage { title = "Ideas: documentation pages" , menuButtons = - [ Button "http://ideas.cs.uu.nl/ " (theme L1) (fontAwesome "lightbulb-o" <> tag "span" (fontSize Large " I") <> tag "span" (fontSize Medium "DEAS")) + [ Button "https://ideas.science.uu.nl/" (theme L1) (fontAwesome "lightbulb-o" <> tag "span" (fontSize Large " I") <> tag "span" (fontSize Medium "DEAS")) , Button (urlForIndex lm) (hover White) "Index" , Button (urlForExercises lm) (hover White) $ "Exercises " <> nrBadge (length (exercises dr)) , Button (urlForServices lm) (hover White) $ "Services " <> nrBadge (length (services dr)) @@ -118,10 +116,10 @@ (encodeIndex, tDomainReasoner) <?> (exerciseHeader . htmlDiagnosis dr, tDiagnosis) <?> (exerciseHeader . encodeExampleList, tList (tPair tDifficulty tContext)) <?> - (exerciseHeader . htmlFirsts, tList (tPair tStepInfo tState)) <?> + (exerciseHeader . htmlFirsts, tList (Tag "first" (tPair tStepInfo tState))) <?> (exerciseHeader . htmlAllApplications, tList (tTuple3 tRule tLocation tState)) <?> - (exerciseHeader . encodeDerivation, tDerivation (tPair tRule tEnvironment) tContext) <?> - (exerciseHeader . encodeDerivationList, tList (tDerivation (tPair tRule tEnvironment) tContext)) <?> + (exerciseHeader . encodeDerivation, tDerivation tStepInfo tContext) <?> + (exerciseHeader . encodeDerivationList, tList (tDerivation tStepInfo tContext)) <?> \(val ::: tp) -> case tp of Iso iso t -> encodeType dr (to iso val ::: t) @@ -458,11 +456,11 @@ let st = emptyStateContext ex x in button (escapeInURL (urlForState lm st)) (htmlContext False ex x) -encodeDerivation :: Derivation (Rule (Context a), Environment) (Context a) -> HTMLEncoder a +encodeDerivation :: Derivation (StepInfo a) (Context a) -> HTMLEncoder a encodeDerivation d = h2 "Derivation" <> htmlDerivation d -encodeDerivationList :: [Derivation (Rule (Context a), Environment) (Context a)] -> HTMLEncoder a +encodeDerivationList :: [Derivation (StepInfo a) (Context a)] -> HTMLEncoder a encodeDerivationList ds = h2 "Derivations" <> mconcat @@ -470,7 +468,7 @@ | (i, d) <- zip [1::Int ..] ds ] -htmlDerivation :: Derivation (Rule (Context a), Environment) (Context a) -> HTMLEncoder a +htmlDerivation :: Derivation (StepInfo a) (Context a) -> HTMLEncoder a htmlDerivation d = withExercise $ \ex -> do lm <- getLinkManager let before = @@ -478,7 +476,7 @@ <> case fmap (isReady ex) (fromContext (lastTerm d)) of Just True -> mempty _ -> spanClass "error" (string "Final term is not finished") - forStep ((r, env1), env2) = + forStep ((r, _, env1), env2) = let showEnv e = munless (noBindings e) $ string $ "," ++ show e in container $ marginPos CenterLeft $ mconcat [ string [chr 8658, ' '] @@ -522,7 +520,7 @@ in return (mconcat [ h2 "Feedback" , submitDiagnose lm state - , tag "p" $ padding Small $ mconcat [ case xs of + , tag "p" $ padding Small $ spaced [ case xs of Right (hd:_) -> linkToState lm (snd hd) $ serviceButton $ string "onefirst" _ -> string "(no onefirst)" , linkToFirsts lm state $ serviceButton $ string $ "allfirsts (" ++ show n ++ ")" @@ -544,11 +542,12 @@ useAllFirstsIO :: DomainReasoner -> State a -> IO (Either String [(StepInfo a, State a)]) useAllFirstsIO dr st = do - srv <- findService dr (newId ("allfirsts" :: String)) + srv <- either fail return $ findService dr (newId ("allfirsts" :: String)) case serviceFunction srv of - f ::: tp -> do - conv <- equalM tp (tState .-> tError (tList (tPair tStepInfo tState))) - return (conv f st) + f ::: tp -> + case equalM tp (tState .-> tError (tList (Tag "first" (tPair tStepInfo tState)))) of + Left msg -> fail msg + Right conv -> return (conv f st) encodePrefix :: State a -> Prefix (Context a) -> HTMLBuilder encodePrefix st = @@ -618,8 +617,8 @@ spanClass "error" $ string $ "Not equivalent: buggy rule " ++ show r NotEquivalent s -> spanClass "error" $ string $ if null s then "Not equivalent" else s - Similar _ s -> - h2 "Similar term" <> encodeState dr s + Similar _ s mr -> + h2 ("Similar term " ++ maybe "" showId mr) <> encodeState dr s WrongRule _ s mr -> h2 ("WrongRule " ++ maybe "" showId mr) <> encodeState dr s
src/Ideas/Encoding/EncoderJSON.hs view
@@ -15,16 +15,17 @@ module Ideas.Encoding.EncoderJSON (jsonEncoder) where -import Control.Applicative hiding (Const) import Data.Maybe import Ideas.Common.Library hiding (exerciseId) import Ideas.Encoding.Encoder import Ideas.Encoding.Request import Ideas.Service.State +import Ideas.Service.BasicServices import Ideas.Service.Types hiding (String) import Ideas.Text.JSON import Ideas.Utils.Prelude (distinct) import qualified Ideas.Service.Diagnose as Diagnose +import qualified Ideas.Service.Apply as Apply import qualified Ideas.Service.Submit as Submit import qualified Ideas.Service.Types as Tp @@ -46,16 +47,19 @@ List (Const Rule) -> return $ Array $ map ruleShortInfo val Tp.Tag s t - | s == "Result" -> encodeTyped encodeResult Submit.tResult tv - | s == "Diagnosis" -> encodeTyped encodeDiagnosis Diagnose.tDiagnosis tv - | s == "Derivation" -> ((encodeDerivation, tDerivation (tPair tRule tEnvironment) tContext) <?> - encodeTyped encodeDerivationText (tDerivation tString tContext)) tv - | s == "elem" -> jsonEncoder (val ::: t) + | s == "Result" -> encodeTyped encodeResult Submit.tResult tv + | s == "Diagnosis" -> encodeTyped encodeDiagnosis Diagnose.tDiagnosis tv + | s == "ApplyResult" -> encodeTyped encodeApplyResult Apply.tApplyResult tv + | s == "Derivation" -> ((encodeDerivation, tDerivation tStepInfo tContext) <?> + encodeTyped encodeDerivationText (tDerivation tString tContext)) tv + | s == "first" -> encodeTyped encodeFirst (tPair tStepInfo tState) (val ::: t) + | s == "elem" -> jsonEncoder (val ::: t) + | s `elem` ["step", "accept", "message"] -> jsonEncoder (val ::: t) | otherwise -> (\b -> Object [(s, b)]) <$> jsonEncoder (val ::: t) Tp.Unit -> return Null Tp.List t -> Array <$> sequence [ jsonEncoder (x ::: t) | x <- val ] Const ctp -> jsonEncodeConst (val ::: ctp) - _ -> fail $ "Cannot encode type: " ++ show tp + _ -> errorStr $ "Cannot encode type: " ++ show tp where tupleList :: TypedValue (TypeRep f) -> [TypedValue (TypeRep f)] tupleList (x ::: Tp.Iso p t) = tupleList (to p x ::: t) @@ -84,7 +88,7 @@ Int -> return (toJSON val) Bool -> return (toJSON val) Tp.String -> return (toJSON val) - _ -> fail $ "Type " ++ show tp ++ " not supported in JSON" + _ -> errorStr $ "Type " ++ show tp ++ " not supported in JSON" -------------------------- @@ -122,9 +126,17 @@ $ environment ctx in Object [ (showId a, String $ showValue a) | a <- bindings env ] -encodeDerivation :: Derivation (Rule (Context a), Environment) (Context a) -> JSONEncoder a +encodeFirst :: (StepInfo a, State a) -> JSONEncoder a +encodeFirst (step, state) = do + x <- jsonEncoder (step ::: tStepInfo) + y <- jsonEncoder (state ::: tState) + case x of + Array xs -> return $ Array $ xs ++ [y] + _ -> return $ Array [x, y] + +encodeDerivation :: Derivation (StepInfo a) (Context a) -> JSONEncoder a encodeDerivation d = - let xs = [ (s, a) | (_, s, a) <- triples d ] + let xs = [ ((r, env), ctx) | (_, (r, _, env), ctx) <- triples d ] in jsonEncoder (xs ::: tList (tPair (tPair tRule tEnvironment) tContext)) encodeDerivationText :: Derivation String (Context a) -> JSONEncoder a @@ -173,8 +185,8 @@ else make "notequiv" [fromReason s] Diagnose.Buggy env r -> make "buggy" [fromEnv env, fromRule r] - Diagnose.Similar b st -> - make "similar" [fromReady b, fromState st] + Diagnose.Similar b st mr -> + make "similar" [fromReady b, fromState st, fromMaybeRule mr] Diagnose.WrongRule b st mr -> make "wrongrule" [fromReady b, fromState st, fromMaybeRule mr] Diagnose.Expected b st r -> @@ -194,6 +206,18 @@ fromState st = jsonEncoder (st ::: tState) fromReason s = return (Object [("reason", toJSON s)]) +-- legacy encoder +encodeApplyResult :: Apply.ApplyResult a -> JSONEncoder a +encodeApplyResult result = + jsonEncoder (f result ::: tError tState) + where + f :: Apply.ApplyResult a -> Either String (State a) + f (Apply.SyntaxError msg) = Left $ "Syntax error: " ++ msg + f (Apply.Correct _ st) = Right st + f (Apply.Buggy _ r) = Left $ "Buggy rule: " ++ show r + f Apply.Incorrect = Left $ "Cannot apply rule" + + jsonTuple :: [JSON] -> JSON jsonTuple xs = case catMaybes <$> mapM f xs of @@ -217,4 +241,4 @@ [ ("exerciseid", toJSON (showId ex)) , ("description", toJSON (description ex)) , ("status", toJSON (show (status ex))) - ]+ ]
src/Ideas/Encoding/EncoderXML.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings, GADTs #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -21,19 +21,21 @@ import Data.Char import Data.List import Data.Maybe -import Data.Monoid -import Ideas.Common.Library hiding (exerciseId) +import Ideas.Common.Library hiding (exerciseId, tFirst) 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.BasicServices (StepInfo, tStepInfo) +import qualified Ideas.Service.Apply as Apply import Ideas.Service.Diagnose import Ideas.Service.FeedbackScript.Syntax import Ideas.Service.State import Ideas.Service.Types import Ideas.Text.OpenMath.Object import Ideas.Text.XML +import Ideas.Utils.Decoding import Ideas.Utils.Prelude (munless) import qualified Ideas.Service.FeedbackText as FeedbackText import qualified Ideas.Service.ProblemDecomposition as PD @@ -45,8 +47,11 @@ xmlEncoder :: TypedEncoder a XMLBuilder xmlEncoder = (encodeDiagnosis, tDiagnosis) <?> + (encodeApplyResult, Apply.tApplyResult) <?> (encodeDecompositionReply, PD.tReply) <?> - (encodeDerivation, tDerivation (tPair tRule tEnvironment) tContext) <?> + (encodeDerivation, tDerivation tStepInfo tContext) <?> + (encodeFirsts, tList tFirst) <?> + (encodeFirst, tFirst) <?> (encodeDerivationText, tDerivation tString tContext) <?> (encodeDifficulty, tDifficulty) <?> (encodeMessage, FeedbackText.tMessage) <?> @@ -56,7 +61,7 @@ Tag "RuleShortInfo" t -> case equal t (Const Rule) of Just f -> ruleShortInfo (f val) - Nothing -> fail "rule short info" + Nothing -> errorStr "rule short info" Tag "RulesInfo" _ -> do ex <- getExercise useOM <- useOpenMath <$> getRequest @@ -78,7 +83,7 @@ Right b -> xmlEncoder (b ::: t2) Unit -> mempty Const t -> xmlEncoderConst (val ::: t) - _ -> fail $ show tp + _ -> errorStr $ show tp xmlEncoderConst :: TypedValue (Const a) -> XMLEncoder a xmlEncoderConst tv@(val ::: tp) = @@ -116,7 +121,7 @@ loc = fromLocation (location ctx) withLoc | null loc = id - | otherwise = insertRef (makeRef "location") loc + | otherwise = insertRef (makeRef ("location" :: String)) loc in munless (null values) $ element "context" [ element "item" [ "name" .=. showId tb @@ -130,10 +135,10 @@ buildExpression :: BuildXML b => Bool -> Exercise a -> a -> b buildExpression useOM ex - | useOM = either msg builderXML . toOpenMath ex + | useOM = maybe msg builderXML . toOpenMath ex | otherwise = tag "expr" . string . prettyPrinter ex where - msg s = error ("Error encoding term in OpenMath: " ++ s) + msg = error "Error encoding term in OpenMath" encodeLocation :: Location -> XMLEncoder a encodeLocation loc = "location" .=. show loc @@ -151,9 +156,9 @@ omobj2xml $ toOMOBJ term _ -> string (showValue tb) -encodeDerivation :: Derivation (Rule (Context a), Environment) (Context a) -> XMLEncoder a +encodeDerivation :: Derivation (StepInfo a) (Context a) -> XMLEncoder a encodeDerivation d = - let xs = [ (s, a) | (_, s, a) <- triples d ] + let xs = [ ((r, env), a) | (_, (r, _, env), a) <- triples d ] in xmlEncoder (xs ::: tList (tPair (tPair tRule tEnvironment) tContext)) encodeDerivationText :: Derivation String (Context a) -> XMLEncoder a @@ -162,6 +167,17 @@ | (_, s, a) <- triples d ] +tFirst :: Type a (StepInfo a, State a) +tFirst = Tag "first" (tPair tStepInfo tState) + +encodeFirst :: (StepInfo a, State a) -> XMLEncoder a +encodeFirst (step, st) = + tag "elem" (xmlEncoder (step ::: tStepInfo) <> encodeState st) + +encodeFirsts :: [(StepInfo a, State a)] -> XMLEncoder a +encodeFirsts = + element "list" . map encodeFirst + ruleShortInfo :: Rule (Context a) -> XMLEncoder a ruleShortInfo r = mconcat [ "name" .=. showId r @@ -197,6 +213,14 @@ , encodeText (FeedbackText.text msg) ] +encodeApplyResult :: Apply.ApplyResult a -> XMLEncoder a +encodeApplyResult result = + case result of + Apply.SyntaxError msg -> "error" .=. msg + Apply.Correct _ st -> encodeState st + Apply.Buggy _ r -> "ruleid" .=. show r + Apply.Incorrect -> "error" .=. "incorrect" + encodeDiagnosis :: Diagnosis a -> XMLEncoder a encodeDiagnosis diagnosis = case diagnosis of @@ -206,8 +230,9 @@ NotEquivalent s -> if null s then emptyTag "notequiv" else element "notequiv" [ "reason" .=. s ] - Similar b st -> element "similar" - ["ready" .=. showBool b, encodeState st] + Similar b st mr -> element "similar" $ + ["ready" .=. showBool b, encodeState st] ++ + maybe [] (\r -> ["ruleid" .=. showId r]) mr WrongRule b st mr -> element "wrongrule" $ [ "ready" .=. showBool b, encodeState st ] ++ maybe [] (\r -> ["ruleid" .=. showId r]) mr
src/Ideas/Encoding/Evaluator.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, RankNTypes #-} +{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -46,10 +46,13 @@ logType opts res tDiagnosis $ \d r -> r {serviceinfo = show d} return (evalResult res) -eval :: Exercise a -> Options -> Evaluator a b c -> b -> TypedValue (Type a) -> IO (EvalResult a c) +eval :: forall a b c. Exercise a -> Options -> Evaluator a b c -> b -> TypedValue (Type a) -> IO (EvalResult a c) eval ex opts (Evaluator dec enc) b = rec where - rec tv@(val ::: tp) = + env = (ex, opts) + + rec :: TypedValue (Type a) -> IO (EvalResult a c) + rec tv@(val ::: tp) = case tp of -- handle exceptions Const String :|: t -> @@ -57,14 +60,16 @@ -- uncurry function if possible t1 :-> t2 :-> t3 -> rec (uncurry val ::: Pair t1 t2 :-> t3) - t1 :-> t2 -> do - a <- runDecoder (dec t1) (ex, opts) b - res <- rec (val a ::: t2) - return res { inputValues = (a ::: t1) : inputValues res } + -- functions + t1 :-> t2 -> + case evalDecoder (dec t1) env b of + Left msg -> fail msg + Right a -> do + res <- rec (val a ::: t2) + return res { inputValues = (a ::: t1) : inputValues res } -- perform IO IO t -> do a <- val rec (a ::: t) - _ -> do - c <- runEncoder (enc tv) (ex, opts) - return $ EvalResult [] tv c+ _ -> + either fail (return . EvalResult [] tv) (runEncoder (enc tv) env)
src/Ideas/Encoding/LinkManager.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings, RankNTypes #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -28,8 +28,7 @@ , escapeInURL ) where -import Data.Maybe -import Data.Monoid +import Data.Either import Ideas.Common.Library import Ideas.Encoding.EncoderXML import Ideas.Encoding.Options @@ -183,12 +182,12 @@ makeRequest s (("exerciseid" .=. showId ex) <> rest) stateRequest :: String -> State a -> XML -stateRequest s state = - exerciseRequestWith s (exercise state) (stateToXML state) +stateRequest s st = + exerciseRequestWith s (exercise st) (stateToXML st) -- assume nothing goest wrong stateToXML :: State a -> XMLBuilder -stateToXML st = fromMaybe (error "LinkManager: Invalid state") $ +stateToXML st = fromRight (error "LinkManager: Invalid state") $ runEncoder (encodeState st) (exercise st, optionHtml mempty) linkWith :: (a -> String) -> a -> HTMLBuilder -> HTMLBuilder
src/Ideas/Encoding/Logging.hs view
@@ -26,7 +26,6 @@ import Data.Char import Data.IORef import Data.Maybe -import Data.Semigroup (Semigroup(..)) import Data.Time import Ideas.Encoding.Request (Request, Schema(..)) import Ideas.Service.State @@ -181,11 +180,13 @@ columnsInTable V1 = values_v1 columnsInTable _ = values_v2 +-- Do not store ip addresses in database + values_v1 :: Record -> [SqlValue] values_v1 r = let get f = toSql (f r) in [ get service, get exerciseid, get source, get dataformat, get encoding - , get input, get output, get ipaddress, get time, get responsetime + , get input, get output, SqlNull {- get ipaddress -}, get time, get responsetime ] values_v2 :: Record -> [SqlValue] @@ -193,7 +194,7 @@ let get f = toSql (f r) in [ get service, get exerciseid, get source, get script, get requestinfo , get dataformat, get encoding, get userid, get sessionid, get taskid - , get time, get responsetime, get ipaddress, get binary, get version + , get time, get responsetime, SqlNull {- get ipaddress -}, get binary, get version , get errormsg, get serviceinfo, get ruleid, get input, get output ]
src/Ideas/Encoding/ModeJSON.hs view
@@ -12,12 +12,11 @@ -- ----------------------------------------------------------------------------- -module Ideas.Encoding.ModeJSON (processJSON) where +module Ideas.Encoding.ModeJSON (processJSON, processJSON') where import Control.Monad import Data.Char import Data.Maybe -import Data.Semigroup ((<>)) import Ideas.Common.Library hiding (exerciseId) import Ideas.Encoding.DecoderJSON import Ideas.Encoding.EncoderJSON @@ -32,6 +31,10 @@ processJSON :: Options -> DomainReasoner -> String -> IO (Request, String, String) processJSON options dr txt = do json <- either fail return (parseJSON txt) + processJSON' options dr json + +processJSON' :: Options -> DomainReasoner -> JSON -> IO (Request, String, String) +processJSON' options dr json = do req <- jsonRequest options json resp <- jsonRPC json $ \fun arg -> maybe id timedSeconds (maxTime options) (myHandler options dr req fun arg) @@ -42,7 +45,7 @@ return (req, f out, "application/json") -- TODO: Clean-up code -extractExerciseId :: Monad m => JSON -> m Id +extractExerciseId :: JSON -> Maybe Id extractExerciseId json = case json of String s -> return (newId s) @@ -50,7 +53,7 @@ Array [String _, String _, _, a@(Array _)] -> extractExerciseId a Array (String s:tl) | any p s -> extractExerciseId (Array tl) Array (hd:_) -> extractExerciseId hd - _ -> fail "no code" + _ -> Nothing where p c = not (isAlphaNum c || isSpace c || c `elem` ".-_") @@ -62,15 +65,15 @@ where info = ("version", String str) -jsonRequest :: Monad m => Options -> JSON -> m Request +jsonRequest :: Options -> JSON -> IO Request jsonRequest options json = do - let exId = lookupM "params" json >>= extractExerciseId + let exId = (either (const Nothing) Just $ lookupM "params" json) >>= extractExerciseId srv <- stringOption "method" json newId src <- stringOption "source" json id rinf <- stringOption "requestinfo" json id seed <- stringOptionM "randomseed" json (defaultSeed options) (return . readM) enc <- stringOptionM "encoding" json [] readEncoding - sch <- stringOptionM "logging" json Nothing (fmap Just . readSchema) + sch <- stringOptionM "logging" json Nothing (maybe (fail "invalid logging scheme") (return . Just) . readSchema) return mempty { serviceId = srv , exerciseId = exId @@ -89,25 +92,25 @@ | isJust (cgiBin options) = Nothing | otherwise = Just 2805 -- magic number -stringOption :: Monad m => String -> JSON -> (String -> a) -> m (Maybe a) +stringOption :: String -> JSON -> (String -> a) -> IO (Maybe a) stringOption attr json f = stringOptionM attr json Nothing (return . Just . f) -stringOptionM :: Monad m => String -> JSON -> a -> (String -> m a) -> m a +stringOptionM :: String -> JSON -> a -> (String -> IO a) -> IO a stringOptionM attr json a f = case lookupM attr json of - Just (String s) -> f s - Just _ -> fail $ "Invalid value for " ++ attr ++ " (expecting string)" - Nothing -> return a + Right (String s) -> f s + Right _ -> fail $ "Invalid value for " ++ attr ++ " (expecting string)" + Left _ -> return a myHandler :: Options -> DomainReasoner -> Request -> RPCHandler myHandler opt1 dr request fun json = do - srv <- findService dr (newId fun) + srv <- either fail return $ findService dr (newId fun) Some ex <- case exerciseId request of - Just a -> findExercise dr a + Just a -> either fail return $ findExercise dr a Nothing -> return (Some emptyExercise) opt2 <- makeOptions dr request let options = opt1 <> opt2 evalService ex options jsonEvaluator srv json jsonEvaluator :: Evaluator a JSON JSON -jsonEvaluator = Evaluator jsonDecoder jsonEncoder+jsonEvaluator = Evaluator jsonTypeDecoder jsonEncoder
src/Ideas/Encoding/ModeXML.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -16,7 +17,7 @@ import Control.Exception import Control.Monad -import Data.Monoid +import Data.String import Ideas.Common.Library hiding (exerciseId) import Ideas.Encoding.DecoderXML import Ideas.Encoding.EncoderHTML @@ -52,27 +53,25 @@ Nothing -> show e addVersion :: String -> XML -> XML -addVersion s xml = - let info = [ "version" := s ] - in xml { attributes = attributes xml ++ info } +addVersion s = changeAttributes (<> attribute "version" s) -xmlRequest :: Monad m => Maybe String -> XML -> m Request +xmlRequest :: Maybe String -> XML -> IO Request xmlRequest ms xml = do - unless (name xml == "request") $ + unless (getName xml == "request") $ fail "expected xml tag request" - enc <- case findAttribute "encoding" xml of + enc <- case findAttribute' "encoding" xml of Just s -> readEncoding s Nothing -> return [] return mempty - { serviceId = newId <$> findAttribute "service" xml + { serviceId = newId <$> findAttribute' "service" xml , exerciseId = extractExerciseId xml - , source = findAttribute "source" xml + , source = findAttribute' "source" xml , cgiBinary = ms - , requestInfo = findAttribute "requestinfo" xml - , logSchema = findAttribute "logging" xml >>= readSchema - , feedbackScript = findAttribute "script" xml + , requestInfo = findAttribute' "requestinfo" xml + , logSchema = findAttribute' "logging" xml >>= readSchema + , feedbackScript = findAttribute' "script" xml , randomSeed = defaultSeed ms $ - findAttribute "randomseed" xml >>= readM + findAttribute' "randomseed" xml >>= readM , dataformat = Just XML , encoding = enc } @@ -85,11 +84,11 @@ xmlReply :: Options -> DomainReasoner -> Request -> XML -> IO XML xmlReply opt1 dr request xml = do srv <- case serviceId request of - Just a -> findService dr a + Just a -> either fail return $ findService dr a Nothing -> fail "No service" Some ex <- case exerciseId request of - Just a -> findExercise dr a + Just a -> either fail return $ findExercise dr a Nothing -> return (Some emptyExercise) opt2 <- makeOptions dr request @@ -101,25 +100,28 @@ -- xml evaluator else resultOk <$> evalService ex options xmlEvaluator srv xml -extractExerciseId :: Monad m => XML -> m Id -extractExerciseId = fmap newId . findAttribute "exerciseid" +extractExerciseId :: XML -> Maybe Id +extractExerciseId = either (const Nothing) (return . newId) . findAttribute "exerciseid" resultOk :: XMLBuilder -> XML -resultOk body = makeXML "reply" $ +resultOk body = makeXML (fromString "reply") $ ("result" .=. "ok") <> body resultError :: Options -> String -> IO XML resultError options msg = do changeLog (logRef options) (\r -> r {errormsg = msg}) - return $ makeXML "reply" $ + return $ makeXML (fromString "reply") $ ("result" .=. "error") <> tag "message" (string msg) +findAttribute' :: String -> XML -> Maybe String +findAttribute' a = either (const Nothing) Just . findAttribute a + ------------------------------------------------------------ xmlEvaluator :: Evaluator a XML XMLBuilder -xmlEvaluator = Evaluator xmlDecoder xmlEncoder +xmlEvaluator = Evaluator xmlTypeDecoder xmlEncoder htmlEvaluator :: DomainReasoner -> Evaluator a XML HTMLPage -htmlEvaluator dr = Evaluator xmlDecoder (htmlEncoder dr)+htmlEvaluator dr = Evaluator xmlTypeDecoder (htmlEncoder dr)
+ src/Ideas/Encoding/NewDecoderJSON.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE GADTs #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-- Services using JSON notation+--+-----------------------------------------------------------------------------++module Ideas.Encoding.NewDecoderJSON+ ( JSONDecoder, jsonTypeDecoder+ ) where++import Control.Monad.State (get)+import Data.Char+import Ideas.Common.Library hiding (exerciseId, symbol)+import Ideas.Common.Traversal.Navigator+import Ideas.Encoding.Encoder+import Ideas.Encoding.Options+import Ideas.Service.State+import Ideas.Service.Types hiding (String)+import Ideas.Text.JSON+import qualified Ideas.Service.Types as Tp++type JSONDecoder a = GDecoderJSON (Exercise a, Options)++jsonTypeDecoder :: Type a t -> DecoderX a String JSON t+jsonTypeDecoder tp = do+ env <- reader id+ json <- get+ case evalGDecoderJSON (jObject $ decodeType tp) env json of+ Left err -> throwError (show err)+ Right a -> return a++decodeType :: Type a t -> JSONDecoder a t+decodeType tp =+ case tp of+ Tag s t ->+ jKey (map toLower s) $ decodeType t+ Iso p t -> from p <$> decodeType t+ Pair t1 t2 -> do+ a <- decodeType t1+ b <- decodeType t2+ return (a, b)+ t1 :|: t2 ->+ Left <$> decodeType t1 <|>+ Right <$> decodeType t2+ Unit -> return ()+ Const t -> decodeConst t+ _ -> errorStr $ "No support for argument type: " ++ show tp++decodeConst :: Const a t -> JSONDecoder a t+decodeConst tp =+ case tp of+ State -> decodeState+ Context -> decodeContext+ Exercise -> getExercise+ Environment -> decodeEnvironment+ Location -> decodeLocation+ Script -> getScript+ Int -> jInt+ Tp.String -> jString+ Id -> decodeId+ Rule -> decodeRule+ QCGen -> getQCGen+ _ -> errorStr $ "No support for argument type: " ++ show tp++decodeState :: JSONDecoder a (State a)+decodeState = jKey "state" $ jObject $ do+ ex <- getExercise+ ps <- decodePaths+ ctx <- decodeContext+ let prf = maybe noPrefix (\x -> replayPaths x (strategy ex) ctx) ps+ uid <- searchKey "userid"+ sid <- searchKey "sessionid"+ tid <- searchKey "taskid"+ return $ (makeState ex prf ctx)+ { stateUser = uid+ , stateSession = sid+ , stateStartTerm = tid+ }++searchKey :: String -> JSONDecoder a (Maybe String)+searchKey k = Just <$> jKey k jString <|> return Nothing++decodePaths :: JSONDecoder a (Maybe [Path])+decodePaths = f <$> jKey "prefix" jString+ where+ f s | s ~= "noprefix" = Nothing+ | otherwise = readPaths s+ x ~= y = filter isAlphaNum (map toLower x) == y++decodeContext :: JSONDecoder a (Context a)+decodeContext = jKey "context" $ jObject $ do+ ex <- getExercise+ val <- decodeValue+ env <- decodeEnvironment+ loc <- decodeLocation+ return $ navigateTowards loc $ deleteRef locRef $+ setEnvironment env $ inContext ex val++decodeValue :: JSONDecoder a a+decodeValue = jKey "term" $ decodeParser <|> decodeJSON+ where+ decodeParser = do+ ex <- getExercise+ s <- jString+ either errorStr return (parser ex s)++ decodeJSON = do+ ex <- getExercise+ case hasJSONView ex of + Just jv -> jNext $ maybe (Left "Could not decode term") Right . match jv+ Nothing -> errorStr "No JSON decoder for term"++decodeEnvironment :: JSONDecoder a Environment+decodeEnvironment = jKey "environment" $ foldr ($) mempty <$> jObjectWithKeys f+ where+ f k = g <$> jString <|> g . show <$> jInt <|> g . show <$> jDouble+ where+ g = insertRef (makeRef k)++decodeLocation :: JSONDecoder a Location+decodeLocation = jKey "location" $ + toLocation <$> jArrayOf jInt++decodeRule :: JSONDecoder a (Rule (Context a))+decodeRule = do+ ex <- getExercise+ jKey "rule" $ do + rid <- newId <$> jString+ case getRule ex rid of+ Just a -> return a+ Nothing -> errorStr ("unknown rule " ++ show rid) ++decodeId :: JSONDecoder a Id -- fix me+decodeId = jKey "rule" $ newId <$> jString++locRef :: Ref String+locRef = makeRef "location"
+ src/Ideas/Encoding/NewEncoderJSON.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE GADTs #-}+-----------------------------------------------------------------------------+-- Copyright 2018, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-- Services using JSON notation+--+-----------------------------------------------------------------------------++module Ideas.Encoding.NewEncoderJSON (jsonEncoder) where++import Data.Char+import Ideas.Common.Library hiding (exerciseId)+import Ideas.Encoding.Encoder+import Ideas.Service.State+import Ideas.Service.Types hiding (String)+import Ideas.Text.JSON+import qualified Ideas.Service.Apply as Apply+import qualified Ideas.Service.Diagnose as Diagnose+import qualified Ideas.Service.Types as Tp++-------------------------------------------------------------++jsonEncoder :: TypedValue (Type a) -> EncoderX a JSONBuilder+jsonEncoder tv@(val ::: tp) = + case tp of+ Iso p t -> jsonEncoder (to p val ::: t)+ t1 :|: t2 -> case val of+ Left x -> jsonEncoder (x ::: t1)+ Right y -> jsonEncoder (y ::: t2)+ Pair t1 t2 -> (<>) <$> jsonEncoder (fst val ::: t1) <*> jsonEncoder (snd val ::: t2)+ Tp.List t -> arrayBuilder <$> sequence [ jsonEncoder (x ::: t) | x <- val ]+ Tp.Tag s t + | s == "Diagnosis" -> encodeTyped encodeDiagnosis Diagnose.tDiagnosis tv+ | s == "ApplyResult" -> encodeTyped encodeApplyResult Apply.tApplyResult tv+ | otherwise -> (map toLower s .=) <$> jsonEncoder (val ::: t)+ Tp.Unit -> pure mempty+ Const ctp -> jsonEncodeConst (val ::: ctp)+ _ -> errorStr $ "Cannot encode type: " ++ show tp++jsonEncodeConst :: TypedValue (Const a) -> EncoderX a JSONBuilder+jsonEncodeConst (val ::: tp) = + case tp of+ Rule -> encodeRule val+ Constraint -> encodeConstraint val+ Location -> encodeLocation val+ Environment -> encodeEnvironment val+ Context -> encodeContext val+ State -> encodeState val+ SomeExercise -> case val of+ Some ex -> pure (exerciseInfo ex)+ Text -> pure $ jsonBuilder (show val)+ Tp.String -> pure $ jsonBuilder val+ Tp.Int -> pure $ jsonBuilder val+ Tp.Bool -> pure $ jsonBuilder val+ _ -> errorStr $ "Type " ++ show tp ++ " not supported in JSON"++encodeRule :: Rule (Context a) -> EncoderX a JSONBuilder+encodeRule r = pure $ "rule" .= showId r++encodeConstraint :: Constraint (Context a) -> EncoderX a JSONBuilder+encodeConstraint c = pure $ "constraint" .= showId c++encodeEnvironment :: Environment -> EncoderX a JSONBuilder+encodeEnvironment env =+ let f a = (showId a, String (showValue a))+ in pure $ "environment" .= Object [ f a | a <- bindings env ]++encodeContext :: Context a -> EncoderX a JSONBuilder+encodeContext ctx = + let encValue = case fromContext ctx of+ Just a -> encodeTerm a+ Nothing -> pure $ "term" .= Null -- todo: merge with encodeTerm+ encEnv = encodeEnvironment (environment ctx)+ encLoc = encodeLocation (location ctx)+ in (\xs ys zs -> "context" .= (xs <> ys <> zs)) <$> encValue <*> encEnv <*> encLoc++encodeTerm :: a -> EncoderX a JSONBuilder+encodeTerm a = tagJSON "term" . f <$> getExercise+ where+ f ex = + case hasJSONView ex of+ Just jv -> build jv a+ Nothing -> String (prettyPrinter ex a)++encodeLocation :: Location -> EncoderX a JSONBuilder+encodeLocation loc = pure $ "location" .= fromLocation loc++encodeState :: State a -> EncoderX a JSONBuilder+encodeState st =+ let ctx = stateContext st+ get f = maybe Null String (f st)+ make ppCtx = mconcat+ [ "exerciseid" .= showId (exercise st)+ , "prefix" .= if withoutPrefix st+ then Null+ else String (show (statePrefix st))+ , ppCtx+ , "userid" .= get stateUser+ , "sessionid" .= get stateSession+ , "taskid" .= get stateStartTerm+ ]+ in ("state" .=) . make <$> encodeContext ctx++encodeDiagnosis :: Diagnose.Diagnosis a -> EncoderX a JSONBuilder+encodeDiagnosis diagnosis =+ case diagnosis of+ Diagnose.Correct b st ->+ (\xs ys -> "diagnosetype" .= "correct" <> xs <> ys) <$> mkReady b <*> encodeState st + Diagnose.Similar b st mr ->+ (\xs ys zs -> "diagnosetype" .= "similar" <> xs <> ys <> zs) <$> mkReady b <*> encodeState st <*> mkMaybeRule mr+ Diagnose.NotEquivalent s ->+ pure $ "diagnosetype" .= "notequiv" <> "message" .= s+ Diagnose.Expected b st r ->+ (\xs ys zs -> "diagnosetype" .= "expected" <> xs <> ys <> zs) <$> mkReady b <*> encodeState st <*> mkRule r+ Diagnose.Buggy env r ->+ (\xs ys -> "diagnosetype" .= "buggy" <> xs <> ys) <$> encodeEnvironment env <*> mkRule r+ Diagnose.Detour b st env r ->+ (\xs ys zs vs -> "diagnosetype" .= "detour" <> xs <> ys <> zs <> vs) <$> mkReady b <*> encodeState st <*> encodeEnvironment env <*> mkRule r+ Diagnose.WrongRule b st mr ->+ (\xs ys zs -> "diagnosetype" .= "wrongrule" <> xs <> ys <> zs) <$> mkReady b <*> encodeState st <*> mkMaybeRule mr+ Diagnose.SyntaxError msg -> + pure $ "diagnosetype" .= "syntaxerror" <> "message" .= msg+ Diagnose.Unknown b st ->+ (\xs ys -> "diagnosetype" .= "unknown" <> xs <> ys) <$> mkReady b <*> encodeState st + where+ mkReady b = pure $ "ready" .= b+ mkRule = mkMaybeRule . Just+ mkMaybeRule mr = pure $ "rule" .= maybe Null (toJSON . showId) mr++encodeApplyResult :: Apply.ApplyResult a -> EncoderX a JSONBuilder+encodeApplyResult result = + case result of+ Apply.Correct b st ->+ (\xs ys -> "diagnosetype" .= "correct" <> xs <> ys) <$> mkReady b <*> encodeState st + Apply.SyntaxError msg -> + pure $ "diagnosetype" .= "syntaxerror" <> "message" .= msg+ Apply.Buggy env r ->+ (\xs ys -> "diagnosetype" .= "buggy" <> xs <> ys) <$> encodeEnvironment env <*> mkRule r+ Apply.Incorrect ->+ pure $ "diagnosetype" .= "incorrect"++ where+ mkReady b = pure $ "ready" .= b+ mkRule = mkMaybeRule . Just+ mkMaybeRule mr = pure $ "rule" .= maybe Null (toJSON . showId) mr++exerciseInfo :: Exercise a -> JSONBuilder+exerciseInfo ex = "exercise" .= mconcat+ [ "exerciseid" .= showId ex+ , "description" .= description ex+ , "status" .= show (status ex)+ ]
+ src/Ideas/Encoding/NewModeJSON.hs view
@@ -0,0 +1,127 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-- Services using JSON notation+--+-----------------------------------------------------------------------------++module Ideas.Encoding.NewModeJSON (processJSON) where++import Control.Applicative+import Control.Exception+import System.IO.Error+import Data.Either+import Data.Maybe+import Ideas.Common.Library hiding (exerciseId)+import qualified Ideas.Encoding.ModeJSON as Legacy+import Ideas.Encoding.NewDecoderJSON+import Ideas.Encoding.NewEncoderJSON+import Ideas.Encoding.Evaluator+import Ideas.Encoding.Options (Options, makeOptions, maxTime, cgiBin)+import Ideas.Encoding.Request+import Ideas.Service.DomainReasoner+import Ideas.Text.JSON+import Ideas.Utils.Prelude (timedSeconds)++processJSON :: Options -> DomainReasoner -> String -> IO (Request, String, String)+processJSON options dr txt = do+ json <- either fail return (parseJSON txt)+ let legacy = isRight $ lookupM "params" json+ if legacy then Legacy.processJSON' options dr json else do+ req <- jsonRequest options json+ resp <- jsonRPC2 dr (maybe "result" show $ serviceId req) json $ \fun arg ->+ maybe id timedSeconds (maxTime options) (toJSON <$> myHandler options dr req fun arg)+ --unless (responseError resp == Null) $ !!!!!!!!!!!!!! + -- changeLog (logRef options) (\r -> r {errormsg = show (responseError resp)})+ let f = if compactOutput req then compactJSON else show+ return (req, f resp, "application/json")++jsonRPC2 :: DomainReasoner -> String -> JSON -> RPCHandler -> IO JSON+jsonRPC2 dr serviceName json rpc = do+ okResponse dr serviceName <$> rpc serviceName json+ `catch` handler+ where+ handler :: SomeException -> IO JSON+ handler e =+ let msg = maybe (show e) ioeGetErrorString (fromException e)+ in return $ errorResponse dr (toJSON msg)++okResponse :: DomainReasoner -> String -> JSON -> JSON+okResponse dr serviceName result = Object+ [ (serviceName, result)+ , ("version", String (version dr))+ ]++errorResponse :: DomainReasoner -> JSON -> JSON+errorResponse dr msg = Object + [ ("error", msg)+ , ("version", String (version dr))+ ]++-- TODO: Clean-up code+extractExerciseId :: JSON -> Maybe Id+extractExerciseId json = f <$> (+ get "exerciseid" json <|>+ (get "state" json >>= get "exerciseid"))+ where+ f (String s) = newId s+ f _ = error "expecting an exercise id"++ get s = either (const Nothing) Just . lookupM s ++jsonRequest :: Options -> JSON -> IO Request+jsonRequest options json = do+ let exId = extractExerciseId json+ srv <- stringOption "service" json newId+ src <- stringOption "source" json id+ rinf <- stringOption "requestinfo" json id+ seed <- stringOptionM "randomseed" json (defaultSeed options) (return . readM)+ enc <- stringOptionM "encoding" json [] readEncoding+ sch <- stringOptionM "logging" json Nothing (maybe (fail "invalid logging scheme") (return . Just) . readSchema)+ return mempty+ { serviceId = srv+ , exerciseId = exId+ , source = src+ , cgiBinary = cgiBin options+ , requestInfo = rinf+ , logSchema = sch+ , randomSeed = seed+ , dataformat = Just JSON+ , encoding = enc+ }++-- Use a fixed seed for random number generation for command-line invocations+defaultSeed :: Options -> Maybe Int+defaultSeed options+ | isJust (cgiBin options) = Nothing+ | otherwise = Just 2805 -- magic number++stringOption :: String -> JSON -> (String -> a) -> IO (Maybe a)+stringOption attr json f = stringOptionM attr json Nothing (return . Just . f)++stringOptionM :: String -> JSON -> a -> (String -> IO a) -> IO a+stringOptionM attr json a f =+ case lookupM attr json of+ Right (String s) -> f s+ Right _ -> fail $ "Invalid value for " ++ attr ++ " (expecting string)"+ Left _ -> return a++myHandler :: Options -> DomainReasoner -> Request -> String -> JSON -> IO JSONBuilder+myHandler opt1 dr request fun json = do+ srv <- either fail return $ findService dr (newId fun)+ Some ex <- case exerciseId request of+ Just a -> either fail return $ findExercise dr a+ Nothing -> return (Some emptyExercise)+ opt2 <- makeOptions dr request+ let options = opt1 <> opt2+ evalService ex options jsonEvaluator srv json++jsonEvaluator :: Evaluator a JSON JSONBuilder+jsonEvaluator = Evaluator jsonTypeDecoder jsonEncoder
src/Ideas/Encoding/OpenMathSupport.hs view
@@ -17,7 +17,6 @@ , toOMOBJ, fromOMOBJ ) where -import Control.Monad import Data.Char import Data.List import Ideas.Common.Library @@ -31,16 +30,16 @@ ----------------------------------------------------------------------------- -- Utility functions for conversion to/from OpenMath -toOpenMath :: Monad m => Exercise a -> a -> m OMOBJ +toOpenMath :: Exercise a -> a -> Maybe OMOBJ toOpenMath ex a = do - v <- hasTermViewM ex + v <- hasTermView ex return (toOMOBJ (build v a)) -fromOpenMath :: MonadPlus m => Exercise a -> OMOBJ -> m a +fromOpenMath :: Exercise a -> OMOBJ -> Maybe a fromOpenMath ex omobj = do - v <- hasTermViewM ex + v <- hasTermView ex a <- fromOMOBJ omobj - matchM v a + match v a toOMOBJ :: IsTerm a => a -> OMOBJ toOMOBJ = rec . toTerm @@ -60,21 +59,21 @@ OMBIND (OMS s) [x] body make xs = OMA xs -fromOMOBJ :: (MonadPlus m, IsTerm a) => OMOBJ -> m a +fromOMOBJ :: IsTerm a => OMOBJ -> Maybe a fromOMOBJ = (>>= fromTerm) . rec where rec omobj = case omobj of OMV x -> case isMeta x of - Just n -> return (TMeta n) - Nothing -> return (TVar x) - OMS s -> return (symbol (newSymbol (OM.dictionary s, OM.symbolName s))) - OMI n -> return (TNum n) - OMF a -> return (TFloat a) + Just n -> Just (TMeta n) + Nothing -> Just (TVar x) + OMS s -> Just (symbol (newSymbol (OM.dictionary s, OM.symbolName s))) + OMI n -> Just (TNum n) + OMF a -> Just (TFloat a) OMA xs -> case xs of OMS s:ys | s == OM.listSymbol -> TList <$> mapM rec ys | otherwise -> function (newSymbol s) <$> mapM rec ys - _ -> fail "Invalid OpenMath object" + _ -> Nothing OMBIND binder xs body -> rec (OMA (binder:map OMV xs++[body])) @@ -94,9 +93,6 @@ OM.extraSymbol (unqualified a) | otherwise = OM.makeSymbol (qualification a) (unqualified a) - -hasTermViewM :: Monad m => Exercise a -> m (View Term a) -hasTermViewM = maybe (fail "No support for terms") return . hasTermView mfSymbol :: OM.Symbol mfSymbol = OM.makeSymbol "extra" "mixedfraction"
src/Ideas/Encoding/Options.hs view
@@ -76,4 +76,5 @@ { request = req , qcGen = Just gen , script = scr + , maxTime = Just 5 }
src/Ideas/Encoding/Request.hs view
@@ -56,12 +56,12 @@ data Schema = V1 | V2 | NoLogging deriving (Show, Eq) -readSchema :: Monad m => String -> m Schema +readSchema :: String -> Maybe Schema readSchema s0 - | s == "v1" = return V1 - | s == "v2" = return V2 - | s `elem` ["false", "no"] = return NoLogging - | otherwise = fail "Unknown schema" + | s == "v1" = Just V1 + | s == "v2" = Just V2 + | s `elem` ["false", "no"] = Just NoLogging + | otherwise = Nothing where s = map toLower (filter isAlphaNum s0) @@ -112,14 +112,14 @@ useLogging :: Request -> Bool useLogging r = EncHTML `notElem` encoding r && logSchema r /= Just NoLogging -discoverDataFormat :: Monad m => String -> m DataFormat +discoverDataFormat :: String -> IO DataFormat discoverDataFormat xs = case dropWhile isSpace xs of '<':_ -> return XML '{':_ -> return JSON _ -> fail "Unknown data format" -readEncoding :: Monad m => String -> m [Encoding] +readEncoding :: String -> IO [Encoding] readEncoding = mapM (f . map toLower) . splitsWithElem '+' where f "html" = return EncHTML
src/Ideas/Encoding/RulePresenter.hs view
@@ -14,7 +14,6 @@ import Data.List import Data.Maybe -import Data.Monoid import Ideas.Common.Library import Ideas.Text.HTML
src/Ideas/Encoding/RulesInfo.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -15,12 +16,11 @@ ) where import Data.Char -import Data.Monoid import Ideas.Common.Library import Ideas.Encoding.OpenMathSupport (toOMOBJ) import Ideas.Text.OpenMath.FMP import Ideas.Text.OpenMath.Object -import Ideas.Text.XML hiding (name) +import Ideas.Text.XML import Ideas.Utils.Prelude (munless) import qualified Data.Map as M
src/Ideas/Encoding/StrategyInfo.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -14,7 +15,7 @@ module Ideas.Encoding.StrategyInfo (strategyToXML) where -import Data.Monoid +import Data.String import Ideas.Common.Id import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Configuration @@ -42,8 +43,8 @@ { fNode = \def xs -> case xs of [x] | isConfigId def - -> addProperty (show def) x - _ -> makeXML (show def) (mconcat (map builder xs)) + -> addProperty (fromString (show def)) x + _ -> makeXML (fromString (show def)) (mconcat (map builder xs)) , fLeaf = \r -> makeXML "rule" ("name" .=. show r) , fLabel = \l a -> @@ -54,10 +55,10 @@ makeXML "var" ("var" .=. show n) } -addProperty :: String -> XML -> XML -addProperty s a = - if name a `elem` ["label", "rule"] - then a { attributes = attributes a ++ [s := "true"] } +addProperty :: Name -> XML -> XML +addProperty n a = + if getName a `elem` ["label", "rule"] + then changeAttributes (<> attribute n "true") a else a -----------------------------------------------------------------------
src/Ideas/Main/CGI.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -Wno-deprecations #-} -- Original source: https://hackage.haskell.org/package/wai-extra-3.0.20.0/docs/Network-Wai-Handler-CGI.html module Ideas.Main.CGI (run) where
src/Ideas/Main/CmdLineOptions.hs view
@@ -26,14 +26,14 @@ data CmdLineOption = Version | Help | PrintLog - | InputFile String | Rerun String | Test FilePath + | InputFile String | Rerun String | Test FilePath | Interactive | MakeScriptFor String | AnalyzeScript FilePath deriving Eq header :: String header = "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++ - "Copyright 2019, Open Universiteit Nederland\n" ++ + "Copyright 2022, Open Universiteit\n" ++ versionText ++ "\n\nUsage: ideas [OPTION] (by default, CGI protocol)\n" ++ "\nOptions:" @@ -55,14 +55,15 @@ options :: [OptDescr CmdLineOption] options = - [ Option [] ["version"] (NoArg Version) "show version number" - , Option "?" ["help"] (NoArg Help) "show options" - , Option "" ["print-log"] (NoArg PrintLog) "print log information (for debugging)" - , Option "f" ["file"] fileArg "use input FILE as request" - , Option "" ["rerun"] rerunArg "rerun inputs from database" - , Option "" ["test"] testArg "run tests on directory (default: 'test')" - , Option "" ["make-script"] makeScrArg "generate feedback script for exercise" - , Option "" ["analyze-script"] analyzeScrArg "analyze feedback script and report errors" + [ Option [] ["version"] (NoArg Version) "show version number" + , Option "?" ["help"] (NoArg Help) "show options" + , Option "" ["print-log"] (NoArg PrintLog) "print log information (for debugging)" + , Option "f" ["file"] fileArg "use input FILE as request" + , Option "" ["rerun"] rerunArg "rerun inputs from database" + , Option "" ["test"] testArg "run tests on directory (default: 'test')" + , Option "i" ["interactive"] (NoArg Interactive) "test in interactive mode" + , Option "" ["make-script"] makeScrArg "generate feedback script for exercise" + , Option "" ["analyze-script"] analyzeScrArg "analyze feedback script and report errors" ] fileArg, rerunArg, testArg, makeScrArg, analyzeScrArg :: ArgDescr CmdLineOption
src/Ideas/Main/Default.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS -Wno-deprecations #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -24,19 +25,19 @@ import Data.ByteString (ByteString, unpack) import Data.Char import Data.Maybe -import Data.Monoid import Data.String -import Ideas.Encoding.ModeJSON (processJSON) +import Ideas.Encoding.NewModeJSON (processJSON) import Ideas.Encoding.ModeXML (processXML) -import Ideas.Encoding.Options (Options, maxTime, optionCgiBin, logRef) +import Ideas.Encoding.Options (Options, optionCgiBin, logRef) import Ideas.Encoding.Request import Ideas.Main.CmdLineOptions hiding (fullVersion) import Ideas.Service.DomainReasoner import Ideas.Service.FeedbackScript.Analysis import Ideas.Service.ServiceList import Ideas.Service.Types (Service) +import qualified Ideas.Text.UTF8 as UTF8 import Ideas.Text.XML.Unicode (decoding) -import Ideas.Utils.BlackBoxTests +import qualified Ideas.Utils.BlackBoxTests as BB import Ideas.Utils.Prelude import Ideas.Utils.TestSuite import Network.HTTP.Types @@ -65,8 +66,8 @@ 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 >>= decoding + addr = "" -- no IP address of the remote host (GDPR) + input <- inputOrDefault req >>= decodingIO -- process request (preq, txt, ctp) <- process (optionCgiBin script options) dr input @@ -75,7 +76,7 @@ { Log.ipaddress = addr , Log.version = shortVersion , Log.input = input - , Log.output = txt + , Log.output = fromMaybe txt (UTF8.decode txt) } -- log request to database when (useLogging preq) $ @@ -122,7 +123,7 @@ processDatabase dr database InputFile file -> withBinaryFile file ReadMode $ \h -> do - input <- hGetContents h >>= decoding + input <- hGetContents h >>= decodingIO (req, txt, _) <- process options dr input putStrLn txt when (PrintLog `elem` cmdLineOptions) $ do @@ -130,25 +131,25 @@ { Log.ipaddress = "command-line" , Log.version = shortVersion , Log.input = input - , Log.output = txt + , Log.output = fromMaybe txt (UTF8.decode txt) } Log.printLog (logRef options) -- blackbox tests Test dir -> do - tests <- blackBoxTests (makeTestRunner dr) ["xml", "json"] dir + let mode = if Interactive `elem` cmdLineOptions then BB.Interactive else BB.Report + tests <- BB.blackBoxTests (makeTestRunner dr) mode ["xml", "json"] dir result <- runTestSuiteResult True tests printSummary result -- feedback scripts MakeScriptFor s -> makeScriptFor dr s AnalyzeScript file -> parseAndAnalyzeScript dr file - PrintLog -> return () + _ -> return () processDatabase :: DomainReasoner -> FilePath -> IO () processDatabase dr database = do (n, time) <- getDiffTime $ do rows <- Log.selectFrom database "requests" ["input"] $ \row -> do - txt <- headM row - (_, out, _) <- process mempty dr txt + (_, out, _) <- process mempty dr (head row) putStrLn out return (length rows) putStrLn $ "processed " ++ show n ++ " requests in " ++ show time @@ -156,7 +157,7 @@ process :: Options -> DomainReasoner -> String -> IO (Request, String, String) process options dr input = do format <- discoverDataFormat input - run format options {maxTime = Just 5} (addVersion dr) input + run format options (addVersion dr) input `catch` \e -> do let msg = "Error: " ++ show (e :: SomeException) Log.changeLog (logRef options) (\r -> r { Log.errormsg = msg }) @@ -166,9 +167,10 @@ run JSON = processJSON makeTestRunner :: DomainReasoner -> String -> IO String -makeTestRunner dr input = do - (_, out, _) <- decoding input >>= process mempty dr - return out +makeTestRunner dr = decodingIO >=> fmap snd3 . process mempty dr + +decodingIO :: String -> IO String +decodingIO = maybe (fail "unicode decoding failed") return . decoding addVersion :: DomainReasoner -> DomainReasoner addVersion dr = dr
src/Ideas/Main/Revision.hs view
@@ -2,10 +2,10 @@ module Ideas.Main.Revision where ideasVersion :: String-ideasVersion = "1.8"+ideasVersion = "1.8.1" ideasRevision :: String-ideasRevision = "26fe80bf0f02342b55587676d6d34fd4bbcd3cad"+ideasRevision = "27a352d26571dad5913f9786c09ce5cda3021793" ideasLastChanged :: String-ideasLastChanged = "Mon Sep 9 12:42:00 2019 +0200"+ideasLastChanged = "Thu Sep 26 13:14:08 2019 +0200"
+ src/Ideas/Service/Apply.hs view
@@ -0,0 +1,108 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Service.Apply+ ( ApplyResult(..), tApplyResult, apply+ ) where++import Data.Either+import Data.List+import Ideas.Common.Library hiding (apply)+import Ideas.Service.State+import Ideas.Service.BasicServices (allfirsts)+import Ideas.Service.Types+import qualified Data.Set as S++----------------------------------------------------------------+-- Result types for apply service++data ApplyResult a+ = SyntaxError String+ | Correct Bool (State a)+ | Buggy Environment (Rule (Context a))+ | Incorrect++instance Show (ApplyResult a) where+ show (SyntaxError _) = "SyntaxError"+ show (Correct _ _) = "Correct"+ show (Buggy _ r) = "Buggy(" ++ show r ++ ")"+ show Incorrect = "Incorrect"++----------------------------------------------------------------+-- The apply feedback service++-- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the+-- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied+-- to the current term at the given location, in which case the request is invalid.+apply :: Rule (Context a) -> Location -> Environment -> State a -> ApplyResult a+apply r loc env st+ | withoutPrefix st = applyOff+ | otherwise = applyOn+ where+ applyOn = -- scenario 1: on-strategy+ case [ new | (stepInfo, new) <- fromRight [] (allfirsts st), testStep stepInfo ] of+ [] -> applyOff+ new:_ -> correct new++ applyOff = -- scenario 2: off-strategy+ case transApplyWith env (transformation r) ca of+ (new, _):_ -> correct (restart (st {stateContext = new, statePrefix = noPrefix}))+ [] ->+ -- first check the environment (exercise-specific property)+ case environmentCheck st env of+ Just msg ->+ SyntaxError msg+ Nothing ->+ -- try to find a buggy rule+ case siblingsFirst [ (envOut, br) | br <- ruleset (exercise st), isBuggy br, (_, envOut) <- transApplyWith env (transformation br) ca ] of+ [] -> Incorrect+ (envOut, br):_ -> Buggy envOut br++ ca = setLocation loc (stateContext st)++ siblingsFirst xs = ys ++ zs+ where+ (ys, zs) = partition (siblingInCommon r . snd) xs++ testStep (r1, loc1, env1) =+ r == r1 && loc == loc1 && (noBindings env || env == env1)++environmentCheck :: State a -> Environment -> Maybe String+environmentCheck st env = do+ p <- getProperty "environment-check" (exercise st)+ p env++correct :: State a -> ApplyResult a+correct st = Correct (finished st) st++siblingInCommon :: Rule a -> Rule a -> Bool+siblingInCommon r1 r2 = not (S.null (getSiblings r1 `S.intersection` getSiblings r2))+ where+ getSiblings r = S.fromList (getId r : ruleSiblings r)++----------------------------------------------------------------+-- Helpers++tApplyResult :: Type a (ApplyResult a)+tApplyResult = Tag "ApplyResult" $ Iso (f <-> g) tp+ where+ tp = tString :|: tPair tBool tState :|: tPair tEnvironment tRule :|: tUnit++ f (Left msg) = SyntaxError msg+ f (Right (Left (b, st))) = Correct b st+ f (Right (Right (Left (env, r)))) = Buggy env r+ f (Right (Right (Right ()))) = Incorrect++ g (SyntaxError msg) = Left msg+ g (Correct b st) = Right (Left (b, st))+ g (Buggy env r) = Right (Right (Left (env, r)))+ g Incorrect = Right (Right (Right ()))
src/Ideas/Service/BasicServices.hs view
@@ -13,21 +13,19 @@ module Ideas.Service.BasicServices ( -- * Basic Services stepsremaining, findbuggyrules, allfirsts, solution, solutionMaxSteps - , onefirst, onefinal, applicable, allapplications, apply, generate, create + , onefirst, onefinal, applicable, allapplications, generate, create , StepInfo, tStepInfo, exampleDerivations, recognizeRule ) where import Control.Monad import Data.List -import Data.Maybe import Ideas.Common.Examples import Ideas.Common.Library hiding (applicable, apply, ready) -import Ideas.Common.Traversal.Navigator (downs, navigateTo) +import Ideas.Common.Traversal.Navigator (downs) import Ideas.Service.State import Ideas.Service.Types import Ideas.Utils.Prelude (fst3) import Test.QuickCheck.Random -import qualified Data.Set as S import qualified Ideas.Common.Classes as Apply import qualified Ideas.Common.Library as Library @@ -37,22 +35,22 @@ Just a -> Right $ startState rng ex userId a Nothing -> Left "No random term" -create :: QCGen -> Exercise a -> String -> Maybe String -> Either String (State a) -create rng ex txt userId = - case parser ex txt of - Left err -> Left err - Right a - | evalPredicate (Library.ready ex) a -> Left "Is ready" - | evalPredicate (Library.suitable ex) a -> Right $ startState rng ex userId a +create :: QCGen -> Exercise a -> Context a -> Maybe String -> Either String (State a) +create rng ex ctx userId = + case fromContext ctx of + Just a + | evalPredicate (Library.ready ex) a -> Left "Is ready" + | evalPredicate (Library.suitable ex) a -> Right $ startStateContext rng ex userId ctx | otherwise -> Left "Not suitable" + Nothing -> Left "Invalid value" -- TODO: add a location to each step -solution :: Maybe StrategyCfg -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a)) +solution :: Maybe StrategyCfg -> State a -> Either String (Derivation (StepInfo a) (Context a)) solution = solutionMaxSteps 50 -solutionMaxSteps :: Int -> Maybe StrategyCfg -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a)) +solutionMaxSteps :: Int -> Maybe StrategyCfg -> State a -> Either String (Derivation (StepInfo a) (Context a)) solutionMaxSteps maxSteps mcfg state = - mapSecond (biMap (\(r, _, as) -> (r, as)) stateContext) $ + mapSecond (fmap stateContext) $ case mcfg of _ | withoutPrefix state -> Left "Prefix is required" -- configuration is only allowed beforehand: hence, the prefix @@ -81,7 +79,7 @@ type StepInfo a = (Rule (Context a), Location, Environment) -- find a good place tStepInfo :: Type a (StepInfo a) -tStepInfo = tTuple3 tRule tLocation tEnvironment +tStepInfo = Tag "step" (tTuple3 tRule tLocation tEnvironment) allfirsts :: State a -> Either String [(StepInfo a, State a)] allfirsts state @@ -133,55 +131,6 @@ EQ -> loc1 `compare` loc2 this -> this --- local helper -setLocation :: Location -> Context a -> Context a -setLocation loc c0 = fromMaybe c0 (navigateTo loc c0) - --- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the --- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied --- to the current term at the given location, in which case the request is invalid. -apply :: Rule (Context a) -> Location -> Environment -> State a -> Either String (State a) -apply r loc env state - | withoutPrefix state = applyOff - | otherwise = applyOn - where - applyOn = -- scenario 1: on-strategy - maybe applyOff Right $ listToMaybe - [ s1 | Right xs <- [allfirsts state], ((r1, loc1, env1), s1) <- xs, r==r1, loc==loc1, noBindings env || env==env1 ] - - ca = setLocation loc (stateContext state) - applyOff = -- scenario 2: off-strategy - case transApplyWith env (transformation r) ca of - (new, _):_ -> Right (restart (state {stateContext = new, statePrefix = noPrefix})) - [] -> - -- first check the environment (exercise-specific property) - case environmentCheck of - Just msg -> - Left msg - Nothing -> - -- try to find a buggy rule - case siblingsFirst [ (br, envOut) | br <- ruleset (exercise state), isBuggy br, (_, envOut) <- transApplyWith env (transformation br) ca ] of - [] -> Left ("Cannot apply " ++ show r) - brs -> Left ("Buggy rule " ++ intercalate "+" (map pp brs)) - where - pp (br, envOut) - | noBindings envOut = show br - | otherwise = show br ++ " {" ++ show envOut ++ "}" - - siblingsFirst xs = ys ++ zs - where - (ys, zs) = partition (siblingInCommon r . fst) xs - - environmentCheck :: Maybe String - environmentCheck = do - p <- getProperty "environment-check" (exercise state) - p env - -siblingInCommon :: Rule a -> Rule a -> Bool -siblingInCommon r1 r2 = not (S.null (getSiblings r1 `S.intersection` getSiblings r2)) - where - getSiblings r = S.fromList (getId r : ruleSiblings r) - stepsremaining :: State a -> Either String Int stepsremaining = mapSecond derivationLength . solution Nothing @@ -206,5 +155,5 @@ `mplus` -- or there concatMap rec (downs x) -exampleDerivations :: Exercise a -> Either String [Derivation (Rule (Context a), Environment) (Context a)] +exampleDerivations :: Exercise a -> Either String [Derivation (StepInfo a) (Context a)] exampleDerivations ex = mapM (solution Nothing . emptyState ex) (examplesAsList ex)
src/Ideas/Service/Diagnose.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -14,15 +13,15 @@ ----------------------------------------------------------------------------- module Ideas.Service.Diagnose - ( Diagnosis(..), tDiagnosis, diagnose + ( Diagnosis(..), tDiagnosis, diagnose, diagnoseOption , getState, getStateAndReady , difference ) where -import Data.List (intercalate, sortBy) +import Data.List (find, intercalate, sortBy) import Data.Maybe import Ideas.Common.Library hiding (ready) -import Ideas.Service.BasicServices hiding (apply) +import Ideas.Service.BasicServices import Ideas.Service.State import Ideas.Service.Types import qualified Ideas.Common.Rewriting.Difference as Diff @@ -34,7 +33,7 @@ = SyntaxError String | Buggy Environment (Rule (Context a)) | NotEquivalent String - | Similar Bool (State a) + | Similar Bool (State a) (Maybe (Rule (Context a))) | WrongRule Bool (State a) (Maybe (Rule (Context a))) | Expected Bool (State a) (Rule (Context a)) | Detour Bool (State a) Environment (Rule (Context a)) @@ -48,7 +47,7 @@ SyntaxError s -> f "SyntaxError" [s] Buggy _ r -> f "Buggy" [show r] NotEquivalent s -> f "NotEquivalent" [ s | not (null s) ] - Similar _ _ -> "Similar" + Similar _ _ _ -> "Similar" WrongRule _ _ mr -> f "WrongRule" [ show r | r <- maybeToList mr ] Expected _ _ r -> f "Expected" [show r] Detour _ _ _ r -> f "Detour" [show r] @@ -68,7 +67,7 @@ SyntaxError _ -> Nothing Buggy _ _ -> Nothing NotEquivalent _ -> Nothing - Similar b s -> Just (s, b) + Similar b s _ -> Just (s, b) WrongRule b s _ -> Just (s, b) Expected b s _ -> Just (s, b) Detour b s _ _ -> Just (s, b) @@ -79,39 +78,52 @@ -- The diagnose service diagnose :: State a -> Context a -> Maybe Id -> Diagnosis a -diagnose state new motivationId +diagnose = diagnoseOption False + +diagnoseOption :: Bool -> State a -> Context a -> Maybe Id -> Diagnosis a +diagnoseOption keepUserTerm state new motivationId -- Is the submitted term equivalent? | not (equivalence ex (stateContext state) new) = -- Is the rule used discoverable by trying all known buggy rules? - case discovered True Nothing of + case discovered isBuggy of Just (r, as) -> Buggy as r -- report the buggy rule Nothing -> NotEquivalent "" -- compareParts state new -- Is the used rule that is submitted applied correctly? - | isJust motivationId && isNothing (discovered False motivationId) = - case discovered False Nothing of -- search for a "sound" rule + | maybe False (isNothing . discovered . isRuleId) motivationId = + case discovered (not . isBuggy) of -- search for a "sound" rule Just (r, _) -> WrongRule (finished state) state (Just r) - Nothing -> - case discovered True Nothing of -- search for buggy rule + _ -> + case discovered isBuggy of -- search for buggy rule Just (r, as) -> Buggy as r -- report the buggy rule - Nothing -> - WrongRule (finished state) state Nothing + Nothing + | similar && maybe False isMinor motivationRule -> + Similar (finished state) state motivationRule + | otherwise -> + WrongRule (finished state) state Nothing -- Was the submitted term expected by the strategy? | isJust expected = -- If yes, return new state and rule - let ((r, _, _), ns) = fromJust expected - in Expected (finished ns) ns r + let ((r, _, _), st) = fromJust expected + newState | keepUserTerm = st { stateContext = new } + | otherwise = st + in Expected (finished newState) newState r -- Is the submitted term (very) similar to the previous one? -- (this check is performed after "expected by strategy". TODO: fix -- granularity of some math rules) - | similar = Similar (finished state) state + | similar = + case discovered (isMinor <&&> (not . isBuggy)) of + Just (r, _) -> + Similar (finished state) state (Just r) + Nothing -> + Similar (finished state) state Nothing -- Is the rule used discoverable by trying all known rules? | otherwise = - case discovered False Nothing of + case discovered (const True) of Just (r, as) -> -- If yes, report the found rule as a detour Detour (finished restarted) restarted as r Nothing -> -- If not, we give up @@ -121,16 +133,19 @@ restarted = restart state {stateContext = new} similar = similarity ex (stateContext state) new + motivationRule = find ((== motivationId) . Just . getId) $ ruleset ex + expected = do let xs = either (const []) id $ allfirsts state p (_, ns) = similarity ex new (stateContext ns) -- use rule recognizer? listToMaybe (filter p xs) - discovered searchForBuggy searchForRule = listToMaybe + isRuleId n r = n `elem` getId r : ruleSiblings r + + discovered condition = listToMaybe [ (r, env) | r <- sortBy (ruleOrdering ex) (ruleset ex) - , isBuggy r == searchForBuggy - , maybe True (`elem` getId r:ruleSiblings r) searchForRule + , condition r , (_, env) <- recognizeRule ex r sub1 sub2 ] where @@ -146,14 +161,14 @@ tDiagnosis = Tag "Diagnosis" $ Iso (f <-> g) tp where tp = (tString :|: tPair tEnvironment tRule :|: (tString :|: tTuple3 tBool tState (tMaybe tRule))) - :|: tPair tBool tState :|: tTuple3 tBool tState tRule + :|: tTuple3 tBool tState (tMaybe tRule) :|: tTuple3 tBool tState tRule :|: tTuple4 tBool tState tEnvironment tRule :|: tPair tBool tState :|: tPair tBool tState f (Left (Left s)) = SyntaxError s f (Left (Right (Left (as, r)))) = Buggy as r f (Left (Right (Right (Left s)))) = NotEquivalent s f (Left (Right (Right (Right (b, s, mr))))) = WrongRule b s mr - f (Right (Left (b, s))) = Similar b s + f (Right (Left (b, s, mr))) = Similar b s mr f (Right (Right (Left (b, s, r)))) = Expected b s r f (Right (Right (Right (Left (b, s, as, r))))) = Detour b s as r f (Right (Right (Right (Right (Left (b, s)))))) = Correct b s @@ -163,7 +178,7 @@ g (Buggy as r) = Left (Right (Left (as, r))) g (NotEquivalent s) = Left (Right (Right (Left s))) g (WrongRule b s mr) = Left (Right (Right (Right (b, s, mr)))) - g (Similar b s) = Right (Left (b, s)) + g (Similar b s mr) = Right (Left (b, s, mr)) g (Expected b s r) = Right (Right (Left (b, s, r))) g (Detour b s as r) = Right (Right (Right (Left (b, s, as, r)))) g (Correct b s) = Right (Right (Right (Right (Left (b, s)))))
src/Ideas/Service/DomainReasoner.hs view
@@ -89,15 +89,16 @@ servicesSorted :: DomainReasoner -> [Service] servicesSorted = sortOn showId . services -findExercise :: Monad m => DomainReasoner -> Id -> m (Some Exercise) +findExercise :: DomainReasoner -> Id -> Either String (Some Exercise) findExercise dr i = case [ a | a@(Some ex) <- exercises dr, getId ex == realName ] of - [this] -> return this - _ -> fail $ "Exercise " ++ show i ++ " not found" + [] -> Left $ "Exercise " ++ show i ++ " not found" + [this] -> Right this + _ -> Left $ "Ambiguous exercise " ++ show i where realName = fromMaybe i (lookup i (aliases dr)) -findService :: Monad m => DomainReasoner -> Id -> m Service +findService :: DomainReasoner -> Id -> Either String Service findService dr a | null (qualifiers a) = -- search for unqualified string findWith (\s -> unqualified s == unqualified a) @@ -106,10 +107,12 @@ where findWith p = single $ filter p $ services dr - single [] = fail $ "No service " ++ showId a - single [hd] = return hd - single _ = fail $ "Ambiguous service " ++ showId a + single [] = Left $ "No service " ++ showId a + single [hd] = Right hd + single _ = Left $ "Ambiguous service " ++ showId a defaultScript :: DomainReasoner -> Id -> IO Script -defaultScript dr = - maybe (return mempty) parseScriptSafe . (`lookup` scripts dr)+defaultScript dr n = + maybe (return mempty) parseScriptSafe (realName `lookup` scripts dr) + where + realName = fromMaybe n (lookup n (aliases dr))
src/Ideas/Service/FeedbackScript/Analysis.hs view
@@ -30,7 +30,7 @@ makeScriptFor :: IsId a => DomainReasoner -> a -> IO () makeScriptFor dr exId = do - Some ex <- findExercise dr (newId exId) + Some ex <- either fail return $ findExercise dr (newId exId) let (brs, nrs) = partition isBuggy (ruleset ex) print $ makeScript $ Supports [getId ex] : @@ -42,7 +42,7 @@ parseAndAnalyzeScript dr file = do putStrLn $ "Parsing " ++ show file script <- parseScript file - let exs = [ maybe unknown Right (findExercise dr a) + let exs = [ either (const unknown) Right (findExercise dr a) | Supports as <- scriptDecls script , a <- as , let unknown = Left (UnknownExercise a)
src/Ideas/Service/FeedbackScript/Parser.hs view
@@ -20,7 +20,6 @@ import Control.Monad import Data.Char import Data.List -import Data.Semigroup import Ideas.Common.Id import Ideas.Service.FeedbackScript.Syntax import Ideas.Utils.Parsing
src/Ideas/Service/FeedbackScript/Run.hs view
@@ -128,7 +128,7 @@ NotEquivalent s -> makeNotEq s "noteq" env Expected _ _ r -> makeOk "ok" env {recognized = Just r} WrongRule _ _ mr -> makeWrong "wrongrule" env {recognized = mr} - Similar _ _ -> makeOk "same" env + Similar _ _ mr -> makeOk "same" env {recognized = mr} Detour _ _ _ r -> makeOk "detour" env {recognized = Just r} Correct _ _ -> makeOk "correct" env Unknown _ _ -> makeOk "unknown" env
src/Ideas/Service/FeedbackText.hs view
@@ -23,13 +23,14 @@ import Ideas.Service.FeedbackScript.Syntax import Ideas.Service.State import Ideas.Service.Types +import Ideas.Utils.Prelude data Message = M { accept :: Maybe Bool, text :: Text } tMessage :: Type a Message -tMessage = Tag "Message" $ Iso (f <-> g) tp +tMessage = Iso (f <-> g) tp where - tp = tPair tBool tText :|: tText + tp = tPair (Tag "accept" tBool) (Tag "message" tText) :|: (Tag "message" tText) f = either (\(b, t) -> M (Just b) t) (M Nothing) g m = maybe (Right (text m)) (\b -> Left (b, text m)) (accept m) @@ -38,7 +39,7 @@ derivationtext :: Script -> State a -> Either String (Derivation String (Context a)) derivationtext script state = - let f = ruleToString (newEnvironment state Nothing) script . fst + let f = ruleToString (newEnvironment state Nothing) script . fst3 in right (mapFirst f) (solution Nothing state) onefirsttext :: Script -> State a -> Maybe String -> (Message, Maybe (State a)) @@ -80,7 +81,7 @@ NotEquivalent _ -> (msg False, old) Expected _ s _ -> (msg True, s) WrongRule _ s _ -> (msg True, s) - Similar _ s -> (msg True, s) + Similar _ s _ -> (msg True, s) Detour _ s _ _ -> (msg True, s) Correct _ s -> (msg False, s) Unknown _ s -> (msg False, s)
src/Ideas/Service/ServiceList.hs view
@@ -22,6 +22,7 @@ import Ideas.Service.Types import Ideas.Utils.TestSuite hiding (Message) import qualified Ideas.Service.Diagnose as Diagnose +import qualified Ideas.Service.Apply as Apply import qualified Ideas.Service.ProblemDecomposition as ProblemDecomposition import qualified Ideas.Service.Submit as Submit @@ -58,7 +59,7 @@ \current expression. The first optional argument lets you configure the \ \strategy, i.e., make some minor modifications to it. Rules used and \ \intermediate expressions are returned in a list." $ - solution ::: tMaybe tStrategyCfg .-> tState .-> tError (tDerivation (tPair tRule tEnvironment) tContext) + solution ::: tMaybe tStrategyCfg .-> tState .-> tError (tDerivation tStepInfo tContext) derivationS :: Service derivationS = deprecate $ makeService "basic.derivation" @@ -71,7 +72,7 @@ \onefirst service to get only one suggestion. For each suggestion, a new \ \state, the rule used, and the location where the rule was applied are \ \returned." $ - allfirsts ::: tState .-> tError (tList (tPair tStepInfo tState)) + allfirsts ::: tState .-> tError (tList (Tag "first" (tPair tStepInfo tState))) onefirstS :: Service onefirstS = makeService "basic.onefirst" @@ -79,7 +80,7 @@ \service to get all possible steps that are allowed by the strategy. In \ \addition to a new state, the rule used and the location where to apply \ \this rule are returned." $ - onefirst ::: tState .-> tString :|: Tag "elem" (tPair tStepInfo tState) + onefirst ::: tState .-> tString :|: Tag "first" (tPair tStepInfo tState) -- special tag for (legacy) xml encoding onefinalS :: Service @@ -138,7 +139,7 @@ "Apply a rule at a certain location to the current expression. If this rule \ \was not expected by the strategy, we deviate from it. If the rule cannot \ \be applied, this service call results in an error." $ - apply ::: tRule .-> tLocation .-> tEnvironment .-> tState .-> tError tState + Apply.apply ::: tRule .-> tLocation .-> tEnvironment .-> tState .-> Apply.tApplyResult generateS :: Service generateS = makeService "basic.generate" @@ -150,7 +151,7 @@ createS = makeService "basic.create" "Given an expression, this service \ \returns an initial state with the original given expression." $ - create ::: tQCGen .-> tExercise .-> tString .-> tMaybe tUserId .-> tError tState + create ::: tQCGen .-> tExercise .-> tContext .-> tMaybe tUserId .-> tError tState examplesS :: Service examplesS = makeService "basic.examples" @@ -166,7 +167,7 @@ \with an exercise. These are the examples that appear at the page generated \ \for each exercise. Also see the generate service, which returns a random \ \start term." $ - f ::: tQCGen .-> tExercise .-> tInt .-> tMaybe tUserId .-> tError tState + f ::: tQCGen .-> tExercise .-> Tag "nr" tInt .-> tMaybe tUserId .-> tError tState where f rng ex nr userId = case drop nr (examplesAsList ex) of @@ -202,7 +203,7 @@ diagnoseStringS :: Service diagnoseStringS = makeService "basic.diagnose-string" "See diagnose service, but also returns a SyntaxError for invalid input." $ - diagnoseString ::: tState .-> tString .-> tMaybe tId .-> Diagnose.tDiagnosis + diagnoseString ::: tState .-> Tag "term" tString .-> tMaybe tId .-> Diagnose.tDiagnosis diagnoseString :: State a -> String -> Maybe Id -> Diagnose.Diagnosis a diagnoseString st s mot = @@ -318,14 +319,14 @@ microstepsS :: Service microstepsS = makeService "meta.microsteps" "Next (minor) steps." $ - (map f . microsteps) ::: tState .-> tList (tPair (tTuple3 tRule tLocation tEnvironment) tState) + (map f . microsteps) ::: tState .-> tList (Tag "first" (tPair tStepInfo tState)) where f ((s, ctx, env), st) = ((s, location ctx, env), st) examplederivationsS :: Service examplederivationsS = makeService "meta.examplederivations" "Show example derivations" $ - exampleDerivations ::: tExercise .-> tError (tList (tDerivation (tPair tRule tEnvironment) tContext)) + exampleDerivations ::: tExercise .-> tError (tList (tDerivation tStepInfo tContext)) testreportS :: Service testreportS = makeService "meta.testreport"
src/Ideas/Service/State.hs view
@@ -16,7 +16,7 @@ module Ideas.Service.State ( -- * Exercise state - State, startState, makeState, makeNoState, emptyStateContext, emptyState + State, startState, startStateContext, makeState, makeNoState, emptyStateContext, emptyState , exercise, statePrefix, stateContext, stateTerm , stateUser, stateSession, stateStartTerm, restart , withoutPrefix, stateLabels, suitable, finished, firsts, microsteps @@ -97,13 +97,16 @@ emptyState ex = emptyStateContext ex . inContext ex startState :: QCGen -> Exercise a -> Maybe String -> a -> State a -startState gen ex userId a = st +startState gen ex userId = startStateContext gen ex userId . inContext ex + +startStateContext :: QCGen -> Exercise a -> Maybe String -> Context a -> State a +startStateContext gen ex userId ctx = st { stateUser = userId , stateSession = Just sid - , stateStartTerm = Just (prettyPrinter ex a) + , stateStartTerm = fmap (prettyPrinter ex) (fromContext ctx) } where - st = emptyStateContext ex (inContext ex a) + st = emptyStateContext ex ctx sid = newSessionId gen -- Restart the strategy: make sure that the new state has a prefix
src/Ideas/Service/Submit.hs view
@@ -46,7 +46,7 @@ Diagnose.SyntaxError s -> NotEquivalent s -- should not happen Diagnose.Buggy _ r -> Buggy [r] Diagnose.NotEquivalent s -> NotEquivalent s - Diagnose.Similar _ s -> Ok [] s + Diagnose.Similar _ s _ -> Ok [] s Diagnose.Expected _ s r -> Ok [r] s Diagnose.WrongRule _ s mr -> Ok (maybeToList mr) s Diagnose.Detour _ s _ r -> Detour [r] s
src/Ideas/Service/Types.hs view
@@ -68,8 +68,8 @@ class Equal f where equal :: f a -> f b -> Maybe (a -> b) -equalM :: Monad m => Type a t1 -> Type a t2 -> m (t1 -> t2) -equalM t1 t2 = maybe (fail msg) return (equal t1 t2) +equalM :: Type a t1 -> Type a t2 -> Either String (t1 -> t2) +equalM t1 t2 = maybe (Left msg) Right (equal t1 t2) where msg = "Types not equal: " ++ show t1 ++ " and " ++ show t2 instance Equal f => Equal (TypeRep f) where @@ -77,6 +77,7 @@ equal t1 (Iso p b) = fmap (from p .) (equal t1 b) equal (a :-> b) (c :-> d) = liftM2 (\f g h -> g . h . f) (equal c a) (equal b d) + equal (IO a) (IO b) = fmap liftM (equal a b) equal (Pair a b) (Pair c d) = liftM2 (***) (equal a c) (equal b d) equal (a :|: b) (c :|: d) = liftM2 biMap (equal a c) (equal b d) equal (List a) (List b) = fmap map (equal a b) @@ -270,7 +271,8 @@ tDerivation :: Type a t1 -> Type a t2 -> Type a (Derivation t1 t2) tDerivation t1 t2 = Tag "Derivation" $ Iso (f <-> g) tp where - tp = tPair t2 (tList (tPair t1 t2)) + tp = tPair t2 (Tag "derivationsteps" (tList (tPair t1 t2))) + f (a, xs) = foldl extend (emptyDerivation a) xs g d = (firstTerm d, [ (s, a) | (_, s, a) <- triples d ])
src/Ideas/Text/HTML.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -15,15 +16,15 @@ module Ideas.Text.HTML ( ToHTML(..), HTMLPage, HTMLBuilder - , addCSS, addScript, addStyle, showHTML + , addCSS, addScript, addStyle, changeBody, showHTML , string, text , htmlPage, link , h1, h2, h3, h4, h5, h6 , preText, ul, table, keyValueTable - , image, space, spaces, (<#>), spaced + , image, space, spaces, (<#>), (<##>), (<###>), spaced, spacedBy , highlightXML - , para, ttText, hr, br, pre, bullet - , divClass, spanClass + , para, paras, ttText, hr, br, pre, bullet + , dv, divClass, spanClass -- HTML generic attributes , idA, classA, styleA, titleA -- Font style elements @@ -32,9 +33,7 @@ import Data.Char import Data.List -import Data.Monoid import Ideas.Text.XML -import Prelude hiding (div) import qualified Data.Map as M import qualified Ideas.Text.XML as XML @@ -84,11 +83,11 @@ , styleSheets :: [FilePath] , scripts :: [FilePath] , styleTxts :: [String] - , htmlContent :: HTMLBuilder + , htmlBody :: HTMLBuilder } instance ToXML HTMLPage where - toXML page = makeXML "html" $ + toXML page = makeXML (toName "html") $ element "head" [ tag "title" (string (title page)) , mconcat @@ -108,7 +107,7 @@ | js <- scripts page ] ] - <> tag "body" (htmlContent page) + <> tag "body" (htmlBody page) showHTML :: HTMLPage -> String showHTML = compactXML . toXML @@ -122,6 +121,9 @@ addStyle :: String -> HTMLPage -> HTMLPage addStyle txt page = page { styleTxts = txt : styleTxts page } +changeBody :: (HTMLBuilder -> HTMLBuilder) -> HTMLPage -> HTMLPage +changeBody f p = p { htmlBody = f (htmlBody p) } + -- html helper functions htmlPage :: String -> HTMLBuilder -> HTMLPage htmlPage s = HTMLPage s [] [] [] @@ -193,14 +195,29 @@ (<#>) :: BuildXML a => a -> a -> a x <#> y = x <> space <> y +(<##>) :: BuildXML a => a -> a -> a +x <##> y = x <> spaces 2 <> y + +(<###>) :: BuildXML a => a -> a -> a +x <###> y = x <> spaces 3 <> y + spaced :: BuildXML a => [a] -> a -spaced = mconcat . intersperse space +spaced = spacedBy 1 +spacedBy :: BuildXML a => Int -> [a] -> a +spacedBy n = mconcat . intersperse (spaces n) + +paras :: BuildXML a => [a] -> a +paras = mconcat . map para + image :: BuildXML a => String -> a image n = tag "img" ("src" .=. n) +dv :: BuildXML a => a -> a +dv = tag "div" + divClass :: BuildXML a => String -> a -> a -divClass n a = tag "div" (classA n <> a) +divClass n a = dv (classA n <> a) spanClass :: BuildXML a => String -> a -> a spanClass n a = tag "span" (classA n <> a)
src/Ideas/Text/HTML/Templates.hs view
@@ -14,14 +14,13 @@ ----------------------------------------------------------------------------- module Ideas.Text.HTML.Templates - ( webpage, WebPage(..), Button(..), Style + ( webpage, WebPage(..), Button(..), emptyWebPage, emptyButton, Style , fontAwesome ) where -import Data.Monoid import Ideas.Text.HTML import Ideas.Text.HTML.W3CSS hiding (tag, ul, top, table, content) -import Ideas.Text.XML hiding (content) +import Ideas.Text.XML import qualified Ideas.Text.HTML.W3CSS as W3 data WebPage = WebPage @@ -39,6 +38,22 @@ , footerStyle :: Style } +emptyWebPage :: WebPage +emptyWebPage = WebPage + { title = "title" + , menuButtons = [] + , menuStyle = id + , iconBarsStyle = id + , sideWidth = 600 + , sideHeader = mempty + , sideButtons = [] + , sideStyle = id + , iconCloseStyle = id + , content = mempty + , footer = mempty + , footerStyle = id + } + type Style = HTMLBuilder -> HTMLBuilder data Button = Button @@ -46,6 +61,9 @@ , buttonStyle :: HTMLBuilder -> HTMLBuilder , buttonText :: HTMLBuilder } + +emptyButton :: Button +emptyButton = Button "" id mempty fromButtons :: [Button] -> HTMLBuilder fromButtons = mconcat . map fromButton
src/Ideas/Text/HTML/W3CSS.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -16,7 +17,6 @@ module Ideas.Text.HTML.W3CSS where import Data.Char -import Data.Monoid import Ideas.Text.HTML import Ideas.Text.XML import qualified Ideas.Text.XML as XML @@ -131,6 +131,13 @@ -- | Creates a responsive table responsive :: BuildXML a => a -> a responsive = w3class "w3-responsive" + +alignTable :: String -> [[HTMLBuilder]] -> [[HTMLBuilder]] +alignTable s = map (zipWith f (s ++ repeat 'l')) + where + f 'c' = center + f 'r' = rightAlign + f _ = id -------------------------------------------------------------------------------- -- * Card Classes
src/Ideas/Text/JSON.hs view
@@ -14,286 +14,15 @@ ----------------------------------------------------------------------------- module Ideas.Text.JSON - ( JSON(..), Key, Number(..) -- types - , InJSON(..) -- type class - , lookupM - , parseJSON, compactJSON -- parser and pretty-printers - , jsonRPC, RPCHandler, RPCResponse(..) - , propEncoding + ( module Ideas.Text.JSON.Data + , module Ideas.Text.JSON.Builder + , module Ideas.Text.JSON.Decoder + , module Ideas.Text.JSON.Class + , module Ideas.Text.JSON.RPC ) where -import Control.Exception -import Control.Monad -import Data.List (intersperse) -import Data.Maybe -import Ideas.Utils.Parsing hiding (string, char) -import System.IO.Error -import Test.QuickCheck -import Text.PrettyPrint.Leijen hiding ((<$>)) -import qualified Ideas.Text.UTF8 as UTF8 -import qualified Text.ParserCombinators.Parsec.Token as P - -data JSON - = Number Number -- integer, real, or floating point - | String String -- double-quoted Unicode with backslash escapement - | Boolean Bool -- true and false - | Array [JSON] -- ordered sequence (comma-separated, square brackets) - | Object [(Key, JSON)] -- collection of key/value pairs (comma-separated, curly brackets - | Null - deriving Eq - -type Key = String - -data Number = I Integer | D Double deriving Eq - -instance Show Number where - show (I n) = show n - show (D d) = show d - -instance Show JSON where - show = show . prettyJSON False - -compactJSON :: JSON -> String -compactJSON = show . prettyJSON True - -prettyJSON :: Bool -> JSON -> Doc -prettyJSON compact = rec - where - rec json = - case json of - Number n -> text (show n) - String s -> str (escape s) - Boolean b -> text (if b then "true" else "false") - Null -> text "null" - Array xs -> make lbracket rbracket (map rec xs) - Object xs -> make lbrace rbrace (map (uncurry (<:>)) xs) - - x <:> y | compact = str x <> char ':' <> rec y - | isSimple y = str x <> string ": " <> rec y - | otherwise = align (str x <> char ':' <> line <> indent 2 (rec y)) - - str = dquotes . text - - make open close xs - | compact || length xs < 2 = - enclose open close (hcat (intersperse comma xs)) - | otherwise = - align (vsep (zipWith (<+>) (open:repeat comma) xs ++ [close])) - - isSimple (Array xs) = null xs - isSimple (Object xs) = null xs - isSimple _ = True - --- Escape double quote and backslash, and convert to UTF8 encoding -escape :: String -> String -escape = concatMap f . fromMaybe "invalid UTF8 string" . UTF8.encodeM - where - f '\n' = "\\n" - f '\r' = "" -- carriage return (DOS files) - f '\t' = "\\t" - f '"' = "\\\"" - f '\\' = "\\\\" - f c = [c] - -class InJSON a where - toJSON :: a -> JSON - listToJSON :: [a] -> JSON - fromJSON :: Monad m => JSON -> m a - listFromJSON :: Monad m => JSON -> m [a] - -- default definitions - listToJSON = Array . map toJSON - listFromJSON (Array xs) = mapM fromJSON xs - listFromJSON _ = fail "expecting an array" - -instance InJSON Int where - toJSON = toJSON . toInteger - fromJSON = fmap fromInteger . fromJSON - -instance InJSON Integer where - toJSON = Number . I - fromJSON (Number (I n)) = return n - fromJSON _ = fail "expecting a number" - -instance InJSON Double where - toJSON = Number . D - fromJSON (Number (D n)) = return n - fromJSON _ = fail "expecting a number" - -instance InJSON Char where - toJSON c = String [c] - listToJSON = String - fromJSON (String [c]) = return c - fromJSON _ = fail "expecting a string" - listFromJSON (String s) = return s - listFromJSON _ = fail "expecting a string" - -instance InJSON Bool where - toJSON = Boolean - fromJSON (Boolean b) = return b - fromJSON _ = fail "expecting a boolean" - -instance InJSON a => InJSON [a] where - toJSON = listToJSON - fromJSON = listFromJSON - -instance (InJSON a, InJSON b) => InJSON (a, b) where - toJSON (a, b) = Array [toJSON a, toJSON b] - fromJSON (Array [a, b]) = (,) <$> fromJSON a <*> fromJSON b - fromJSON _ = fail "expecting an array with 2 elements" - -instance (InJSON a, InJSON b, InJSON c) => InJSON (a, b, c) where - toJSON (a, b, c) = Array [toJSON a, toJSON b, toJSON c] - fromJSON (Array [a, b, c]) = (,,) <$> fromJSON a <*> fromJSON b <*> fromJSON c - fromJSON _ = fail "expecting an array with 3 elements" - -instance (InJSON a, InJSON b, InJSON c, InJSON d) => InJSON (a, b, c, d) where - toJSON (a, b, c, d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] - fromJSON (Array [a, b, c, d]) = (,,,) <$> fromJSON a <*> fromJSON b <*> fromJSON c <*> fromJSON d - fromJSON _ = fail "expecting an array with 4 elements" - --------------------------------------------------------- --- Parser - -parseJSON :: String -> Either String JSON -parseJSON = parseSimple json - where - json :: Parser JSON - json = choice - [ Null <$ P.reserved lexer "null" - , Boolean True <$ P.reserved lexer "true" - , Boolean False <$ P.reserved lexer "false" - , Number . either I D <$> naturalOrFloat -- redefined in Ideas.Text.Parsing - , String <$> P.stringLiteral lexer - , Array <$> P.brackets lexer (sepBy json (P.comma lexer)) - , Object <$> P.braces lexer (sepBy keyValue (P.comma lexer)) - ] - - keyValue :: Parser (String, JSON) - keyValue = (,) <$> P.stringLiteral lexer <* P.colon lexer <*> json - - lexer :: P.TokenParser a - lexer = P.makeTokenParser $ emptyDef - { reservedNames = ["true", "false", "null"] } - --------------------------------------------------------- --- JSON-RPC - -data RPCRequest = Request - { requestMethod :: String - , requestParams :: JSON - , requestId :: JSON - } - -data RPCResponse = Response - { responseResult :: JSON - , responseError :: JSON - , responseId :: JSON - } - -instance Show RPCRequest where - show = show . toJSON - -instance Show RPCResponse where - show = show . toJSON - -instance InJSON RPCRequest where - toJSON req = Object - [ ("method", String $ requestMethod req) - , ("params", requestParams req) - , ("id" , requestId req) - ] - fromJSON json = - case lookupM "method" json of - Just (String s) -> - let pj = fromMaybe Null (lookupM "params" json) - ij = fromMaybe Null (lookupM "id" json) - in return (Request s pj ij) - Just _ -> fail "expecting a string as method" - Nothing -> fail "no method specified" - -instance InJSON RPCResponse where - toJSON resp = Object - [ ("result", responseResult resp) - , ("error" , responseError resp) - , ("id" , responseId resp) - ] - fromJSON obj = do - rj <- lookupM "result" obj - ej <- lookupM "error" obj - ij <- lookupM "id" obj - return (Response rj ej ij) - -okResponse :: JSON -> JSON -> RPCResponse -okResponse x y = Response - { responseResult = x - , responseError = Null - , responseId = y - } - -errorResponse :: JSON -> JSON -> RPCResponse -errorResponse x y = Response - { responseResult = Null - , responseError = x - , responseId = y - } - -lookupM :: Monad m => String -> JSON -> m JSON -lookupM x (Object xs) = maybe (fail $ "field " ++ x ++ " not found") return (lookup x xs) -lookupM _ _ = fail "expecting a JSON object" - --------------------------------------------------------- --- JSON-RPC over HTTP - -type RPCHandler = String -> JSON -> IO JSON - -jsonRPC :: JSON -> RPCHandler -> IO RPCResponse -jsonRPC input rpc = - case fromJSON input of - Nothing -> return (errorResponse (String "Invalid request") Null) - Just req -> do - json <- rpc (requestMethod req) (requestParams req) - return (okResponse json (requestId req)) - `catch` handler req - where - handler :: RPCRequest -> SomeException -> IO RPCResponse - handler req e = - let msg = maybe (show e) ioeGetErrorString (fromException e) - in return $ errorResponse (toJSON msg) (requestId req) - --------------------------------------------------------- --- Testing parser/pretty-printer - -instance Arbitrary JSON where - arbitrary = sized arbJSON - -instance Arbitrary Number where - arbitrary = oneof [ I <$> arbitrary, D . fromInteger <$> arbitrary ] - -arbJSON :: Int -> Gen JSON -arbJSON n - | n == 0 = oneof - [ Number <$> arbitrary, String <$> myStringGen - , Boolean <$> arbitrary, return Null - ] - | otherwise = oneof - [ arbJSON 0 - , do i <- choose (0, 6) - xs <- replicateM i rec - return (Array xs) - , do i <- choose (0, 6) - xs <- replicateM i myStringGen - ys <- replicateM i rec - return (Object (zip xs ys)) - ] - where - rec = arbJSON (n `div` 2) - -myStringGen :: Gen String -myStringGen = do - n <- choose (1, 10) - replicateM n $ elements $ - ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] - -propEncoding :: Property -propEncoding = property $ \a -> - parseJSON (show a) == Right a+import Ideas.Text.JSON.Builder +import Ideas.Text.JSON.Data +import Ideas.Text.JSON.Decoder +import Ideas.Text.JSON.Class +import Ideas.Text.JSON.RPC
+ src/Ideas/Text/JSON/Builder.hs view
@@ -0,0 +1,66 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Text.JSON.Builder+ ( JSONBuilder, arrayBuilder, jsonToBuilder, tagJSON, builderToJSON+ , isEmptyBuilder+ , extractFirst, extractKey, extractKeyAndValues+ ) where++import Data.Maybe+import Ideas.Text.JSON.Data++--------------------------------------------------------+-- JSON builder++newtype JSONBuilder = JB [(Maybe Key, JSON)]++instance Semigroup JSONBuilder where+ JB xs <> JB ys = JB (xs <> ys)++instance Monoid JSONBuilder where+ mempty = JB []++jsonToBuilder :: JSON -> JSONBuilder+jsonToBuilder a = JB [(Nothing, a)]++tagJSON :: String -> JSON -> JSONBuilder+tagJSON s a = JB [(Just s, a)]++arrayBuilder :: [JSONBuilder] -> JSONBuilder+arrayBuilder = jsonToBuilder . Array . map builderToJSON++isEmptyBuilder :: JSONBuilder -> Bool+isEmptyBuilder (JB xs) = null xs++extractFirst :: JSONBuilder -> Maybe (JSON, JSONBuilder)+extractFirst (JB ((Nothing, a):rest)) = Just (a, JB rest)+extractFirst _ = Nothing++extractKey :: Key -> JSONBuilder -> Maybe (JSON, JSONBuilder)+extractKey k (JB xs) =+ case break (maybe False (== k) . fst) xs of+ (xs1, (_, v):xs2) -> Just (v, JB (xs1 ++ xs2))+ _ -> Nothing++extractKeyAndValues :: JSONBuilder -> [(Key, JSON)]+extractKeyAndValues (JB xs) = [ (k, a) | (mk, a) <- xs, k <- maybeToList mk ]++builderToJSON :: JSONBuilder -> JSON+builderToJSON (JB [(Nothing, x)]) = x+builderToJSON (JB xs) = + case mapM fst xs of+ Just ks -> Object (zip ks (map snd xs))+ Nothing -> Array (map f xs)+ where+ f (Nothing, a) = a+ f (Just k, a) = Object [(k, a)]
+ src/Ideas/Text/JSON/Class.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Text.JSON.Class ( InJSON(..), (.=) ) where++import Control.Monad.State+import Ideas.Text.JSON.Builder+import Ideas.Text.JSON.Data+import Ideas.Text.JSON.Decoder++class InJSON a where+ toJSON :: a -> JSON+ listToJSON :: [a] -> JSON+ fromJSON :: JSON -> Maybe a+ jsonBuilder :: a -> JSONBuilder+ jsonListBuilder :: [a] -> JSONBuilder+ jsonDecoder :: DecoderJSON a+ jsonListDecoder :: DecoderJSON [a]++ {-# MINIMAL (toJSON | jsonBuilder), jsonDecoder #-}++ -- default definitions+ toJSON = builderToJSON . jsonBuilder+ listToJSON = Array . map toJSON+ fromJSON = either (fail . show) return . evalDecoderJSON jsonDecoder++ jsonBuilder = jsonToBuilder . toJSON+ jsonListBuilder = mconcat . map jsonBuilder + jsonListDecoder = jArrayOf jsonDecoder++instance InJSON Int where+ toJSON = toJSON . toInteger+ jsonDecoder = jInt++instance InJSON Integer where+ toJSON = Integer+ jsonDecoder = jInteger++instance InJSON Double where+ toJSON = Double+ jsonDecoder = jDouble++instance InJSON Char where+ toJSON c = String [c]+ listToJSON = String+ jsonListBuilder = jsonToBuilder . String + jsonDecoder = jChar+ jsonListDecoder = jString++instance InJSON Bool where+ toJSON = Boolean+ jsonDecoder = jBool++instance InJSON a => InJSON [a] where+ toJSON = listToJSON+ jsonBuilder = jsonListBuilder+ jsonDecoder = jsonListDecoder++instance InJSON () where+ jsonBuilder = mempty+ jsonDecoder = return ()++instance (InJSON a, InJSON b) => InJSON (a, b) where+ jsonBuilder (a, b) = jsonBuilder a <> jsonBuilder b+ jsonDecoder = (,) <$> jsonDecoder <*> jsonDecoder++instance (InJSON a, InJSON b, InJSON c) => InJSON (a, b, c) where+ jsonBuilder (a, b, c) = jsonBuilder a <> jsonBuilder b <> jsonBuilder c+ jsonDecoder = (,,) <$> jsonDecoder <*> jsonDecoder <*> jsonDecoder++instance (InJSON a, InJSON b, InJSON c, InJSON d) => InJSON (a, b, c, d) where+ jsonBuilder (a, b, c, d) = jsonBuilder a <> jsonBuilder b <> jsonBuilder c <> jsonBuilder d+ jsonDecoder = (,,,) <$> jsonDecoder <*> jsonDecoder <*> jsonDecoder <*> jsonDecoder++instance InJSON JSON where+ toJSON = id+ jsonDecoder = gets builderToJSON++instance InJSON JSONBuilder where+ jsonBuilder = id+ jsonDecoder = get++infix 7 .=++(.=) :: InJSON a => String -> a -> JSONBuilder+s .= a = tagJSON s (toJSON a)
+ src/Ideas/Text/JSON/Data.hs view
@@ -0,0 +1,152 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Text.JSON.Data+ ( JSON(..), Key -- types+ , lookupM+ , parseJSON, compactJSON -- parser and pretty-printers+ ) where++import Control.Monad+import Data.List (intersperse)+import Data.Maybe+import Data.String+import Ideas.Utils.Parsing hiding (string, char)+import Test.QuickCheck+import Text.PrettyPrint.Leijen hiding ((<$>))+import qualified Ideas.Text.UTF8 as UTF8+import qualified Text.ParserCombinators.Parsec.Token as P++data JSON+ = Integer Integer -- integer, ... + | Double Double -- ... real, or floating point+ | String String -- double-quoted Unicode with backslash escapement+ | Boolean Bool -- true and false+ | Array [JSON] -- ordered sequence (comma-separated, square brackets)+ | Object [(Key, JSON)] -- collection of key/value pairs (comma-separated, curly brackets+ | Null+ deriving Eq++type Key = String++instance Show JSON where+ show = show . prettyJSON False++instance IsString JSON where+ fromString = String++compactJSON :: JSON -> String+compactJSON = show . prettyJSON True++prettyJSON :: Bool -> JSON -> Doc+prettyJSON compact = rec+ where+ rec json =+ case json of+ Integer n -> text (show n)+ Double d -> text (show d)+ String s -> str (escape s)+ Boolean b -> text (if b then "true" else "false")+ Null -> text "null"+ Array xs -> make lbracket rbracket (map rec xs)+ Object xs -> make lbrace rbrace (map (uncurry (<:>)) xs)++ x <:> y | compact = str x <> char ':' <> rec y+ | isSimple y = str x <> string ": " <> rec y+ | otherwise = align (str x <> char ':' <> line <> indent 2 (rec y))++ str = dquotes . text++ make open close xs+ | compact || length xs < 2 =+ enclose open close (hcat (intersperse comma xs))+ | otherwise =+ align (vsep (zipWith (<+>) (open:repeat comma) xs ++ [close]))++ isSimple (Array xs) = null xs+ isSimple (Object xs) = null xs+ isSimple _ = True++-- Escape double quote and backslash, and convert to UTF8 encoding+escape :: String -> String+escape = concatMap f . fromMaybe "invalid UTF8 string" . UTF8.encode+ where+ f '\n' = "\\n"+ f '\r' = "" -- carriage return (DOS files)+ f '\t' = "\\t"+ f '"' = "\\\""+ f '\\' = "\\\\"+ f c = [c]++--------------------------------------------------------+-- Parser++parseJSON :: String -> Either String JSON+parseJSON = parseSimple json+ where+ json :: Parser JSON+ json = choice+ [ Null <$ P.reserved lexer "null"+ , Boolean True <$ P.reserved lexer "true"+ , Boolean False <$ P.reserved lexer "false"+ , either Integer Double <$> naturalOrFloat -- redefined in Ideas.Text.Parsing+ , String <$> P.stringLiteral lexer+ , Array <$> P.brackets lexer (sepBy json (P.comma lexer))+ , Object <$> P.braces lexer (sepBy keyValue (P.comma lexer))+ ]++ keyValue :: Parser (String, JSON)+ keyValue = (,) <$> P.stringLiteral lexer <* P.colon lexer <*> json++ lexer :: P.TokenParser a+ lexer = P.makeTokenParser $ emptyDef+ { reservedNames = ["true", "false", "null"] }++lookupM :: String -> JSON -> Either String JSON+lookupM x (Object xs) = maybe (Left $ "field " ++ x ++ " not found") Right (lookup x xs)+lookupM _ _ = Left "expecting a JSON object"++--------------------------------------------------------+-- Testing parser/pretty-printer++instance Arbitrary JSON where+ arbitrary = sized arbJSON++arbJSON :: Int -> Gen JSON+arbJSON n+ | n == 0 = oneof+ [ Integer <$> arbitrary, Double . fromInteger <$> arbitrary + , String <$> myStringGen+ , Boolean <$> arbitrary, return Null+ ]+ | otherwise = oneof+ [ arbJSON 0+ , do i <- choose (0, 6)+ xs <- replicateM i rec+ return (Array xs)+ , do i <- choose (0, 6)+ xs <- replicateM i myStringGen+ ys <- replicateM i rec+ return (Object (zip xs ys))+ ]+ where+ rec = arbJSON (n `div` 2)++myStringGen :: Gen String+myStringGen = do+ n <- choose (1, 10)+ replicateM n $ elements $+ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9']++_propEncoding :: Property+_propEncoding = property $ \a ->+ parseJSON (show a) == Right a
+ src/Ideas/Text/JSON/Decoder.hs view
@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Text.JSON.Decoder+ ( GDecoderJSON, evalGDecoderJSON+ , DecoderJSON, evalDecoderJSON+ , Error, errorStr+ , jObject, jKey, jWithKeys, jObjectWithKeys+ , jArray, jArrayOf, jArray0, jArray1, jArray2, jArray3+ , jString, jChar, jBool, jInteger, jInt, jDouble, jFloat+ , jNull, jEmpty, jSkip+ , jNext+ -- re-exports+ , Alternative(..), MonadReader(..), throwError+ ) where++import Control.Monad+import Ideas.Text.JSON.Builder+import Ideas.Text.JSON.Data+import Ideas.Utils.Decoding++type GDecoderJSON env = Decoder env (Error JSON) JSONBuilder++evalGDecoderJSON :: GDecoderJSON env a -> env -> JSON -> Either (Error JSON) a+evalGDecoderJSON p env = evalDecoder p env . jsonToBuilder++type DecoderJSON = GDecoderJSON ()++evalDecoderJSON :: DecoderJSON a -> JSON -> Either (Error JSON) a+evalDecoderJSON p = evalGDecoderJSON p ()++jObject :: GDecoderJSON env a -> GDecoderJSON env a+jObject p = jFirst $ \a -> + case a of + Just (Object xs) -> put (mconcat $ map (uncurry tagJSON) xs) >> p+ _ -> raiseError "not an object" a++jKey :: Key -> GDecoderJSON env a -> GDecoderJSON env a+jKey k p = get2 >>= \(loc, xs) -> + case extractKey k xs of+ Just (v, rest) -> put2 (LocByKey 0 k loc, jsonToBuilder v) *> p <* put2 (loc, rest)+ _ -> raiseError ("key '" ++ k ++ "' not found") (Just (builderToJSON xs))++jWithKeys :: (Key -> GDecoderJSON env a) -> GDecoderJSON env [a]+jWithKeys f = get2 >>= \(loc, xs) ->+ mapM (\(k, v) -> put2 (LocByKey 0 k loc, jsonToBuilder v) >> f k) (extractKeyAndValues xs)++jObjectWithKeys :: (Key -> GDecoderJSON env a) -> GDecoderJSON env [a]+jObjectWithKeys = jObject . jWithKeys++jArray :: GDecoderJSON env a -> GDecoderJSON env a+jArray p = jFirst $ \a -> + case a of + Just (Array xs) -> changeLoc (LocByPos 0) >> put (mconcat $ map jsonToBuilder xs) >> p+ _ -> raiseError "not an array" a++jArrayOf :: GDecoderJSON env a -> GDecoderJSON env [a]+jArrayOf p = jArray $ many p <* jEmpty++jArray0 :: GDecoderJSON env ()+jArray0 = jArray jEmpty++jArray1 :: GDecoderJSON env a -> GDecoderJSON env a+jArray1 p = jArray $ p <* jEmpty++jArray2 :: (a -> b -> c) -> GDecoderJSON env a -> GDecoderJSON env b -> GDecoderJSON env c+jArray2 f p q = jArray $ f <$> p <*> q <* jEmpty++jArray3 :: (a -> b -> c -> d) -> GDecoderJSON env a -> GDecoderJSON env b -> GDecoderJSON env c -> GDecoderJSON env d+jArray3 f p q r = jArray $ f <$> p <*> q <*> r <* jEmpty++jString :: GDecoderJSON env String+jString = jFirst $ \a ->+ case a of+ Just (String s) -> return s+ _ -> raiseError "not a string" a++jChar :: GDecoderJSON env Char+jChar = jFirst $ \a ->+ case a of+ Just (String [c]) -> return c+ _ -> raiseError "not a char" a++jBool :: GDecoderJSON env Bool+jBool = jFirst $ \a ->+ case a of+ Just (Boolean b) -> return b+ _ -> raiseError "not a boolean" a++jInteger :: GDecoderJSON env Integer+jInteger = jFirst $ \a ->+ case a of+ Just (Integer i) -> return i+ _ -> raiseError "not an integer" a++jInt :: GDecoderJSON env Int+jInt = fromInteger <$> jInteger++jDouble :: GDecoderJSON env Double+jDouble = jFirst $ \a ->+ case a of+ Just (Double d) -> return d+ _ -> raiseError "not a double" a++jFloat :: GDecoderJSON env Float+jFloat = realToFrac <$> jDouble++jNull :: GDecoderJSON env ()+jNull = jFirst $ \a ->+ case a of+ Just Null -> return ()+ _ -> raiseError "not null" a++jEmpty :: GDecoderJSON env ()+jEmpty = get >>= \xs ->+ unless (isEmptyBuilder xs) (raiseError "not empty" (Just (builderToJSON xs)))++jSkip :: GDecoderJSON env ()+jSkip = jNext $ const $ return ()++jNext :: (JSON -> Either String a) -> GDecoderJSON env a+jNext f = jFirst $ \mjson -> + case fmap f mjson of+ Just res -> either errorStr return res+ Nothing -> raiseError "no next element" Nothing++-- local helper: not exported+jFirst :: (Maybe JSON -> GDecoderJSON env a) -> GDecoderJSON env a+jFirst f = get >>= \xs ->+ case extractFirst xs of+ Just (json, rest) -> f (Just json) <* changeLoc nextLoc <* put rest+ _ -> f Nothing++get2 :: GDecoderJSON env (Loc, JSONBuilder)+get2 = (,) <$> getLoc <*> get++put2 :: (Loc, JSONBuilder) -> GDecoderJSON env ()+put2 (loc, xs) = putLoc loc >> put xs
+ src/Ideas/Text/JSON/RPC.hs view
@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Text.JSON.RPC+ ( jsonRPC, RPCHandler, RPCRequest(..), RPCResponse(..)+ ) where++import Control.Exception+import Ideas.Text.JSON.Data+import Ideas.Text.JSON.Class+import Ideas.Text.JSON.Decoder+import System.IO.Error++--------------------------------------------------------+-- JSON-RPC++data RPCRequest = Request+ { requestMethod :: String+ , requestParams :: JSON+ , requestId :: JSON+ }++data RPCResponse = Response+ { responseResult :: JSON+ , responseError :: JSON+ , responseId :: JSON+ }++instance InJSON RPCRequest where+ toJSON req = Object+ [ ("method", String $ requestMethod req)+ , ("params", requestParams req)+ , ("id" , requestId req)+ ]+ jsonDecoder = jObject $+ Request <$> jKey "method" jString + <*> (jKey "params" (jNext Right) <|> pure Null)+ <*> (jKey "id" (jNext Right) <|> pure Null)++instance InJSON RPCResponse where+ toJSON resp = Object+ [ ("result", responseResult resp)+ , ("error" , responseError resp)+ , ("id" , responseId resp)+ ]+ jsonDecoder = jObject $ + Response <$> jKey "result" (jNext Right)+ <*> jKey "error" (jNext Right)+ <*> jKey "id" (jNext Right)++instance Show RPCRequest where+ show = show . toJSON++instance Show RPCResponse where+ show = show . toJSON++okResponse :: JSON -> JSON -> RPCResponse+okResponse x y = Response+ { responseResult = x+ , responseError = Null+ , responseId = y+ }++errorResponse :: JSON -> JSON -> RPCResponse+errorResponse x y = Response+ { responseResult = Null+ , responseError = x+ , responseId = y+ }++--------------------------------------------------------+-- JSON-RPC over HTTP++type RPCHandler = String -> JSON -> IO JSON++jsonRPC :: JSON -> RPCHandler -> IO RPCResponse+jsonRPC input rpc =+ case fromJSON input of+ Nothing -> return (errorResponse (String "Invalid request") Null)+ Just req -> do+ json <- rpc (requestMethod req) (requestParams req)+ return (okResponse json (requestId req))+ `catch` handler req+ where+ handler :: RPCRequest -> SomeException -> IO RPCResponse+ handler req e =+ let msg = maybe (show e) ioeGetErrorString (fromException e)+ in return $ errorResponse (toJSON msg) (requestId req)
src/Ideas/Text/MathML.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -14,9 +15,9 @@ ( MathML(..), xml2mathml, mathml2xml ) where -import Data.Maybe import Ideas.Text.XML import Ideas.Utils.Uniplate hiding (children) +import Ideas.Utils.Decoding data MathML = MRow [MathML] | MId String @@ -54,68 +55,52 @@ toXML = mathml2xml instance InXML MathML where - fromXML = either fail return . xml2mathml + xmlDecoder = rec + where + rec = xmlTag "mrow" (MRow <$> many rec) + <|> xmlTag "msqrt" (MSqrt <$> impliedRow) + <|> xmlTag "math" impliedRow + <|> xmlTag "mi" (MId <$> xmlString) + <|> xmlTag "mn" (MNumber <$> xmlString) + <|> xmlTag "mo" (MOperator <$> xmlString) + <|> xmlTag "ms" (MString <$> xmlString) + <|> xmlTag "mtext" (MText <$> xmlString) + <|> xmlTag "mroot" (MRoot <$> rec <*> rec) + <|> xmlTag "msup" (MSup <$> rec <*> rec) + <|> xmlTag "msub" (MSub <$> rec <*> rec) + <|> xmlTag "msubsup" (MSubSup <$> rec <*> rec <*> rec) + <|> xmlTag "mfrac" (MFrac <$> rec <*> rec) + <|> xmlTag "mfenced" (MFenced <$> xmlAttr "open" <*> xmlAttr "close" <*> rec) + <|> xmlTag "mspace" (return MSpace) + <|> xmlTag "mstyle" (return MStyle) + <|> xmlTag "mpadded" (return MPadded) + <|> xmlTag "mphantom" (return MPhantom) + <|> xmlTag "merror" (return MError) + <|> xmlTag "menclose" (return MEnclose) + <|> xmlTag "munder" (return MUnder) + <|> xmlTag "mover" (return MOver) + <|> xmlTag "munderover" (return MUnderOver) + <|> xmlTag "mtable" (return MTable) + <|> xmlTag "mtr" (return MTableRow) + <|> xmlTag "mlabeledtr" (return MLabeledTableRow) + <|> xmlTag "mtd" (return MTableData) + impliedRow = f <$> many rec + + f [x] = x + f xs = MRow xs + instance Uniplate MathML where uniplate math = case math of - MRow xs -> plate MRow ||* xs - _ -> plate math + MRow xs -> plate MRow ||* xs + _ -> plate math ---------------------------------------------------------- -- conversion functions: XML <-> MathML xml2mathml :: XML -> Either String MathML -xml2mathml = rec - where - rec xml = case name xml of - "mrow" -> MRow <$> mapM rec (children xml) - "mi" -> return (MId (getData xml)) - "mn" -> return (MNumber (getData xml)) - "mo" -> return (MOperator (getData xml)) - "ms" -> return (MString (getData xml)) - "mtext" -> return (MText (getData xml)) - "mroot" -> case children xml of - [c, d] -> MRoot <$> rec c <*> rec d - _ -> 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 - [c, d, e] -> MSubSup <$> rec c <*> rec d <*> rec e - _ -> fail "invalid msubsup" - "mfrac" -> case children xml of - [c, d] -> MFrac <$> rec c <*> rec d - _ -> fail "invalid mfrac" - "mfenced" -> case children xml of - [c] -> MFenced (fromMaybe "(" (findAttribute "open" xml)) (fromMaybe ")" (findAttribute "close" xml)) <$> rec c - _ -> fail "invalid mfenced" - "mspace" -> return MSpace - "mtable" -> return MTable - "mtr" -> return MTableRow - "mlabeledtr" -> return MLabeledTableRow - "munder" -> return MUnder - "mover" -> return MOver - "munderover" -> return MUnderOver - -- below are cases that have 1* arguments, when none-one an mrow is implied. - "math" -> impliedMRow xml - "msqrt" -> MSqrt <$> impliedMRow xml - "mphantom" -> return MPhantom - "mpadded" -> return MPadded - "mstyle" -> return MStyle - "merror" -> return MError - "mtd" -> return MTableData - "menclose" -> return MEnclose - _ -> fail ("unsupported MathML: " ++ show xml) - - impliedMRow :: XML -> Either String MathML - impliedMRow xml = - case children xml of - [x] -> rec x - xs -> MRow <$> mapM rec xs +xml2mathml = either (Left . show) (Right . fst) . runDecoder xmlDecoder () . builder mathml2xml :: MathML -> XML mathml2xml = makeXML "math" . rec
src/Ideas/Text/OpenMath/Object.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -19,7 +20,9 @@ import Data.List (nub) import Data.Maybe import Ideas.Text.OpenMath.Symbol +import Ideas.Text.XML.Decoder import Ideas.Text.XML +import Ideas.Utils.Decoding -- internal representation for OpenMath objects data OMOBJ = OMI Integer @@ -34,8 +37,20 @@ toXML = omobj2xml instance InXML OMOBJ where - fromXML = either fail return . xml2omobj + xmlDecoder = xmlTag "OMOBJ" rec + where + rec = xmlTag "OMA" (OMA <$> many rec) + <|> xmlTag "OMS" (makeOMS <$> optional (xmlAttr "cd") <*> xmlAttr "name") + <|> xmlTag "OMI" (OMI . fromJust . readInt <$> xmlString) + <|> xmlTag "OMF" (OMF . fromJust . readDouble <$> xmlAttr "dec") + <|> xmlTag "OMV" (OMV <$> xmlAttr "name") + <|> xmlTag "OMBIND" (OMBIND <$> rec <*> recOMBVar <*> rec) + recOMBVar = xmlTag "OMBVAR" (many (xmlTag "OMV" (xmlAttr "name"))) + + makeOMS (Just "unknown") a = OMS (Nothing, a) + makeOMS cd a = OMS (cd, a) + instance Uniplate OMOBJ where uniplate omobj = case omobj of @@ -50,58 +65,14 @@ -- conversion functions: XML <-> OMOBJ xml2omobj :: XML -> Either String OMOBJ -xml2omobj xmlTop - | name xmlTop == "OMOBJ" = - case children xmlTop of - [x] -> rec x - _ -> fail "invalid omobj" - | otherwise = fail "expected an OMOBJ tag" - where - rec xml = - case name xml of - "OMA" -> do - ys <- mapM rec (children xml) - return (OMA ys) - - "OMS" | emptyContent xml -> do - let mcd = case findAttribute "cd" xml of - Just "unknown" -> Nothing - this -> this - n <- findAttribute "name" xml - return (OMS (mcd, n)) - - "OMI" | name xml == "OMI" -> - case readInt (getData xml) of - Just i -> return (OMI (toInteger i)) - _ -> fail "invalid integer in OMI" - - "OMF" | emptyContent xml -> do - s <- findAttribute "dec" xml - case readDouble s of - Just nr -> return (OMF nr) - _ -> fail "invalid floating-point in OMF" - - "OMV" | emptyContent xml -> do - s <- findAttribute "name" xml - return (OMV s) - - "OMBIND" -> - case children xml of - [x1, x2, x3] -> do - y1 <- rec x1 - y2 <- recOMBVAR x2 - y3 <- rec x3 - return (OMBIND y1 y2 y3) - _ -> fail "invalid ombind" - _ -> fail ("invalid tag " ++ name xml) +xml2omobj = either (Left . show) (Right . fst) . runDecoder xmlDecoder () . builder . removeLayout - recOMBVAR xml - | name xml == "OMBVAR" = - let f (Right (OMV s)) = return s - f this = fail $ "expected tag OMV in OMBVAR, but found " ++ show this - in mapM (f . rec) (children xml) - | otherwise = - fail ("expected tag OMVAR, but found " ++ show (name xml)) +removeLayout :: XML -> XML +removeLayout = foldXML (\n as cs -> makeXML n (as <> cs)) (.=.) keepText builder + where + keepText s + | all isSpace s = mempty + | otherwise = string s omobj2xml :: OMOBJ -> XML omobj2xml object = makeXML "OMOBJ" $ mconcat
src/Ideas/Text/OpenMath/Tests.hs view
@@ -24,6 +24,7 @@ import Ideas.Text.OpenMath.Dictionary.Relation1 import Ideas.Text.OpenMath.Dictionary.Transc1 import Ideas.Text.OpenMath.Object +import Ideas.Text.XML import Test.QuickCheck arbOMOBJ :: Gen OMOBJ @@ -48,4 +49,10 @@ f = rec (n `div` 2) propEncoding :: Property -propEncoding = forAll arbOMOBJ $ \x -> xml2omobj (omobj2xml x) == Right x+propEncoding = forAll arbOMOBJ $ \x -> + let expected = Right x + parsed = parseXML (prettyXML (omobj2xml x)) >>= xml2omobj + in conjoin + [ xml2omobj (omobj2xml x) === expected + , parsed === expected + ]
src/Ideas/Text/UTF8.hs view
@@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- module Ideas.Text.UTF8 - ( encode, encodeM, decode, decodeM + ( encode, decode , isUTF8, allBytes, propEncoding ) where @@ -26,24 +26,16 @@ -- Interface -- | Encode a string to UTF8 format -encode :: String -> String -encode = either error id . encodeM +encode :: String -> Maybe String +encode = fmap (map chr . concat) . mapM (toUTF8 . ord) -- | Decode an UTF8 format string to unicode points -decode :: String -> String -decode = either error id . decodeM - --- | Encode a string to UTF8 format (monadic) -encodeM :: Monad m => String -> m String -encodeM = fmap (map chr . concat) . mapM (toUTF8 . ord) - --- | Decode an UTF8 format string to unicode points (monadic) -decodeM :: Monad m => String -> m String -decodeM = fmap (map chr) . fromUTF8 . map ord +decode :: String -> Maybe String +decode = fmap (map chr) . fromUTF8 . map ord -- | Test whether the argument is a proper UTF8 string isUTF8 :: String -> Bool -isUTF8 = isJust . decodeM +isUTF8 = isJust . decode -- | Test whether all characters are in the range 0-255 allBytes :: String -> Bool @@ -52,26 +44,26 @@ ------------------------------------------------------------------ -- Helper functions -toUTF8 :: Monad m => Int -> m [Int] +toUTF8 :: Int -> Maybe [Int] toUTF8 n | n < 128 = -- one byte - return [n] + Just [n] | n < 2048 = -- two bytes let (a, d) = n `divMod` 64 - in return [a+192, d+128] + in Just [a+192, d+128] | n < 65536 = -- three bytes let (a, d1) = n `divMod` 4096 (b, d2) = d1 `divMod` 64 - in return [a+224, b+128, d2+128] + in Just [a+224, b+128, d2+128] | n < 1114112 = -- four bytes let (a, d1) = n `divMod` 262144 (b, d2) = d1 `divMod` 4096 (c, d3) = d2 `divMod` 64 - in return [a+240, b+128, c+128, d3+128] + in Just [a+240, b+128, c+128, d3+128] | otherwise = - fail "invalid character in UTF8" + Nothing -fromUTF8 :: Monad m => [Int] -> m [Int] +fromUTF8 :: [Int] -> Maybe [Int] fromUTF8 xs | null xs = return [] | otherwise = do @@ -80,22 +72,21 @@ return (i:is) where f (a:rest) | a < 128 = -- one byte - return (a, rest) - f (a:b:rest) | a `between` (192, 223) = do -- two bytes - unless (isHigh b) $ - fail "invalid UTF8 character (two bytes)" - return ((a-192)*64 + b-128, rest) - f (a:b:c:rest) | a `between` (224, 239) = do -- three bytes - unless (isHigh b && isHigh c) $ - fail "invalid UTF8 character (three bytes)" - return ((a-224)*4096 + (b-128)*64 + c-128, rest) - f (a:b:c:d:rest) | a >= 240 && a < 248 = do -- four bytes + Just (a, rest) + f (a:b:rest) | a `between` (192, 223) = -- two bytes + checked (isHigh b) + ((a-192)*64 + b-128, rest) + f (a:b:c:rest) | a `between` (224, 239) = -- three bytes + checked (isHigh b && isHigh c) + ((a-224)*4096 + (b-128)*64 + c-128, rest) + f (a:b:c:d:rest) | a >= 240 && a < 248 = -- four bytes let value = (a-240)*262144 + (b-128)*4096 + (c-128)*64 + d-128 - unless (isHigh b && isHigh c && isHigh d && value <= 1114111) $ - fail "invalid UTF8 character (four bytes)" - return (value, rest) - f _ = fail "invalid character in UTF8" + in checked (isHigh b && isHigh c && isHigh d && value <= 1114111) (value, rest) + f _ = Nothing +checked :: Bool -> a -> Maybe a +checked b a = if b then Just a else Nothing + isHigh :: Int -> Bool isHigh i = i `between` (128, 191) @@ -119,6 +110,6 @@ valid :: String -> Bool valid xs = fromMaybe False $ - do us <- encodeM xs - bs <- decodeM us + do us <- encode xs + bs <- decode us return (xs == bs)
src/Ideas/Text/XML.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -13,71 +14,45 @@ ----------------------------------------------------------------------------- module Ideas.Text.XML - ( -- * XML types - XML, Name, Attributes, Attribute(..) + ( Name, toName, uncheckedName + , module Ideas.Text.XML.Attributes + , module Ideas.Text.XML.Data + , module Ideas.Text.XML.Builder + , module Ideas.Text.XML.Decoder -- * Parsing XML , parseXML, parseXMLFile - -- * Building/constructing XML - , BuildXML(..), XMLBuilder, makeXML - -- * Pretty-printing XML - , prettyXML, compactXML -- * Simple decoding queries - , name, attributes, findAttribute, children, findChildren, findChild - , getData, expecting + , findAttribute, children, findChildren, findChild + , getData -- * Decoding XML , decodeData, decodeAttribute, decodeChild, decodeFirstChild -- * Type classes for converting to/from XML , ToXML(..), builderXML, InXML(..) - -- * Processing XML - , foldXML, trimXML -- * Deprecated functions - , content, emptyContent, fromBuilder + , fromBuilder ) where +import Control.Monad (forM_, (>=>)) import Control.Monad.State -import Data.Char (chr, ord, isSpace) -import Data.Foldable (toList) -import Data.List +import Data.Char (chr) import Data.Maybe -import Data.Semigroup as Sem import Data.String -import Ideas.Text.XML.Document (escape, Name, prettyElement) +import Ideas.Text.XML.Attributes +import Ideas.Text.XML.Builder +import Ideas.Text.XML.Decoder +import Ideas.Text.XML.Data import Ideas.Text.XML.Parser (document) -import Ideas.Text.XML.Unicode 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 - -------------------------------------------------------------------------------- --- XML types - --- invariants content: no two adjacent Lefts, no Left with empty string, --- valid tag/attribute names -data XML = Tag - { name :: Name - , attributes :: Attributes - , content :: [Either String XML] - } - deriving Eq - -instance Show XML where - show = compactXML - -type Attributes = [Attribute] - -data Attribute = Name := String - deriving Eq +import Ideas.Text.XML.Document (Name, toName, uncheckedName) ------------------------------------------------------------------------------- -- Parsing XML parseXML :: String -> Either String XML -parseXML input = do - doc <- parseSimple document input - return (fromXMLDoc doc) +parseXML input = fromXMLDoc <$> parseSimple document input parseXMLFile :: FilePath -> IO XML parseXMLFile file = @@ -106,186 +81,112 @@ refToString :: D.Reference -> String refToString (D.CharRef i) = [chr i] - refToString (D.EntityRef s) = maybe "" return (lookup s general) + refToString (D.EntityRef n) = maybe "" return (lookup n general) fromReference :: D.Reference -> XMLBuilder fromReference (D.CharRef i) = char (chr i) - fromReference (D.EntityRef s) = fromMaybe mempty (lookup s entities) + fromReference (D.EntityRef n) = fromMaybe mempty (lookup n entities) - entities :: [(String, XMLBuilder)] + entities :: [(Name, XMLBuilder)] entities = [ (n, fromContent (snd ext)) | (n, ext) <- D.externals doc ] ++ -- predefined entities [ (n, char c) | (n, c) <- general ] - general :: [(String, Char)] + general :: [(Name, Char)] general = [("lt",'<'), ("gt",'>'), ("amp",'&'), ("apos",'\''), ("quot",'"')] ------------------------------------------------------------------------------- --- Building/constructing XML - -infix 7 .=. - -class (Sem.Semigroup a, Monoid a) => BuildXML a where - (.=.) :: String -> String -> a -- attribute - string :: String -> a -- (escaped) text - builder :: XML -> a -- (named) xml element - tag :: String -> a -> a -- tag (with content) - -- functions with a default - char :: Char -> a - text :: Show s => s -> a -- escaped text with Show class - element :: String -> [a] -> a - emptyTag :: String -> a - -- implementations - char c = string [c] - text = string . show - element s = tag s . mconcat - emptyTag s = tag s mempty - -instance BuildXML a => BuildXML (Decoder env s a) where - n .=. s = pure (n .=. s) - string = pure . string - builder = pure . builder - tag = fmap . tag - -data XMLBuilder = BS (Seq.Seq Attribute) (Seq.Seq (Either String XML)) - -instance Sem.Semigroup XMLBuilder where - BS as1 elts1 <> BS as2 elts2 = BS (as1 <> as2) (elts1 <> elts2) - -instance Monoid XMLBuilder where - mempty = BS mempty mempty - mappend = (<>) - -instance BuildXML XMLBuilder where - n .=. s = nameCheck n $ BS (Seq.singleton (n := s)) mempty - string s = BS mempty (if null s then mempty else Seq.singleton (Left s)) - builder = BS mempty . Seq.singleton . Right - tag n = builder . uncurry (Tag n) . fromBS . nameCheck n - -instance IsString XMLBuilder where - fromString = string - -makeXML :: String -> XMLBuilder -> XML -makeXML s = uncurry (Tag s) . fromBS . nameCheck s - -nameCheck :: String -> a -> a -nameCheck s = if isName s then id else fail $ "Invalid name " ++ s - -isName :: String -> Bool -isName [] = False -isName (x:xs) = (isLetter x || x `elem` "_:") && all isNameChar xs - -isNameChar :: Char -> Bool -isNameChar c = any ($ c) [isLetter, isDigit, isCombiningChar, isExtender, (`elem` ".-_:")] - --- local helper: merge attributes, but preserve order -fromBS :: XMLBuilder -> (Attributes, [Either String XML]) -fromBS (BS as elts) = (attrList, merge (toList elts)) - where - attrMap = foldr add M.empty as - add (k := v) = M.insertWith (\x y -> x ++ " " ++ y) k v - attrList = nubBy eqKey (map make (toList as)) - make (k := _) = k := M.findWithDefault "" k attrMap - eqKey (k1 := _) (k2 := _) = k1 == k2 - - merge [] = [] - merge (Left x:Left y:rest) = merge (Left (x++y):rest) - merge (Left x:rest) = Left x : merge rest - merge (Right y:rest) = Right y : merge rest - -------------------------------------------------------------------------------- --- Pretty-printing XML - -prettyXML :: XML -> String -prettyXML = show . prettyElement False . toElement - -compactXML :: XML -> String -compactXML = show . prettyElement True . toElement - -toElement :: XML -> D.Element -toElement = foldXML make mkAttribute mkString - where - make n as = D.Element n as . concatMap (either id (return . D.Tagged)) - - mkAttribute :: Attribute -> D.Attribute - mkAttribute (m := s) = (D.:=) m (map Left s) - - mkString :: String -> [D.XML] - mkString [] = [] - mkString xs@(hd:tl) - | null xs1 = D.Reference (D.CharRef (ord hd)) : mkString tl - | otherwise = D.CharData xs1 : mkString xs2 - where - (xs1, xs2) = break ((> 127) . ord) xs - -------------------------------------------------------------------------------- -- Simple decoding queries -findAttribute :: Monad m => String -> XML -> m String -findAttribute s (Tag _ as _) = - case [ t | n := t <- as, s==n ] of - [hd] -> return hd - _ -> fail $ "Invalid attribute: " ++ show s +findAttribute :: String -> XML -> Either String String +findAttribute s xml = + case lookupAttribute (toName s) (getAttributes xml) of + Just hd -> Right hd + _ -> Left $ "Invalid attribute: " ++ show s -children :: XML -> [XML] -children e = [ c | Right c <- content e ] +children :: HasContent a => a -> [XML] +children = rec . getContent + where + rec a = + case headIsString a of + Just (_, rest) -> rec rest + Nothing -> + case headIsXML a of + Just (xml, rest) -> xml : rec rest + Nothing -> [] findChildren :: String -> XML -> [XML] -findChildren s = filter ((==s) . name) . children +findChildren s = filter ((==s) . show . getName) . children -findChild :: Monad m => String -> XML -> m XML +findChild :: String -> XML -> Either String XML findChild s e = case findChildren s e of - [] -> fail $ "Child not found: " ++ show s - [a] -> return a - _ -> fail $ "Multiple children found: " ++ show s - -getData :: XML -> String -getData e = concat [ s | Left s <- content e ] + [] -> Left $ "Child not found: " ++ show s + [a] -> Right a + _ -> Left $ "Multiple children found: " ++ show s -expecting :: Monad m => String -> XML -> m () -expecting s xml = - unless (name xml == s) $ fail $ "Expecting element " ++ s ++ ", but found " ++ name xml +getData :: HasContent a => a -> String +getData = rec . getContent + where + rec a = + case headIsString a of + Just (s, rest) -> s ++ rec rest + Nothing -> + case headIsXML a of + Just (_, rest) -> rec rest + Nothing -> [] ------------------------------------------------------------------------------- -- Decoding XML -decodeData :: Decoder env XML String +decodeData :: Decoder env String XML String decodeData = get >>= \xml -> - case content xml of - Left s:rest -> put xml {content = rest} >> return s - _ -> fail "Could not find data" + case headIsString xml of + Just (s, rest) -> put rest >> return s + _ -> throwError "Could not find data" -decodeAttribute :: String -> Decoder env XML String +decodeAttribute :: String -> Decoder env String XML String decodeAttribute s = get >>= \xml -> - case break hasName (attributes xml) of - (xs, (_ := val):ys) -> put xml {attributes = xs ++ ys } >> return val - _ -> fail $ "Could not find attribute " ++ s - where - hasName (n := _) = n == s + case lookupAttribute (toName s) (getAttributes xml) of + Just val -> return val + _ -> throwError $ "Could not find attribute " ++ s -decodeChild :: Name -> Decoder env XML a -> Decoder env XML a +decodeChild :: String -> Decoder env String XML a -> Decoder env String XML a decodeChild s p = get >>= \xml -> - case break hasName (content xml) of - (xs, Right y:ys) -> do + case extractChild (toName s) (getContent xml) of + Just (y, rest) -> do put y a <- p - put xml { content = xs ++ ys } + put (setContent rest xml) return a - _ -> fail $ "Could not find child " ++ s + _ -> throwError $ "Could not find child " ++ s + +-- local helper +extractChild :: Name -> Content -> Maybe (XML, Content) +extractChild n = rec where - hasName = either (const False) ((==s) . name) + rec a = + case headIsXML a of + Just (xml, rest) + | n == getName xml -> Just (xml, rest) + | otherwise -> add (xmlToContent xml) (rec rest) + Nothing -> + case headIsString a of + Just (s, rest) -> add (fromString s) (rec rest) + Nothing -> Nothing -decodeFirstChild :: Name -> Decoder env XML a -> Decoder env XML a + add a = fmap (fmap (a <>)) + +decodeFirstChild :: String -> Decoder env String XML a -> Decoder env String XML a decodeFirstChild s p = get >>= \xml -> - case content xml of - Right y:ys | name y == s -> do + case headIsXML xml of + Just (y, rest) | show (getName y) == s -> do put y a <- p - put xml { content = ys } + put rest return a - _ -> fail $ "Could not find first child " ++ s + _ -> throwError $ "Could not find first child " ++ s ------------------------------------------------------------------------------- -- Type classes for converting to/from XML @@ -294,57 +195,45 @@ toXML :: a -> XML listToXML :: [a] -> XML -- default definitions - listToXML = makeXML "list" . mconcat . map builderXML + listToXML = makeXML (toName "list") . mconcat . map builderXML instance ToXML () where - toXML _ = makeXML "Unit" mempty + toXML _ = makeXML (toName "Unit") mempty instance ToXML a => ToXML (Maybe a) where - toXML = maybe (makeXML "Nothing" mempty) toXML + toXML = maybe (makeXML (toName "Nothing") mempty) toXML 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] - listFromXML xml - | name xml == "list" && null (attributes xml) = - mapM fromXML (children xml) - | otherwise = fail "expecting a list tag" - -------------------------------------------------------------------------------- --- Processing XML - -foldXML :: (Name -> [a] -> [Either s e] -> e) -> (Attribute -> a) -> (String -> s) -> XML -> e -foldXML fe fa fs = rec - where - rec (Tag n as cs) = fe n (map fa as) (map (either (Left . fs) (Right . rec)) cs) - -trimXML :: XML -> XML -trimXML = foldXML make fa (string . trim) - where - fa (n := s) = n .=. trim s + fromXML :: XML -> Maybe a + --listFromXML :: XML -> Maybe [a] -- to be removed + xmlDecoder :: DecoderXML a - make :: String -> [XMLBuilder] -> [Either XMLBuilder XML] -> XML - make s as = makeXML s . mconcat . (as ++) . map (either id builder) + {-# MINIMAL fromXML | xmlDecoder #-} -trim, trimLeft, trimRight :: String -> String -trim = trimLeft . trimRight -trimLeft = dropWhile isSpace -trimRight = reverse . trimLeft . reverse + -- default definitions + -- listFromXML xml + -- | name xml == "list" && null (attributes xml) = + -- mapM fromXML (children xml) + -- | otherwise = fail "expecting a list tag" + fromXML xml = either (const Nothing) Just $ evalDecoder xmlDecoder () (builder (trimXML xml)) + xmlDecoder = do + b <- get + case fromBuilder b of + Just xml -> maybe (errorStr "xml-decoder") return (fromXML xml) + _ -> errorStr "xml-decoder" ------------------------------------------------------------------------------- -- Deprecated functions -emptyContent :: XML -> Bool -emptyContent = null . content - fromBuilder :: XMLBuilder -> Maybe XML fromBuilder m = - case fromBS m of - ([], [Right a]) -> Just a - _ -> Nothing + case headIsXML m of + Just (a, rest) | noAttributes (getAttributes m) && contentIsEmpty rest + -> Just a + _ -> Nothing ------------------------------------------------------------------------------- -- Tests @@ -371,9 +260,9 @@ testDataP, testAttrP, testDataB, testAttrB :: String -> Bool testDataP s = let xml = mkPD s in getData xml == s - testAttrP s = let xml = mkPA s in findAttribute "a" xml == Just s + testAttrP s = let xml = mkPA s in findAttribute "a" xml == Right s testDataB s = let xml = mkBD s in getData xml == s - testAttrB s = let xml = mkBA s in findAttribute "a" xml == Just s + testAttrB s = let xml = mkBA s in findAttribute "a" xml == Right s testXML :: XML -> Bool testXML xml = @@ -382,7 +271,7 @@ Right a -> a == xml mkPD, mkPA, mkBD, mkBA :: String -> XML - mkPD s = either error id $ parseXML $ "<a>" ++ escape s ++ "</a>" - mkPA s = either error id $ parseXML $ "<t a='" ++ escape s ++ "'/>" + mkPD s = either error id $ parseXML $ "<a>" ++ D.escape s ++ "</a>" + mkPA s = either error id $ parseXML $ "<t a='" ++ D.escape s ++ "'/>" mkBD s = makeXML "a" (string s) - mkBA s = makeXML "t" ("a".=. s)+ mkBA s = makeXML "t" ("a".=. s)
+ src/Ideas/Text/XML/Attributes.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Text.XML.Attributes + ( Attributes, HasAttributes(..)+ , attribute+ , noAttributes, lookupAttribute+ , foldAttributes+ ) where++import Ideas.Text.XML.Document (Name)+import qualified Data.Map as M++newtype Attributes = A { attributeMap :: M.Map Name String }+ deriving Eq++data Attribute = Name := String+ deriving Eq++instance Semigroup Attributes where+ A xs <> A ys = A $ M.unionWith (\x y -> x ++ " " ++ y) xs ys++instance Monoid Attributes where+ mempty = A M.empty++class HasAttributes a where+ getAttributes :: a -> Attributes+ setAttributes :: Attributes -> a -> a+ changeAttributes :: (Attributes -> Attributes) -> a -> a+ updateAttributes :: a -> (Attributes, Attributes -> a)+ + {-# MINIMAL (getAttributes, changeAttributes) | updateAttributes #-}++ -- default definitions+ getAttributes = fst . updateAttributes+ setAttributes = changeAttributes . const+ changeAttributes f = (\(c, g) -> g (f c)) . updateAttributes+ updateAttributes a = (getAttributes a, (`setAttributes` a))++instance HasAttributes Attributes where+ updateAttributes a = (a, id)++attribute :: Name -> String -> Attributes+attribute n s = A $ M.singleton n s++lookupAttribute :: HasAttributes a => Name -> a -> Maybe String+lookupAttribute n = M.lookup n . attributeMap . getAttributes++noAttributes :: HasAttributes a => a -> Bool+noAttributes = null . attributeMap . getAttributes++foldAttributes :: Monoid a => (Name -> String -> a) -> Attributes -> a+foldAttributes fa = M.foldrWithKey f mempty . attributeMap+ where+ f n s = (fa n s <>)
+ src/Ideas/Text/XML/Builder.hs view
@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Text.XML.Builder + ( BuildXML(..)+ , XMLBuilder, makeXML, makeXMLBuilder+ ) where++import Data.String+import Ideas.Text.XML.Data+import Ideas.Text.XML.Document (Name)+import Ideas.Text.XML.Attributes+import Ideas.Utils.Decoding++infix 7 .=.++class (Semigroup a, Monoid a) => BuildXML a where+ (.=.) :: Name -> String -> a -- attribute+ string :: String -> a -- (escaped) text+ builder :: XML -> a -- (named) xml element+ tag :: Name -> a -> a -- tag (with content)+ -- functions with a default+ char :: Char -> a+ text :: Show s => s -> a -- escaped text with Show class+ element :: Name -> [a] -> a+ emptyTag :: Name -> a+ -- implementations+ char c = string [c]+ text = string . show+ element s = tag s . mconcat+ emptyTag s = tag s mempty++instance BuildXML a => BuildXML (Decoder env err s a) where+ n .=. s = pure (n .=. s)+ string = pure . string+ builder = pure . builder+ tag = fmap . tag++-------------------------------------------------------------------++data XMLBuilder = B Attributes Content++instance Semigroup XMLBuilder where+ B as1 elts1 <> B as2 elts2 = B (as1 <> as2) (elts1 <> elts2)++instance Monoid XMLBuilder where+ mempty = B mempty mempty+ mappend = (<>)++instance BuildXML XMLBuilder where+ n .=. s = B (attribute n s) mempty+ string s = B mempty (if null s then mempty else fromString s)+ builder = B mempty . xmlToContent+ tag n = builder . makeXML n++instance IsString XMLBuilder where+ fromString = string++instance HasContent XMLBuilder where+ updateContent (B as c) = (c, B as)++instance HasAttributes XMLBuilder where+ updateAttributes (B as c) = (as, \bs -> B bs c)++makeXMLBuilder :: Attributes -> Content -> XMLBuilder+makeXMLBuilder = B++makeXML :: Name -> XMLBuilder -> XML+makeXML n (B as c) = xmlRoot n as c
+ src/Ideas/Text/XML/Data.hs view
@@ -0,0 +1,163 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Text.XML.Data + ( -- types+ XML, xmlRoot, getName+ , Content, xmlToContent+ , HasContent(..), contentIsEmpty, headIsString, headIsXML+ -- pretty-printing+ , prettyXML, compactXML+ -- processing+ , foldXML, trimXML+ ) where++import Data.Char (isSpace, ord)+import Data.String+import Ideas.Text.XML.Attributes+import Ideas.Text.XML.Document (Name)+import qualified Ideas.Text.XML.Document as D++-------------------------------------------------------------------------------+-- XML types++data XML = Root Name Attributes Content+ deriving Eq++instance Show XML where+ show = compactXML++data Content = Empty+ | CData String+ | Cons XML Content + | Mixed String XML Content+ deriving Eq++instance Show Content where+ showsPrec _ = rec+ where+ rec Empty = id+ rec (CData s) = (s ++)+ rec (Cons x c) = (show x ++) . rec c + rec (Mixed s x c) = (s ++) . (show x ++) . rec c ++instance Semigroup Content where+ Empty <> rest = rest+ CData s <> Empty = CData s+ CData s <> CData t = CData (s ++ t)+ CData s <> Cons x c = Mixed s x c+ CData s <> Mixed t x c = Mixed (s ++ t) x c + Cons x c <> rest = Cons x (c <> rest)+ Mixed s x c <> rest = Mixed s x (c <> rest) ++instance Monoid Content where+ mempty = Empty++instance IsString Content where+ fromString s = if null s then Empty else CData s++class HasContent a where+ getContent :: a -> Content+ setContent :: Content -> a -> a+ changeContent :: (Content -> Content) -> a -> a+ updateContent :: a -> (Content, Content -> a)+ + {-# MINIMAL (getContent, changeContent) | updateContent #-}++ -- default definitions+ getContent = fst . updateContent+ setContent = changeContent . const+ changeContent f = (\(c, g) -> g (f c)) . updateContent+ updateContent a = (getContent a, (`setContent` a))++instance HasContent Content where+ updateContent a = (a, id)++instance HasContent XML where+ updateContent (Root n as c) = (c, xmlRoot n as)++instance HasAttributes XML where+ updateAttributes (Root n as c) = (as, \bs -> xmlRoot n bs c)++xmlRoot :: Name -> Attributes -> Content -> XML+xmlRoot = Root++getName :: XML -> Name+getName (Root n _ _) = n++contentIsEmpty :: HasContent a => a -> Bool+contentIsEmpty a =+ case getContent a of+ Empty -> True+ _ -> False++headIsString :: HasContent a => a -> Maybe (String, a)+headIsString a =+ case updateContent a of+ (CData s, f) -> Just (s, f Empty)+ (Mixed s x c, f) -> Just (s, f (Cons x c))+ _ -> Nothing++headIsXML :: HasContent a => a -> Maybe (XML, a)+headIsXML a =+ case updateContent a of+ (Cons x c, f) -> Just (x, f c)+ _ -> Nothing++xmlToContent :: XML -> Content+xmlToContent = (`Cons` Empty)++-------------------------------------------------------------------------------+-- Pretty-printing XML++prettyXML :: XML -> String+prettyXML = show . D.prettyElement False . toElement++compactXML :: XML -> String+compactXML = show . D.prettyElement True . toElement++toElement :: XML -> D.Element+toElement = foldXML D.Element mkAttribute mkString (return . D.Tagged)+ where+ mkAttribute :: Name -> String -> D.Attributes+ mkAttribute m s = [(D.:=) m (map Left s)]++ mkString :: String -> [D.XML]+ mkString [] = []+ mkString xs@(hd:tl)+ | null xs1 = D.Reference (D.CharRef (ord hd)) : mkString tl+ | otherwise = D.CharData xs1 : mkString xs2+ where+ (xs1, xs2) = break ((> 127) . ord) xs++-------------------------------------------------------------------------------+-- Processing XML++foldXML :: (Monoid a, Monoid c) => (Name -> a -> c -> e) -> (Name -> String -> a) -> (String -> c) -> (e -> c) -> XML -> e+foldXML f fa fs fc = rec+ where+ rec (Root n as cs) = f n (foldAttributes fa as) (recContent cs)++ recContent Empty = mempty+ recContent (CData s) = fs s+ recContent (Cons x c) = fc (rec x) <> recContent c+ recContent (Mixed s x c) = fs s <> fc (rec x) <> recContent c++trimXML :: XML -> XML+trimXML = foldXML xmlRoot f (fromString . trim) xmlToContent+ where+ f n = attribute n . trim++trim, trimLeft, trimRight :: String -> String+trim = trimLeft . trimRight+trimLeft = dropWhile isSpace+trimRight = reverse . trimLeft . reverse
+ src/Ideas/Text/XML/Decoder.hs view
@@ -0,0 +1,58 @@+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Text.XML.Decoder+ ( DecoderXML, evalDecoderXML+ , xmlTag, xmlString, xmlAttr, xmlEnd+ ) where++import Data.String+import Ideas.Utils.Decoding+import Ideas.Text.XML.Attributes+import Ideas.Text.XML.Data+import Ideas.Text.XML.Builder+import Ideas.Text.XML.Document (Name)++type DecoderXML = Decoder () (Error XML) XMLBuilder++evalDecoderXML :: DecoderXML a -> XML -> Either (Error XML) a+evalDecoderXML p = evalDecoder p () . builder++xmlTag :: Name -> DecoderXML a -> DecoderXML a+xmlTag n p = get >>= \xml -> + case headIsXML xml of + Just (hd, rest) | getName hd == n -> do+ put (makeXMLBuilder (getAttributes hd) (getContent hd))+ a <- p+ xmlEnd+ put rest+ return a+ _ -> errorStr "xTag"++xmlString :: DecoderXML String+xmlString = do+ xml <- get+ case headIsString xml of + Just (s, rest) -> put rest >> return s+ Nothing -> errorStr "xString"++xmlAttr :: String -> DecoderXML String+xmlAttr s = get >>= \xml -> + case lookupAttribute (fromString s) (getAttributes xml) of+ Just v -> return v+ _ -> errorStr "xAttr"++xmlEnd :: DecoderXML ()+xmlEnd = get >>= \xml -> + if contentIsEmpty xml + then return () + else errorStr "xEnd"
src/Ideas/Text/XML/Document.hs view
@@ -13,7 +13,8 @@ ----------------------------------------------------------------------------- module Ideas.Text.XML.Document - ( Name, Attributes, Attribute(..), Reference(..), Parameter(..) + ( Name, toName, uncheckedName + , Attributes, Attribute(..), Reference(..), Parameter(..) , XMLDoc(..), XML(..), Element(..), Content, DTD(..), DocTypeDecl(..) , ContentSpec(..), CP(..), AttType(..), DefaultDecl(..), AttDef , EntityDef, AttValue, EntityValue, ExternalID(..), PublicID @@ -21,25 +22,54 @@ , prettyXML, prettyElement, escape ) where +import Data.String import Prelude hiding ((<$>)) - +import Ideas.Text.XML.Unicode import Text.PrettyPrint.Leijen -type Name = String +------------------------------------------------------------------ +-- (checked) names +newtype Name = N String + deriving (Eq, Ord) + +instance Show Name where + show (N s) = s + +instance IsString Name where + fromString = toName + +toName :: String -> Name +toName s + | validName s = N s + | otherwise = error $ "Invalid XML name: " ++ s + +uncheckedName :: String -> Name +uncheckedName = N + +validName :: String -> Bool +validName [] = False +validName (x:xs) = (isLetter x || x `elem` "_:") && all validNameChar xs + +validNameChar :: Char -> Bool +validNameChar c = any ($ c) [isLetter, isDigit, isCombiningChar, isExtender, (`elem` ".-_:")] + +------------------------------------------------------------------ +-- (checked) names + type Attributes = [Attribute] data Attribute = Name := AttValue -data Reference = CharRef Int | EntityRef String +data Reference = CharRef Int | EntityRef Name -newtype Parameter = Parameter String +newtype Parameter = Parameter Name data XMLDoc = XMLDoc { versionInfo :: Maybe String , encoding :: Maybe String , standalone :: Maybe Bool , dtd :: Maybe DTD - , externals :: [(String, External)] + , externals :: [(Name, External)] , root :: Element } @@ -71,12 +101,12 @@ data CP = Choice [CP] | Sequence [CP] | QuestionMark CP | Star CP | Plus CP | CPName Name data AttType = IdType | IdRefType | IdRefsType | EntityType | EntitiesType | NmTokenType | NmTokensType - | StringType | EnumerationType [String] | NotationType [String] + | StringType | EnumerationType [String] | NotationType [Name] data DefaultDecl = Required | Implied | Value AttValue | Fixed AttValue type AttDef = (Name, AttType, DefaultDecl) -type EntityDef = Either EntityValue (ExternalID, Maybe String) +type EntityDef = Either EntityValue (ExternalID, Maybe Name) type AttValue = [Either Char Reference] type EntityValue = [Either Char (Either Parameter Reference)] @@ -102,17 +132,20 @@ ------------------------------------------------------------------ -- Pretty printing -instance Pretty Attribute where - pretty (n := v) = text n <> char '=' <> prettyAttValue v +instance Pretty Name where + pretty = text . show +instance Pretty Attribute where + pretty (n := v) = pretty n <> char '=' <> prettyAttValue v + instance Pretty Reference where pretty ref = case ref of CharRef n -> text "&#" <> int n <> char ';' - EntityRef s -> char '&' <> text s <> char ';' + EntityRef s -> char '&' <> pretty s <> char ';' instance Pretty Parameter where - pretty (Parameter s) = text "%" <> text s <> text ";" + pretty (Parameter s) = text "%" <> pretty s <> text ";" instance Pretty XML where pretty = prettyXML False @@ -129,7 +162,7 @@ Reference r -> pretty r prettyElement :: Bool -> Element -> Doc -prettyElement _ (Element n@"script" as [CharData s]) = +prettyElement _ (Element n as [CharData s]) | show n == "script" = -- quick fix for not escaping javascript code in html openTag n as <> text s <> closeTag n prettyElement compact (Element n as c) @@ -151,7 +184,7 @@ closeTag n = prettyTag (text "</") (char '>') n [] prettyTag :: Doc -> Doc -> Name -> Attributes -> Doc -prettyTag open close n as = open <> hsep (text n:map pretty as) <> close +prettyTag open close n as = open <> hsep (pretty n:map pretty as) <> close prettyAttValue :: AttValue -> Doc prettyAttValue = dquotes . hcat . map (either (text . escapeChar) pretty)
src/Ideas/Text/XML/Parser.hs view
@@ -89,13 +89,13 @@ nameChar = letter <|> digit <|> combiningChar <|> extender <|> oneOf ".-_:" -- [5] Name ::= (Letter | '_' | ':') (NameChar)* -name :: Parser String +name :: Parser Name name = do c <- letter <|> oneOf "_:" cs <- many nameChar - return (c:cs) + return (uncheckedName (c:cs)) -spacedName :: Parser String +spacedName :: Parser Name spacedName = space *> name <* space {- @@ -173,11 +173,10 @@ p = piTarget >> option "" (space >> stopOn ["?>"]) -- [17] PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) -piTarget :: Parser String +piTarget :: Parser () piTarget = do n <- name - when (map toUpper n == "XML") $ fail "XML in piTarget" - return n + when (map toUpper (show n) == "XML") $ fail "XML in piTarget" -------------------------------------------------- -- ** 2.7 CDATA Sections @@ -636,7 +635,7 @@ return (Public x y) -- [76] NDataDecl ::= S 'NDATA' S Name -nDataDecl :: Parser String +nDataDecl :: Parser Name nDataDecl = space >> string "NDATA" >> space >> name --------------------------------------------------
src/Ideas/Text/XML/Unicode.hs view
@@ -170,16 +170,16 @@ f '\x02D1' , f '\x0387' , f '\x0640' , f '\x0E46' , f '\x0EC6' , f '\x3005' , ('\x3031','\x3035') , ('\x309D','\x309E'), ('\x30FC','\x30FE') ] -decoding :: Monad m => String -> m String +decoding :: String -> Maybe String decoding xs | "\255\254" `isPrefixOf` xs = return (decode16 $ drop 2 xs) | "\254\255" `isPrefixOf` xs = return (decode16X $ drop 2 xs) | "\239\187\191" `isPrefixOf` xs = - UTF8.decodeM (drop 3 xs) + UTF8.decode (drop 3 xs) | otherwise = - UTF8.decodeM xs + UTF8.decode xs decode16 :: String -> String decode16 [] = []
src/Ideas/Utils/BlackBoxTests.hs view
@@ -10,10 +10,12 @@ -- ----------------------------------------------------------------------------- -module Ideas.Utils.BlackBoxTests (blackBoxTests, TestRunner) where +module Ideas.Utils.BlackBoxTests + (blackBoxTests, TestRunner, Mode(..)) where import Control.Monad import Data.Char +import Data.IORef import Data.List import Ideas.Utils.TestSuite import System.Directory @@ -22,9 +24,16 @@ type TestRunner = String -> IO String +data Mode = Interactive | Report | Replace + -- Returns the number of tests performed -blackBoxTests :: TestRunner -> [String] -> String -> IO TestSuite -blackBoxTests runner exts = rec +blackBoxTests :: TestRunner -> Mode -> [String] -> String -> IO TestSuite +blackBoxTests runner mode exts path = do + ref <- newIORef mode + blackBoxTestsInMode ref runner exts path + +blackBoxTestsInMode :: IORef Mode -> TestRunner -> [String] -> String -> IO TestSuite +blackBoxTestsInMode ref runner exts = rec where rec path = do -- analyse content @@ -35,12 +44,12 @@ subs <- filterM doesDirectoryExist xs2 rest <- mapM rec subs return $ suite ("Directory " ++ simplerDirectory path) $ - [ doBlackBoxTest runner (path </> x) + [ doBlackBoxTest ref runner (path </> x) | x <- files ] ++ rest -doBlackBoxTest :: TestRunner -> FilePath -> TestSuite -doBlackBoxTest runner path = +doBlackBoxTest :: IORef Mode -> TestRunner -> FilePath -> TestSuite +doBlackBoxTest ref runner path = assertMessageIO (stripDirectoryPart path) $ -- Comparing output with expected output withFile path ReadMode $ \h1 -> do @@ -57,11 +66,31 @@ msg = unlines (path : diffs list1 list2) if list1 == list2 then return mempty else do force msg -- force evaluation of message before closing files - return (message msg) + return $ addPostHook (postHook out) $ message msg where expPath = baseOf path ++ ".exp" baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse + postHook out status = do + mode <- readIORef ref + case mode of + _ | isOk status -> return () + Report -> return () + Replace -> replaceExpected + Interactive -> do + putStrLn "Replace expected file: (y)es, (s)kip, (a)lways, or (n)ever?" + putStr "? " + answer <- getLine + case map toLower answer of + "y" -> replaceExpected + "s" -> return () + "a" -> replaceExpected >> writeIORef ref Replace + "n" -> writeIORef ref Report + _ -> postHook out status + where + replaceExpected = withFile expPath WriteMode $ \h -> + hSetBinaryMode h True >> hPutStr h out + elemExts :: FilePath -> [String] -> Bool elemExts s = any (\xs -> ('.':xs) `isSuffixOf` s) @@ -96,15 +125,4 @@ stripDirectoryPart = reverse . takeWhile (/= '/') . reverse (</>) :: FilePath -> FilePath -> FilePath -x </> y = x ++ "/" ++ y - -{- -logicConfluence :: IO () -logicConfluence = reportTest "logic rules" (isConfluent f rs) - where - f = normalizeWith ops . normalFormWith ops rs - ops = map makeCommutative Logic.logicOperators - rwrs = Logic.logicRules \\ [Logic.ruleOrOverAnd, Logic.ruleCommOr, Logic.ruleCommAnd] - rs = [ r | RewriteRule r <- concatMap transformations rwrs ] - -- eqs = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ] --}+x </> y = x ++ "/" ++ y
src/Ideas/Utils/Decoding.hs view
@@ -1,91 +1,131 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- Copyright 2019, Ideas project team. This file is distributed under the --- terms of the Apache License 2.0. For more information, see the files --- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Extensions to the QuickCheck library --- ------------------------------------------------------------------------------ - -module Ideas.Utils.Decoding - ( Decoder, runDecoder, symbol - , Encoder, runEncoder - , Error, runError, runErrorM - ) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Reader -import Control.Monad.State -import Data.Semigroup as Sem - -------------------------------------------------------------------- - -newtype Decoder env s a = Dec { runDec :: StateT s (ReaderT env Error) a } - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadReader env, MonadState s) - -instance Sem.Semigroup a => Sem.Semigroup (Decoder env s a) where - (<>) = liftA2 (<>) - -instance Monoid a => Monoid (Decoder env s a) where - mempty = pure mempty - mappend = liftA2 mappend - -symbol :: Decoder env [s] s -symbol = get >>= \list -> - case list of - [] -> fail "Empty input" - x:xs -> - put xs >> return x - -runDecoder :: Monad m => Decoder env s a -> env -> s -> m a -runDecoder p env s = runErrorM (runReaderT (evalStateT (runDec p) s) env) - -------------------------------------------------------------------- - -type Encoder env = Decoder env () - -runEncoder :: Monad m => Encoder env a -> env -> m a -runEncoder p env = runDecoder p env () - -------------------------------------------------------------------- --- Error monad (helper) - -newtype Error a = Error { runError :: Either String a } - -instance Functor Error where - fmap f = Error . fmap f . runError - -instance Applicative Error where - pure = Error . Right - p <*> q = Error $ - case (runError p, runError q) of - (Left s, _) -> Left s - (_, Left s) -> Left s - (Right f, Right x) -> Right (f x) - -instance Alternative Error where - empty = Error (Left "empty") - p <|> q = Error $ - case (runError p, runError q) of - (Right a, _) -> Right a - (_, Right a) -> Right a - (Left s, _) -> Left s - -instance Monad Error where - fail = Error . Left - return = pure - m >>= f = Error $ either Left (runError . f) (runError m) - -instance MonadPlus Error where - mzero = fail "mzero" - mplus = (<|>) - -runErrorM :: Monad m => Error a -> m a -runErrorM = either fail return . runError+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- Copyright 2019, Ideas project team. This file is distributed under the+-- terms of the Apache License 2.0. For more information, see the files+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.+-----------------------------------------------------------------------------+-- |+-- Maintainer : bastiaan.heeren@ou.nl+-- Stability : provisional+-- Portability : portable (depends on ghc)+--+-----------------------------------------------------------------------------++module Ideas.Utils.Decoding+ ( Decoder, evalDecoder, runDecoder, mapError, getLoc, putLoc, changeLoc+ , Encoder, runEncoder+ , Error, ErrorType, Loc(..), nextLoc, raiseError, errorStr+ -- re-exports+ , Alternative(..), optional, MonadReader(..), MonadState(..), MonadError(..)+ , gets+ ) where++import Control.Arrow+import Control.Applicative+import Control.Monad+import Control.Monad.Except hiding (mapError)+import Control.Monad.Reader+import Control.Monad.State+import Data.List+import Data.String++-------------------------------------------------------------------++newtype Decoder env err s a = Dec { fromDec :: StateT (Loc, s) (ReaderT env (Except err)) a }+ deriving (Functor, Applicative, Alternative, MonadPlus, MonadReader env, MonadError err)++instance Semigroup a => Semigroup (Decoder env err s a) where+ (<>) = liftA2 (<>)++instance Monoid a => Monoid (Decoder env err s a) where+ mempty = pure mempty++instance Monad (Decoder env err s) where+ Dec m >>= f = Dec $ m >>= fromDec . f++instance MonadState s (Decoder env err s) where+ state f = Dec $ state $ \(loc, s) -> let (a, s') = f s in (a, (loc, s'))++runDecoder :: Decoder env err s a -> env -> s -> Either err (a, s)+runDecoder p env s = fmap snd <$> runExcept (runReaderT (runStateT (fromDec p) (Root 0, s)) env)++evalDecoder :: Decoder env err s a -> env -> s -> Either err a+evalDecoder p env = fmap fst . runDecoder p env++mapError :: (err1 -> err2) -> Decoder env err1 s a -> Decoder env err2 s a+mapError f p = do+ env <- reader id+ s1 <- get+ case runDecoder p env s1 of+ Left e1 -> throwError (f e1)+ Right (a, s2) -> put s2 >> return a++getLoc :: Decoder env err s Loc+getLoc = Dec $ gets fst++putLoc :: Loc -> Decoder env err s ()+putLoc = changeLoc . const ++changeLoc :: (Loc -> Loc) -> Decoder env err s ()+changeLoc = Dec . modify . first++-------------------------------------------------------------------++type Encoder env err = Decoder env err ()++runEncoder :: Encoder env err a -> env -> Either err a+runEncoder p env = evalDecoder p env ()++--------------------------------------------------------------------------------+-- Errors++newtype Error a = E [Either String (ErrorType, Loc, Maybe a)]++type ErrorType = String ++instance Show a => Show (Error a) where+ show (E xs)+ | null xs = "Parse error"+ | otherwise = unlines (map (either id f) xs)+ where+ + f (tp, loc, ma) = unlines+ [ "Parse error: " ++ tp+ , " * Location: " ++ show loc+ , " * Found: " ++ maybe "" show ma+ ]++instance IsString (Error a) where+ fromString s = E [Left s]++instance Semigroup (Error a) where+ E xs <> E ys = E (xs <> ys)++instance Monoid (Error a) where+ mempty = E []++data Loc = Root Int | LocByPos Int Loc | LocByKey Int String Loc++instance Show Loc where+ show loc+ | null parts = "root"+ | otherwise = intercalate "." parts+ where+ parts = collect loc++ collect (Root n) = [ "root+" ++ show n | n > 0 ]+ collect (LocByPos n l) = collect l ++ [show n]+ collect (LocByKey n k l) = collect l ++ [k ++ if n==0 then "" else "+" ++ show n]++nextLoc :: Loc -> Loc+nextLoc (Root n) = Root (n+1)+nextLoc (LocByPos n l) = LocByPos (n+1) l+nextLoc (LocByKey n k l) = LocByKey (n+1) k l++errorStr :: IsString err => String -> Decoder env err s a+errorStr = throwError . fromString++raiseError :: ErrorType -> Maybe a -> Decoder env (Error a) s b+raiseError tp a = do+ loc <- getLoc+ throwError $ E [Right (tp, loc, a)]
src/Ideas/Utils/Parsing.hs view
@@ -54,7 +54,7 @@ '-':xs -> return (Left (negate (readInt xs))) xs -> return (Left (readInt xs)) [(d, [])] -> return (Right d) - _ -> fail "not a float" + _ -> unexpected "not a float" where nat = many1 digit num = maybe id (:) <$> optionMaybe (char '-') <*> nat @@ -68,7 +68,7 @@ c <- option "" ((:) <$> oneOf "eE" <*> num) case reads (a++b++c) of [(d, [])] -> return d - _ -> fail "not a float" + _ -> unexpected "not a float" where nat = many1 digit num = (:) <$> char '-' <*> nat
src/Ideas/Utils/Prelude.hs view
@@ -18,12 +18,10 @@ , subsets, isSubsetOf , cartesian, distinct, allsame , fixpoint + , split, split3, split4 , splitAtElem, splitsWithElem , timedSeconds, getDiffTime , fst3, snd3, thd3 - , headM, findIndexM - , elementAt, changeAt, replaceAt - , list , mwhen, munless ) where @@ -45,14 +43,15 @@ readInt :: String -> Maybe Int readInt xs - | null xs = Nothing - | any (not . isDigit) xs = Nothing - | otherwise = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' + | null xs = Nothing + | not (all isDigit xs) = Nothing + | otherwise = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' -readM :: (Monad m, Read a) => String -> m a +{-# INLINE readM #-} +readM :: Read a => String -> Maybe a readM s = case reads s of - [(a, xs)] | all isSpace xs -> return a - _ -> fail ("no read: " ++ s) + [(a, xs)] | all isSpace xs -> Just a + _ -> Nothing subsets :: [a] -> [[a]] subsets = foldr op [[]] @@ -80,6 +79,24 @@ | x == head xs = x | otherwise = rec xs +split :: [a] -> [([a], [a])] +split xs = map (`splitAt` xs) [0 .. length xs] + +split3 :: [a] -> [([a], [a], [a])] +split3 as = + [ (xs, ys1, ys2) + | (xs, ys) <- split as + , (ys1, ys2) <- split ys + ] + +split4 :: [a] -> [([a], [a], [a], [a])] +split4 as = + [ (xs1, xs2, ys1, ys2) + | (xs, ys) <- split as + , (xs1, xs2) <- split xs + , (ys1, ys2) <- split ys + ] + splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a]) splitAtElem c s = case break (==c) s of @@ -111,29 +128,6 @@ thd3 :: (a, b, c) -> c thd3 (_, _, x) = x - --- generalized list functions (results in monad) -headM :: Monad m => [a] -> m a -headM (a:_) = return a -headM _ = fail "headM" - -findIndexM :: Monad m => (a -> Bool) -> [a] -> m Int -findIndexM p = maybe (fail "findIndexM") return . findIndex p - -elementAt :: Monad m => Int -> [a] -> m a -elementAt i = headM . drop i - -changeAt :: Monad m => Int -> (a -> a) -> [a] -> m [a] -changeAt i f as = - case splitAt i as of - (xs, y:ys) -> return (xs ++ f y : ys) - _ -> fail "changeAt" - -replaceAt :: Monad m => Int -> a -> [a] -> m [a] -replaceAt i = changeAt i . const - -list :: b -> ([a] -> b) -> [a] -> b -list b f xs = if null xs then b else f xs -- Monoids
src/Ideas/Utils/TestSuite.hs view
@@ -30,7 +30,7 @@ , nrOfTests, nrOfErrors, nrOfWarnings , timeInterval, makeSummary, printSummary -- * Message - , Message, message, warning, messageLines + , Message, message, warning, messageLines, addPostHook -- * Status , Status, HasStatus(..) , isError, isWarning, isOk @@ -100,8 +100,6 @@ message "no expected failure" GaveUp {numTests = i} -> warning ("passed only " ++ show i ++ " tests") - InsufficientCoverage {numTests = i} -> - warning ("only performed " ++ show i ++ " tests") assertTrue :: String -> Bool -> TestSuite assertTrue s = assertIO s . return @@ -193,6 +191,7 @@ newlineIndent ref print msg reset ref + messagePostHook msg returnStrict (caseResult (s, msg)) where handler :: SomeException -> IO Message @@ -343,11 +342,11 @@ -- Message data Message = M - { messageStatus :: !Status - , messageRating :: !Rating - , messageLines :: [String] + { messageStatus :: !Status + , messageRating :: !Rating + , messageLines :: [String] + , messagePostHook :: IO () } - deriving Eq instance Show Message where show a = st ++ sep ++ msg @@ -360,12 +359,15 @@ | otherwise = "" instance Sem.Semigroup Message where - M s r xs <> M t q ys = M (s <> t) (r <> q) (xs <> ys) + M s r xs ph1 <> M t q ys ph2 = M (s <> t) (r <> q) (xs <> ys) (ph1 <> ph2) instance Monoid Message where - mempty = M mempty mempty mempty + mempty = M mempty mempty mempty (return ()) mappend = (<>) +instance HasStatus Status where + getStatus = id + instance HasStatus Message where getStatus = messageStatus @@ -374,16 +376,19 @@ rate n a = a {messageRating = Rating n} message :: String -> Message -message = M Error (Rating 0) . return +message s = M Error (Rating 0) [s] (return ()) warning :: String -> Message -warning = M Warning mempty . return +warning s = M Warning mempty [s] (return ()) +addPostHook :: (Status -> IO ()) -> Message -> Message +addPostHook postHook m = m { messagePostHook = messagePostHook m <> postHook (messageStatus m) } + ----------------------------------------------------- -- Status data Status = Ok | Warning | Error - deriving (Eq, Ord) + deriving (Show, Eq, Ord) instance Sem.Semigroup Status where (<>) = max