ideas 1.2 → 1.3
raw patch · 113 files changed
+4233/−2496 lines, 113 filesdep +Diffdep +bytestringdep +exceptionsdep −cgi
Dependencies added: Diff, bytestring, exceptions, mtl, multipart, network, old-locale, old-time, xhtml
Dependencies removed: cgi
Files
- CREDITS.txt +9/−1
- ideas.cabal +132/−115
- src/Ideas/Common/Algebra/Boolean.hs +2/−2
- src/Ideas/Common/Algebra/BooleanLaws.hs +2/−2
- src/Ideas/Common/Algebra/Field.hs +2/−2
- src/Ideas/Common/Algebra/FieldLaws.hs +2/−2
- src/Ideas/Common/Algebra/Group.hs +7/−4
- src/Ideas/Common/Algebra/GroupLaws.hs +2/−2
- src/Ideas/Common/Algebra/Law.hs +2/−2
- src/Ideas/Common/Algebra/SmartGroup.hs +2/−2
- src/Ideas/Common/Classes.hs +2/−2
- src/Ideas/Common/Context.hs +2/−2
- src/Ideas/Common/Derivation.hs +2/−2
- src/Ideas/Common/DerivationTree.hs +2/−2
- src/Ideas/Common/Environment.hs +2/−2
- src/Ideas/Common/Exercise.hs +10/−13
- src/Ideas/Common/ExerciseTests.hs +6/−8
- src/Ideas/Common/Id.hs +3/−3
- src/Ideas/Common/Library.hs +2/−3
- src/Ideas/Common/Predicate.hs +2/−2
- src/Ideas/Common/Rewriting.hs +2/−2
- src/Ideas/Common/Rewriting/AC.hs +2/−2
- src/Ideas/Common/Rewriting/Confluence.hs +2/−2
- src/Ideas/Common/Rewriting/Difference.hs +2/−2
- src/Ideas/Common/Rewriting/RewriteRule.hs +7/−3
- src/Ideas/Common/Rewriting/Substitution.hs +2/−2
- src/Ideas/Common/Rewriting/Term.hs +6/−3
- src/Ideas/Common/Rewriting/Unification.hs +2/−2
- src/Ideas/Common/Rule.hs +2/−2
- src/Ideas/Common/Rule/Abstract.hs +2/−9
- src/Ideas/Common/Rule/EnvironmentMonad.hs +2/−2
- src/Ideas/Common/Rule/Parameter.hs +2/−2
- src/Ideas/Common/Rule/Recognizer.hs +2/−2
- src/Ideas/Common/Rule/Transformation.hs +2/−2
- src/Ideas/Common/Strategy.hs +11/−9
- src/Ideas/Common/Strategy/Abstract.hs +67/−122
- src/Ideas/Common/Strategy/Choice.hs +232/−0
- src/Ideas/Common/Strategy/Combinators.hs +21/−10
- src/Ideas/Common/Strategy/Configuration.hs +69/−77
- src/Ideas/Common/Strategy/Core.hs +77/−72
- src/Ideas/Common/Strategy/Derived.hs +62/−0
- src/Ideas/Common/Strategy/Location.hs +15/−18
- src/Ideas/Common/Strategy/Parsing.hs +216/−109
- src/Ideas/Common/Strategy/Path.hs +0/−70
- src/Ideas/Common/Strategy/Prefix.hs +0/−75
- src/Ideas/Common/Strategy/Process.hs +156/−0
- src/Ideas/Common/Strategy/Sequence.hs +101/−0
- src/Ideas/Common/Strategy/Sequential.hs +0/−326
- src/Ideas/Common/Strategy/Tests.hs +0/−183
- src/Ideas/Common/Strategy/Traversal.hs +13/−3
- src/Ideas/Common/Traversal/Iterator.hs +2/−2
- src/Ideas/Common/Traversal/Navigator.hs +2/−2
- src/Ideas/Common/Traversal/Tests.hs +2/−2
- src/Ideas/Common/Traversal/Utils.hs +2/−2
- src/Ideas/Common/Utils.hs +2/−2
- src/Ideas/Common/Utils/QuickCheck.hs +2/−2
- src/Ideas/Common/Utils/StringRef.hs +2/−2
- src/Ideas/Common/Utils/TestSuite.hs +2/−2
- src/Ideas/Common/Utils/Uniplate.hs +2/−2
- src/Ideas/Common/View.hs +2/−2
- src/Ideas/Encoding/DecoderJSON.hs +55/−68
- src/Ideas/Encoding/DecoderXML.hs +97/−86
- src/Ideas/Encoding/Encoder.hs +261/−0
- src/Ideas/Encoding/EncoderHTML.hs +198/−171
- src/Ideas/Encoding/EncoderJSON.hs +47/−40
- src/Ideas/Encoding/EncoderXML.hs +43/−46
- src/Ideas/Encoding/Evaluator.hs +15/−143
- src/Ideas/Encoding/LinkManager.hs +14/−8
- src/Ideas/Encoding/ModeJSON.hs +28/−31
- src/Ideas/Encoding/ModeXML.hs +34/−85
- src/Ideas/Encoding/OpenMathSupport.hs +2/−2
- src/Ideas/Encoding/RulePresenter.hs +2/−2
- src/Ideas/Encoding/RulesInfo.hs +4/−6
- src/Ideas/Encoding/StrategyInfo.hs +55/−52
- src/Ideas/Main/BlackBoxTests.hs +32/−11
- src/Ideas/Main/Default.hs +52/−47
- src/Ideas/Main/Documentation.hs +17/−14
- src/Ideas/Main/LoggingDatabase.hs +3/−3
- src/Ideas/Main/Options.hs +3/−3
- src/Ideas/Main/Revision.hs +3/−3
- src/Ideas/Service/BasicServices.hs +26/−44
- src/Ideas/Service/Diagnose.hs +16/−12
- src/Ideas/Service/DomainReasoner.hs +16/−6
- src/Ideas/Service/FeedbackScript/Analysis.hs +2/−2
- src/Ideas/Service/FeedbackScript/Parser.hs +3/−3
- src/Ideas/Service/FeedbackScript/Run.hs +3/−6
- src/Ideas/Service/FeedbackScript/Syntax.hs +2/−2
- src/Ideas/Service/FeedbackText.hs +11/−10
- src/Ideas/Service/ProblemDecomposition.hs +59/−73
- src/Ideas/Service/Request.hs +22/−17
- src/Ideas/Service/ServiceList.hs +92/−46
- src/Ideas/Service/State.hs +52/−22
- src/Ideas/Service/Submit.hs +8/−5
- src/Ideas/Service/Types.hs +92/−86
- src/Ideas/Text/HTML.hs +2/−2
- src/Ideas/Text/JSON.hs +12/−9
- src/Ideas/Text/OpenMath/FMP.hs +2/−2
- src/Ideas/Text/OpenMath/Object.hs +2/−2
- src/Ideas/Text/OpenMath/Symbol.hs +2/−2
- src/Ideas/Text/OpenMath/Tests.hs +2/−2
- src/Ideas/Text/Parsing.hs +2/−2
- src/Ideas/Text/UTF8.hs +2/−2
- src/Ideas/Text/XML.hs +3/−3
- src/Ideas/Text/XML/Document.hs +2/−2
- src/Ideas/Text/XML/Interface.hs +9/−5
- src/Ideas/Text/XML/Parser.hs +2/−2
- src/Ideas/Text/XML/Unicode.hs +2/−2
- src/Network/CGI.hs +634/−0
- src/Network/CGI/Accept.hs +173/−0
- src/Network/CGI/Compat.hs +112/−0
- src/Network/CGI/Cookie.hs +154/−0
- src/Network/CGI/Monad.hs +138/−0
- src/Network/CGI/Protocol.hs +317/−0
CREDITS.txt view
@@ -4,4 +4,12 @@ CREDITS -Harrie Passier, Arthur van Leeuwen, Josje Lodder+Harrie Passier, Arthur van Leeuwen, Josje Lodder, Hieke Keuning+++This package contains a verbatim copy of the cgi-3001.2.2.0 package, with+minor modifications to resolve conflicting dependencies. The original package,+together with its BSD3 license and further information about copyright, author+and maintainer, can be found at:++ http://hackage.haskell.org/package/cgi-3001.2.2.0
ideas.cabal view
@@ -1,5 +1,5 @@ name: ideas-version: 1.2+version: 1.3 synopsis: Feedback services for intelligent tutoring systems homepage: http://ideas.cs.uu.nl/www/ description:@@ -9,7 +9,7 @@ and Activemath. category: Education-copyright: (c) 2014+copyright: (c) 2015 license: GPL license-file: LICENSE.txt author: Bastiaan Heeren, Alex Gerdes, Johan Jeuring@@ -18,7 +18,7 @@ extra-source-files: CREDITS.txt build-type: Simple cabal-version: >= 1.8.0.2-tested-with: GHC == 7.4.1, GHC == 7.6.3+tested-with: GHC == 7.4.1, GHC == 7.6.3, GHC == 7.8.3 source-repository head type: svn@@ -31,128 +31,145 @@ hs-source-dirs: src Build-Depends: base >= 4.2 && < 5, QuickCheck >= 2.4.1 && < 2.7, + Diff, containers, random, uniplate, time, filepath, directory,- cgi, parsec, wl-pprint,- array+ array,+ mtl == 2.1.*,+ network < 2.6,+ exceptions,+ multipart,+ bytestring,+ old-time,+ old-locale,+ xhtml Exposed-modules:- Ideas.Common.Algebra.Boolean- Ideas.Common.Algebra.BooleanLaws- Ideas.Common.Algebra.Field- Ideas.Common.Algebra.FieldLaws- Ideas.Common.Algebra.Group- Ideas.Common.Algebra.GroupLaws- Ideas.Common.Algebra.Law- Ideas.Common.Algebra.SmartGroup- Ideas.Common.Classes- Ideas.Common.Context- Ideas.Common.Derivation- Ideas.Common.DerivationTree- Ideas.Common.Environment- 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.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.EnvironmentMonad- Ideas.Common.Rule.Parameter- Ideas.Common.Rule.Recognizer- Ideas.Common.Rule.Transformation- Ideas.Common.Strategy- Ideas.Common.Strategy.Abstract- Ideas.Common.Strategy.Combinators- Ideas.Common.Strategy.Configuration- Ideas.Common.Strategy.Core- Ideas.Common.Strategy.Location- Ideas.Common.Strategy.Parsing- Ideas.Common.Strategy.Path- Ideas.Common.Strategy.Prefix- Ideas.Common.Strategy.Sequential- Ideas.Common.Strategy.Tests- Ideas.Common.Strategy.Traversal- Ideas.Common.Traversal.Iterator- Ideas.Common.Traversal.Navigator- Ideas.Common.Traversal.Tests- Ideas.Common.Traversal.Utils- Ideas.Common.Utils- Ideas.Common.Utils.QuickCheck- Ideas.Common.Utils.StringRef- Ideas.Common.Utils.TestSuite- Ideas.Common.Utils.Uniplate- Ideas.Common.View- Ideas.Encoding.DecoderJSON- Ideas.Encoding.DecoderXML- Ideas.Encoding.EncoderHTML- Ideas.Encoding.EncoderJSON- Ideas.Encoding.EncoderXML- Ideas.Encoding.Evaluator- Ideas.Encoding.LinkManager- Ideas.Encoding.ModeJSON- Ideas.Encoding.ModeXML- Ideas.Encoding.OpenMathSupport- Ideas.Encoding.RulePresenter- Ideas.Encoding.RulesInfo- Ideas.Encoding.StrategyInfo- Ideas.Main.BlackBoxTests- Ideas.Main.Default- Ideas.Main.Documentation- Ideas.Main.LoggingDatabase- Ideas.Main.Options- 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.Request- Ideas.Service.ServiceList- Ideas.Service.State- Ideas.Service.Submit- Ideas.Service.Types- Ideas.Text.HTML- Ideas.Text.JSON- 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.Parsing- Ideas.Text.UTF8- Ideas.Text.XML- Ideas.Text.XML.Document- Ideas.Text.XML.Interface- Ideas.Text.XML.Parser- Ideas.Text.XML.Unicode+ Ideas.Common.Algebra.Boolean+ Ideas.Common.Algebra.BooleanLaws+ Ideas.Common.Algebra.Field+ Ideas.Common.Algebra.FieldLaws+ Ideas.Common.Algebra.Group+ Ideas.Common.Algebra.GroupLaws+ Ideas.Common.Algebra.Law+ Ideas.Common.Algebra.SmartGroup+ Ideas.Common.Classes+ Ideas.Common.Context+ Ideas.Common.Derivation+ Ideas.Common.DerivationTree+ Ideas.Common.Environment+ 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.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.EnvironmentMonad+ 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.Core+ Ideas.Common.Strategy.Derived+ Ideas.Common.Strategy.Location+ Ideas.Common.Strategy.Parsing+ Ideas.Common.Strategy.Process+ Ideas.Common.Strategy.Sequence+ Ideas.Common.Strategy.Traversal+ Ideas.Common.Traversal.Iterator+ Ideas.Common.Traversal.Navigator+ Ideas.Common.Traversal.Tests+ Ideas.Common.Traversal.Utils+ Ideas.Common.Utils+ Ideas.Common.Utils.QuickCheck+ Ideas.Common.Utils.StringRef+ Ideas.Common.Utils.TestSuite+ Ideas.Common.Utils.Uniplate+ 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.ModeJSON+ Ideas.Encoding.ModeXML+ Ideas.Encoding.OpenMathSupport+ Ideas.Encoding.RulePresenter+ Ideas.Encoding.RulesInfo+ Ideas.Encoding.StrategyInfo+ Ideas.Main.BlackBoxTests+ Ideas.Main.Default+ Ideas.Main.Documentation+ Ideas.Main.LoggingDatabase+ Ideas.Main.Options+ 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.Request+ Ideas.Service.ServiceList+ Ideas.Service.State+ Ideas.Service.Submit+ Ideas.Service.Types+ Ideas.Text.HTML+ Ideas.Text.JSON+ 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.Parsing+ Ideas.Text.UTF8+ Ideas.Text.XML+ Ideas.Text.XML.Document+ Ideas.Text.XML.Interface+ Ideas.Text.XML.Parser+ Ideas.Text.XML.Unicode++ Other-modules:+ Network.CGI+ Network.CGI.Accept+ Network.CGI.Compat+ Network.CGI.Cookie+ Network.CGI.Monad+ Network.CGI.Protocol --------------------------------------------------------------------------------
src/Ideas/Common/Algebra/Boolean.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Boolean.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Boolean.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Algebra.Boolean ( -- * Boolean algebra
src/Ideas/Common/Algebra/BooleanLaws.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: BooleanLaws.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: BooleanLaws.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Algebra.BooleanLaws ( -- * Boolean laws
src/Ideas/Common/Algebra/Field.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Field.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Field.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Algebra.Field ( -- * Semi-ring
src/Ideas/Common/Algebra/FieldLaws.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: FieldLaws.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: FieldLaws.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Algebra.FieldLaws ( -- * Semi-ring laws
src/Ideas/Common/Algebra/Group.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Group.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Group.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Algebra.Group ( -- * Monoids @@ -29,7 +29,7 @@ import Data.Foldable (Foldable) import Data.Maybe import Data.Monoid -import Data.Traversable (Traversable) +import Data.Traversable (Traversable, traverse) import Ideas.Common.Classes import qualified Data.Set as S @@ -59,7 +59,7 @@ -- Type that adds a zero element newtype WithZero a = WZ { fromWithZero :: Maybe a } - deriving (Eq, Ord, Functor, Foldable, Traversable, Applicative) + deriving (Eq, Ord, Functor, Foldable, Applicative) instance Monoid a => Monoid (WithZero a) where mempty = WZ (Just mempty) @@ -67,6 +67,9 @@ instance Monoid a => MonoidZero (WithZero a) where mzero = WZ Nothing + +instance Traversable WithZero where + traverse f = liftA WZ . traverse f . fromWithZero -------------------------------------------------------- -- Groups
src/Ideas/Common/Algebra/GroupLaws.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: GroupLaws.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: GroupLaws.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Algebra.GroupLaws ( -- * Monoid laws
src/Ideas/Common/Algebra/Law.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Law.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Law.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Algebra.Law ( Law, LawSpec((:==:)), law, mapLaw
src/Ideas/Common/Algebra/SmartGroup.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: SmartGroup.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: SmartGroup.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Algebra.SmartGroup ( -- * Smart datatypes
src/Ideas/Common/Classes.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Type classes and instances. -- ----------------------------------------------------------------------------- --- $Id: Classes.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Classes.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Classes ( -- * Type class Apply
src/Ideas/Common/Context.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -16,7 +16,7 @@ -- the 'Navigator' type class (for traversing the term). -- ----------------------------------------------------------------------------- --- $Id: Context.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Context.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Context ( -- * Abstract data type
src/Ideas/Common/Derivation.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- and the steps) -- ----------------------------------------------------------------------------- --- $Id: Derivation.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Derivation.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Derivation ( -- * Data type
src/Ideas/Common/DerivationTree.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- intermediate results as well as annotations for the steps. -- ----------------------------------------------------------------------------- --- $Id: DerivationTree.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: DerivationTree.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.DerivationTree ( -- * Data types
src/Ideas/Common/Environment.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- References, bindings, and heterogenous environments -- ----------------------------------------------------------------------------- --- $Id: Environment.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Environment.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Environment ( -- * Reference
src/Ideas/Common/Exercise.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE Rank2Types, DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,7 +15,7 @@ -- "Ideas.Common.ExerciseTests" module. -- ----------------------------------------------------------------------------- --- $Id: Exercise.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Exercise.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Exercise ( -- * Exercise record @@ -38,20 +38,18 @@ , simpleGenerator, useGenerator, randomTerm, randomTerms -- * Derivations , showDerivation, showDerivations, printDerivation, printDerivations - , diffEnvironment + , diffEnvironment, defaultDerivation, allDerivations ) where import Data.Char import Data.Data import Data.Dynamic -import Data.Function import Data.List import Data.Maybe import Data.Ord import Ideas.Common.Classes import Ideas.Common.Context import Ideas.Common.Derivation -import Ideas.Common.DerivationTree import Ideas.Common.Environment import Ideas.Common.Id import Ideas.Common.Predicate @@ -376,7 +374,10 @@ -- | 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 = showThisDerivation (defaultDerivation ex a) ex +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. @@ -422,13 +423,9 @@ list = bindings old in (a, makeEnvironment $ filter keep $ bindings new) -defaultDerivation :: Exercise a -> a -> Derivation (Rule (Context a), Environment) (Context a) -defaultDerivation ex a = - case allDerivations ex a of - [] -> emptyDerivation (inContext ex a) - d:_ -> d +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 = - derivations . sortTree (ruleOrdering ex `on` fst) - . derivationTree (strategy ex) . inContext ex+ derivationList (ruleOrdering ex) (strategy ex) . inContext ex
src/Ideas/Common/ExerciseTests.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: ExerciseTests.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: ExerciseTests.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.ExerciseTests where @@ -20,12 +20,10 @@ import Ideas.Common.Classes import Ideas.Common.Context import Ideas.Common.Derivation -import Ideas.Common.DerivationTree import Ideas.Common.Environment import Ideas.Common.Exercise import Ideas.Common.Id import Ideas.Common.Rule -import Ideas.Common.Strategy (derivationTree) import Ideas.Common.Utils.TestSuite import Ideas.Common.View import System.Random @@ -114,19 +112,19 @@ xs = map snd (examples ex) checksForTerm :: Bool -> StdGen -> Exercise a -> a -> [TestSuite] -checksForTerm leftMost stdgen ex a = +checksForTerm leftMost _ ex a = concat -- Left-most derivation - [ case derivation tree of + [ case defaultDerivation ex a of Just d -> checksForDerivation ex d Nothing -> [assertTrue ("no derivation for " ++ prettyPrinter ex a) False] | leftMost - ] ++ + ] {- ++ case randomDerivation stdgen tree of Just d -> checksForDerivation ex d Nothing -> [] where - tree = derivationTree (strategy ex) (inContext ex a) + tree = derivationTree (strategy ex) (inContext ex a) -} checksForDerivation :: Exercise a -> Derivation (Rule (Context a), Environment) (Context a) -> [TestSuite] checksForDerivation ex d =
src/Ideas/Common/Id.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -30,7 +30,7 @@ -- The 'Id' datatype implements and re-exports the Monoid interface. -- ----------------------------------------------------------------------------- --- $Id: Id.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Id.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Id ( -- * Constructing identifiers @@ -164,7 +164,7 @@ where ref = stringRef (show a ++ "." ++ show b) --- Only allow alphanum and '-' ('.' has a special meaning) +-- Only allow alphanum and '-' and '_' ('.' has a special meaning) stringId :: String -> Id stringId txt = Id (make s) "" (stringRef s) where
src/Ideas/Common/Library.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Exports most from package Common -- ----------------------------------------------------------------------------- --- $Id: Library.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Library.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Library ( module Export @@ -21,7 +21,6 @@ import Ideas.Common.Classes as Export import Ideas.Common.Context as Export import Ideas.Common.Derivation as Export -import Ideas.Common.DerivationTree as Export import Ideas.Common.Environment as Export import Ideas.Common.Exercise as Export import Ideas.Common.Id as Export
src/Ideas/Common/Predicate.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- Representation for predicates -- ----------------------------------------------------------------------------- --- $Id: Predicate.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Predicate.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Predicate ( -- * Predicate representation
src/Ideas/Common/Rewriting.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Rewriting.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Rewriting.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rewriting (module Export) where
src/Ideas/Common/Rewriting/AC.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: AC.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: AC.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rewriting.AC ( -- * Types
src/Ideas/Common/Rewriting/Confluence.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Confluence.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Confluence.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rewriting.Confluence ( isConfluent, checkConfluence, checkConfluenceWith
src/Ideas/Common/Rewriting/Difference.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- into account. -- ----------------------------------------------------------------------------- --- $Id: Difference.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Difference.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rewriting.Difference ( difference, differenceEqual
src/Ideas/Common/Rewriting/RewriteRule.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: RewriteRule.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: RewriteRule.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rewriting.RewriteRule ( -- * Supporting type class @@ -19,7 +19,7 @@ -- * Rewrite rules and specs , RewriteRule, ruleSpecTerm, RuleSpec(..) -- * Compiling rewrite rules - , makeRewriteRule, RuleBuilder(..) + , makeRewriteRule, termRewriteRule, RuleBuilder(..) -- * Using rewrite rules , showRewriteRule , metaInRewriteRule, renumberRewriteRule @@ -125,6 +125,10 @@ makeRewriteRule :: (IsId n, RuleBuilder f a) => n -> f -> RewriteRule a makeRewriteRule s f = R (newId s) (buildRuleSpec 0 f) show termView M.empty M.empty + +termRewriteRule :: (IsId n, IsTerm a, Show a) => n -> RuleSpec Term -> RewriteRule a +termRewriteRule s spec = + R (newId s) spec show termView M.empty M.empty symbolMatcher :: Symbol -> SymbolMatch -> RewriteRule a -> RewriteRule a symbolMatcher s f r = r {ruleMatchers = M.insert s f (ruleMatchers r)}
src/Ideas/Common/Rewriting/Substitution.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Substitutions on terms. Substitutions are idempotent, and non-cyclic. -- ----------------------------------------------------------------------------- --- $Id: Substitution.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Substitution.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rewriting.Substitution ( Substitution, emptySubst, singletonSubst, dom, lookupVar
src/Ideas/Common/Rewriting/Term.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS -fno-warn-orphans #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,7 @@ -- A simple data type for term rewriting -- ----------------------------------------------------------------------------- --- $Id: Term.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Term.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rewriting.Term ( -- * Symbols @@ -24,7 +24,7 @@ , fromTermM, fromTermWith -- * Functions and symbols , WithFunctions(..), isSymbol, isFunction - , unary, binary, isUnary, isBinary + , unary, binary, ternary, isUnary, isBinary -- * Variables , WithVars(..), isVariable , vars, varSet, hasVar, withoutVar @@ -191,6 +191,9 @@ 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 =
src/Ideas/Common/Rewriting/Unification.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Unification.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Unification.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rewriting.Unification ( unify, match, matchExtended, matchList
src/Ideas/Common/Rule.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Rule.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Rule.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rule (module Export) where
src/Ideas/Common/Rule/Abstract.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,7 +14,7 @@ -- can be lifted with a view using the LiftView type class. -- ----------------------------------------------------------------------------- --- $Id: Abstract.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Abstract.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rule.Abstract ( -- * Rule data type and accessors @@ -43,7 +43,6 @@ import Ideas.Common.Rule.Recognizer import Ideas.Common.Rule.Transformation import Ideas.Common.View -import Test.QuickCheck ----------------------------------------------------------- --- Rule data type and accessors @@ -90,12 +89,6 @@ instance Minor (Rule a) where setMinor b r = r {isMinorRule = b} isMinor = isMinorRule - -instance (Arbitrary a, CoArbitrary a) => Arbitrary (Rule a) where - arbitrary = liftM3 make arbitrary arbitrary arbitrary - where - make :: Bool -> Id -> (a -> Maybe a) -> Rule a - make b n f = setMinor b $ makeRule n f instance HasRefs (Rule a) where allRefs r = allRefs (transformation r) ++ allRefs (recognizer r)
src/Ideas/Common/Rule/EnvironmentMonad.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- State monad for environments -- ----------------------------------------------------------------------------- --- $Id: EnvironmentMonad.hs 6542 2014-05-14 19:03:09Z bastiaan $ +-- $Id: EnvironmentMonad.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rule.EnvironmentMonad ( -- * Environment Monad
src/Ideas/Common/Rule/Parameter.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,7 +15,7 @@ -- the LiftView type class. -- ----------------------------------------------------------------------------- --- $Id: Parameter.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Parameter.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rule.Parameter ( ParamTrans
src/Ideas/Common/Rule/Recognizer.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Recognizer.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Recognizer.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rule.Recognizer ( -- * data type and type class
src/Ideas/Common/Rule/Transformation.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, Rank2Types #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,7 @@ -- a list of results (often a singleton list or the empty list). -- ----------------------------------------------------------------------------- --- $Id: Transformation.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Transformation.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Rule.Transformation ( -- * Trans data type
src/Ideas/Common/Strategy.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,14 +14,14 @@ -- functions yourself. -- ----------------------------------------------------------------------------- --- $Id: Strategy.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Strategy.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Strategy ( -- * Data types and type classes Strategy, LabeledStrategy , IsStrategy(..) -- * Running strategies - , fullDerivationTree, derivationTree + , derivationList -- * Strategy combinators -- ** Basic combinators , (<*>), (<|>), (<%>), succeed, fail, atomic, label @@ -29,7 +29,7 @@ -- ** EBNF combinators , many, many1, replicate, option -- ** Negation and greedy combinators - , check, not, repeat, repeat1, try, (|>), exhaustive + , check, not, repeat, repeat1, try, (|>), (>|>), exhaustive , while, until, multi -- ** Graph , DependencyGraph, dependencyGraph @@ -37,12 +37,16 @@ , module Ideas.Common.Strategy.Traversal -- * Configuration combinators , module Ideas.Common.Strategy.Configuration + , remove, collapse, hide -- * Strategy locations - , strategyLocations, subStrategy + , strategyLocations, checkLocation , subTaskLocation, nextTaskLocation -- * Prefixes - , Prefix, showPrefix, emptyPrefix, makePrefix, prefixTree, Step(..), Path, emptyPath - , prefixToSteps, stepsToRules, lastStepInPrefix, activeLabels + , Prefix, emptyPrefix, noPrefix + , replayPath, replayPaths, replayStrategy + , Step(..), stepRule, stepEnvironment + , Path, emptyPath, readPath, readPaths + , prefixPaths, majorPrefix, isEmptyPrefix -- * Misc , cleanUpStrategy, cleanUpStrategyAfter , rulesInStrategy @@ -53,7 +57,5 @@ import Ideas.Common.Strategy.Configuration import Ideas.Common.Strategy.Location import Ideas.Common.Strategy.Parsing -import Ideas.Common.Strategy.Path -import Ideas.Common.Strategy.Prefix import Ideas.Common.Strategy.Traversal hiding (full, spine, stop, once) import Prelude ()
src/Ideas/Common/Strategy/Abstract.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,40 +10,39 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Abstract.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Abstract.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Strategy.Abstract ( Strategy, IsStrategy(..) , LabeledStrategy, label, unlabel - , fullDerivationTree, derivationTree, rulesInStrategy + , derivationList + , emptyPrefix, replayPath, replayPaths, replayStrategy + , rulesInStrategy , mapRules, mapRulesS , cleanUpStrategy, cleanUpStrategyAfter -- Accessors to the underlying representation - , toCore, fromCore, liftCore, liftCore2, makeLabeledStrategy - , toLabeledStrategy - , LabelInfo, processLabelInfo, changeInfo, makeInfo - , removed, collapsed, hidden, IsLabeled(..), noInterleaving + , toCore, fromCore, liftCore, liftCore2 + , noInterleaving ) where -import Control.Monad -import Data.List +import Data.Function import Ideas.Common.Classes -import Ideas.Common.DerivationTree +import Ideas.Common.Derivation import Ideas.Common.Environment import Ideas.Common.Id import Ideas.Common.Rewriting (RewriteRule) import Ideas.Common.Rule import Ideas.Common.Strategy.Core import Ideas.Common.Strategy.Parsing +import Ideas.Common.Strategy.Sequence (Firsts(..), firstsOrdered) import Ideas.Common.Utils.Uniplate hiding (rewriteM) import Ideas.Common.View -import Test.QuickCheck hiding (label) ----------------------------------------------------------- --- Strategy data-type -- | Abstract data type for strategies -newtype Strategy a = S { toCore :: Core LabelInfo a } +newtype Strategy a = S (Core a) instance Show (Strategy a) where show = show . toCore @@ -51,39 +50,7 @@ instance Apply Strategy where applyAll = runCore . toCore -instance (Arbitrary a, CoArbitrary a) => Arbitrary (Strategy a) where - arbitrary = liftM fromCore arbitrary - ----------------------------------------------------------- ---- The information used as label in a strategy - -data LabelInfo = Info - { labelId :: Id - , removed :: Bool - , collapsed :: Bool - , hidden :: Bool - } - deriving (Eq, Ord) - -instance Show LabelInfo where - show info = - let ps = ["removed" | removed info] ++ - ["collapsed" | collapsed info] ++ - ["hidden" | hidden info] - extra = " (" ++ intercalate ", " ps ++ ")" - in showId info ++ if null ps then "" else extra - -instance HasId LabelInfo where - getId = labelId - changeId f info = info { labelId = f (labelId info) } - -instance Arbitrary LabelInfo where - arbitrary = liftM (makeInfo :: Id -> LabelInfo) arbitrary - -makeInfo :: IsId a => a -> LabelInfo -makeInfo s = Info (newId s) False False False - ------------------------------------------------------------ --- Type class -- | Type class to turn values into strategies @@ -97,9 +64,7 @@ toStrategy (LS info (S core)) = S (Label info core) instance IsStrategy Rule where - toStrategy r - | isMajor r = toStrategy (toLabeled r) - | otherwise = S (Rule r) + toStrategy = S . Rule instance IsStrategy RewriteRule where toStrategy = toStrategy . ruleRewrite @@ -107,98 +72,78 @@ ----------------------------------------------------------- --- Labeled Strategy data-type --- | A strategy which is labeled with a string -data LabeledStrategy a = LS - { labelInfo :: LabelInfo -- ^ Returns information associated with this label - , unlabel :: Strategy a -- ^ Removes the label from a strategy - } - -makeLabeledStrategy :: IsStrategy f => LabelInfo -> f a -> LabeledStrategy a -makeLabeledStrategy info = LS info . toStrategy - -toLabeledStrategy :: Monad m => Strategy a -> m (LabeledStrategy a) -toLabeledStrategy s = - case toCore s of - Label l c -> return (makeLabeledStrategy l (fromCore c)) - _ -> fail "Strategy without label" +-- | A strategy which is labeled with an identifier +data LabeledStrategy a = LS Id (Strategy a) instance Show (LabeledStrategy a) where - show s = show (labelInfo s) ++ ": " ++ show (unlabel s) + show s = showId s ++ ": " ++ show (unlabel s) instance Apply LabeledStrategy where applyAll = applyAll . toStrategy instance HasId (LabeledStrategy a) where - getId = getId . labelInfo - changeId = changeInfo . changeId - -class IsLabeled f where - toLabeled :: f a -> LabeledStrategy a - -instance IsLabeled LabeledStrategy where - toLabeled = id - -instance IsLabeled Rule where - toLabeled r = LS (makeInfo (getId r)) (S (Rule r)) - -instance IsLabeled RewriteRule where - toLabeled = toLabeled . ruleRewrite + getId (LS l _) = l + changeId f (LS l s) = LS (changeId f l) s -- | Labels a strategy with an identifier. Labels are used to identify -- substrategies and to specialize feedback messages. The first argument of -- 'label' can be of type 'String', in which case the string is used as -- identifier (and not as description). label :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a -label l = LS (makeInfo l) . toStrategy +label l = LS (newId l) . toStrategy -changeInfo :: IsLabeled f => (LabelInfo -> LabelInfo) -> f a -> LabeledStrategy a -changeInfo f a = LS (f info) s - where LS info s = toLabeled a +-- | Removes the label from a strategy +unlabel :: LabeledStrategy a -> Strategy a +unlabel (LS _ s) = s ------------------------------------------------------------ ---- Process Label Information +-- | Construct the empty prefix for a labeled strategy +emptyPrefix :: IsStrategy f => f a -> a -> Prefix a +emptyPrefix = makePrefix . toCore -processLabelInfo :: (l -> LabelInfo) -> Core l a -> Core l a -processLabelInfo getInfo = rec [] - where - rec env core = - case core of - -- Rec n a -> Rec n (rec ((n, core):env) a) - -- Let ?? - Label l a -> forLabel env l (rec env a) - _ -> descend (rec env) core +-- | Construct a prefix for a path and a labeled strategy. The third argument +-- is the current term. +replayPath :: IsStrategy f => Path -> f a -> a -> ([Step a], Prefix a) +replayPath path s a = + let (xs, f) = replayCore path (toCore s) + in (xs, f a) - forLabel env l c - | removed info = Fail - | collapsed info = Label l (Rule asRule) -- !! - | otherwise = new - where - new | hidden info = fmap minor (Label l c) - | otherwise = Label l c - info = getInfo l - asRule = makeRule (getId info) (runCore (subst new)) - subst = flip (foldl (flip (uncurry substCoreVar))) env +-- | Construct a prefix for a list of paths and a labeled strategy. The third +-- argument is the current term. +replayPaths :: IsStrategy f => [Path] -> f a -> a -> Prefix a +replayPaths paths s a = mconcat + [ snd (replayPath path s a) | path <- paths ] +-- | 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 = + let (xs, f) = replayCore path (toCore s) + in case applyList xs a of + Just b -> return (b, f b) + Nothing -> fail "Cannot replay strategy" + ----------------------------------------------------------- --- Remaining functions --- | Returns the derivation tree for a strategy and a term, including all --- minor rules -fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a -fullDerivationTree = make . processLabelInfo id . toCore . toStrategy +derivationList :: IsStrategy f => (Rule a -> Rule a -> Ordering) -> f a -> a -> [Derivation (Rule a, Environment) a] +derivationList cmpRule s a0 = rec a0 (toPrefix s) where - make core a = fmap fst (parseDerivationTree a (makeState a core)) + toPrefix = majorPrefix . flip makePrefix a0 . toCore --- | Returns the derivation tree for a strategy and a term with only major rules -derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a, Environment) a -derivationTree s = mergeMaybeSteps . mapFirst f . fullDerivationTree s - where - f (RuleStep env r) | isMajor r = Just (r, env) - f _ = Nothing + rec a prfx = (if ready prfx then (emptyDerivation a:) else id) + [ prepend (a, rEnv) d | (rEnv, b, new) <- firstsOrd prfx, d <- rec b new ] + firstsOrd = map f . firstsOrdered cmp + where + cmp = cmpRule `on` (fst . g . fst) + + f ((stp, b), new) = (g stp, b, new) + + g stp = (stepRule stp, stepEnvironment stp) + -- | Returns a list of all major rules that are part of a labeled strategy rulesInStrategy :: IsStrategy f => f a -> [Rule a] -rulesInStrategy f = [ r | Rule r <- universe (toCore (toStrategy f)), isMajor r ] +rulesInStrategy s = [ r | Rule r <- universe (toCore s), isMajor r ] instance LiftView LabeledStrategy where liftViewIn = mapRules . liftViewIn @@ -212,10 +157,7 @@ mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b mapRulesS f = S . fmap f . toCore -{- -mapRulesM :: Monad m => (Rule a -> m (Rule a)) -> Strategy a -> m (Strategy a) -mapRulesM f = liftM S . T.mapM f . toCore --} + -- | Use a function as do-after hook for all rules in a labeled strategy, but -- also use the function beforehand cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a @@ -238,11 +180,14 @@ ----------------------------------------------------------- --- Functions to lift the core combinators -fromCore :: Core LabelInfo a -> Strategy a +toCore :: IsStrategy f => f a -> Core a +toCore s = let S core = toStrategy s in core + +fromCore :: Core a -> Strategy a fromCore = S -liftCore :: IsStrategy f => (Core LabelInfo a -> Core LabelInfo a) -> f a -> Strategy a -liftCore f = fromCore . f . toCore . toStrategy +liftCore :: IsStrategy f => (Core a -> Core a) -> f a -> Strategy a +liftCore f = fromCore . f . toCore -liftCore2 :: (IsStrategy f, IsStrategy g) => (Core LabelInfo a -> Core LabelInfo a -> Core LabelInfo a) -> f a -> g a -> Strategy a -liftCore2 f = liftCore . f . toCore . toStrategy+liftCore2 :: (IsStrategy f, IsStrategy g) => (Core a -> Core a -> Core a) -> f a -> g a -> Strategy a +liftCore2 f = liftCore . f . toCore
+ src/Ideas/Common/Strategy/Choice.hs view
@@ -0,0 +1,232 @@+----------------------------------------------------------------------------- +-- Copyright 2015, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A type class with an implementation for expressing choice and left-biased +-- choice. +-- +----------------------------------------------------------------------------- +-- $Id: Sequential.hs 6598 2014-06-04 14:59:01Z bastiaan $ + +module Ideas.Common.Strategy.Choice + ( -- * Choice type class + Choice(..) + -- * Menu data type + , Menu, eqMenuBy + -- * Queries + , elems, bests, bestsOrdered, isEmpty, getByIndex + -- * Generalized functions + , onMenu, cut, cutOn, mapWithIndex + ) where + +import Data.Maybe (listToMaybe) + +infixr 3 <|>, >|>, |>, :|:, :>|, :|> + +------------------------------------------------------------------------ +-- Choice type class + +-- | Laws: '<|>', '>|>' '|>' are all associative, and have 'empty' as their +-- unit element. +class Choice f where + -- | Nothing to choose from. + empty :: f a + -- | One element. + single :: a -> f a + -- | Normal (unbiased) choice. + (<|>) :: f a -> f a -> f a + -- | Left-preference. + (>|>) :: f a -> f a -> f a + -- | Left-biased choice. + (|>) :: f a -> f a -> f a + -- | One element from a list (unbiased). + oneof :: [a] -> f a + -- | One of the alternatives in a list (unbiased). + choice :: [f a] -> f a + -- default implementation + oneof = choice . map single + choice xs + | null xs = empty + | otherwise = foldr1 (<|>) xs + +instance Choice [] where + empty = [] + single = return + (<|>) = (++) + (>|>) = (++) + xs |> ys = if null xs then ys else xs + oneof = id + choice = concat + +------------------------------------------------------------------------ +-- Menu data type + +-- Invariants for the Menu datatype: +-- (Unit) The left-hand side of :|: and :|> cannot be Empty +-- (Asso) :|: and :|> are balanced to the right + +-- | A menu offers choices and preferences. It is an instance of the 'Functor' +-- and 'Monad' type classes. +data Menu a = Single a + | Empty + | Menu a :|: Menu a + | Menu a :>| Menu a -- left-preference + | Menu a :|> Menu a -- left-biased + +instance Eq a => Eq (Menu a) where + (==) = eqMenuBy (==) + +instance Choice Menu where + empty = Empty + single = Single + + p0 <|> rest = rec p0 -- maintain invariant + where + rec Empty = rest + rec (p :|: q) = p :|: rec q + rec p = case rest of -- strict: also check rhs + Empty -> p + _ -> p :|: rest + + p0 >|> rest = rec p0 -- maintain invariant + where + rec Empty = rest + rec (p :>| q) = p :>| rec q + rec p = p :>| rest + + p0 |> rest = rec p0 -- maintain invariant + where + rec Empty = rest + rec (p :|> q) = p :|> rec q + rec p = p :|> rest + +instance Functor Menu where + fmap f p = p >>= (Single . f) + +instance Monad Menu where + return = single + fail _ = empty + (>>=) = flip onMenu + +-- | Equality with a comparison function for the elements +eqMenuBy :: (a -> a -> Bool) -> Menu a -> Menu a -> Bool +eqMenuBy eq = test + where + test (p1 :|: p2) (q1 :|: q2) = test p1 q1 && test p2 q2 + test (p1 :>| p2) (q1 :>| q2) = test p1 q1 && test p2 q2 + test (p1 :|> p2) (q1 :|> q2) = test p1 q1 && test p2 q2 + test (Single a) (Single b) = eq a b + test Empty Empty = True + test (p :>| Empty) q = test p q + test (p :|> Empty) q = test p q + test p (q :>| Empty) = test p q + test p (q :|> Empty) = test p q + test _ _ = False + +------------------------------------------------------------------------ +-- Queries + +-- | Returns all elements that are in the menu. +elems :: Menu a -> [a] +elems = ($ []) . rec + where + rec (p :|: q) = rec p . rec q + rec (p :>| q) = rec p . rec q + rec (p :|> q) = rec p . rec q + rec (Single p) = (p:) + rec Empty = id + +-- | Returns only the best elements that are in the menu. +bests :: Menu a -> [a] +bests (p :|: q) = bests p ++ bests q +bests (p :>| q) = bests p ++ bests q +bests (p :|> q) = bests p |> bests q +bests (Single a) = [a] +bests Empty = [] + +-- | Returns only the best elements that are in the menu, with a given ordering. +bestsOrdered :: (a -> a -> Ordering) -> Menu a -> [a] +bestsOrdered cmp = rec + where + rec (p :|: q) = merge (rec p) (rec q) + rec (p :>| q) = rec p ++ rec q + rec (p :|> q) = rec p |> rec q + rec (Single a) = [a] + rec Empty = [] + + -- merge two lists with comparison function + merge lx@(x:xs) ly@(y:ys) + | cmp x y == GT = y : merge lx ys + | otherwise = x : merge xs ly + merge [] ys = ys + merge xs [] = xs + +-- | Is the menu empty? +isEmpty :: Menu a -> Bool +isEmpty Empty = True +isEmpty _ = False -- because of invariant + +-- | Get an element from the menu by its index. +getByIndex :: Int -> Menu a -> Maybe a +getByIndex n = listToMaybe . drop n . elems + +------------------------------------------------------------------------ +-- Generalized functions + +-- | Generalized monadic bind, with the arguments flipped. +{-# INLINE onMenu #-} +onMenu :: Choice f => (a -> f b) -> Menu a -> f b +onMenu f = rec + where + rec (p :|: q) = rec p <|> rec q + rec (p :>| q) = rec p >|> rec q + rec (p :|> q) = rec p |> rec q + rec (Single a) = f a + rec Empty = empty + +-- | Only keep the best elements in the menu. +{-# INLINE cut #-} +cut :: Choice f => Menu a -> f a +cut (p :|: q) = cut p <|> cut q +cut (p :>| q) = cut p >|> cut q +cut (p :|> _) = cut p +cut (Single a) = single a +cut Empty = empty + +cutOn :: Choice f => (a -> Bool) -> Menu a -> f a +cutOn f = snd . rec + where + rec (p :|: q) = let (b1, cp) = rec p + (b2, cq) = rec q + in (b1 || b2, cp <|> cq) + rec (p :>| q) = let (b1, cp) = rec p + (b2, cq) = rec q + in (b1 || b2, cp >|> cq) + rec (p :|> q) = let (b1, cp) = rec p + (b2, cq) = rec q + in (b1 || b2, if b1 then cp else cp |> cq) + rec (Single a) = (f a, single a) + rec Empty = (False, empty) + +-- | Maps a function over a menu that also takes the index of an element. +{-# INLINE mapWithIndex #-} +mapWithIndex :: Choice f => (Int -> a -> f b) -> Menu a -> f b +mapWithIndex f = snd . rec 0 + where + rec n (p :|: q) = let (n1, pn) = rec n p + (n2, qn) = rec n1 q + in (n2, pn <|> qn) + rec n (p :>| q) = let (n1, pn) = rec n p + (n2, qn) = rec n1 q + in (n2, pn >|> qn) + rec n (p :|> q) = let (n1, pn) = rec n p + (n2, qn) = rec n1 q + in (n2, pn |> qn) + rec n (Single a) = (n+1, f n a) + rec n Empty = (n, empty)
src/Ideas/Common/Strategy/Combinators.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,18 +12,16 @@ -- data types -- ----------------------------------------------------------------------------- --- $Id: Combinators.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Combinators.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Strategy.Combinators where import Data.Array import Data.Graph import Data.List ((\\)) -import Ideas.Common.Classes import Ideas.Common.Id import Ideas.Common.Rule import Ideas.Common.Strategy.Abstract -import Ideas.Common.Strategy.Configuration import Ideas.Common.Strategy.Core import Ideas.Common.Utils (fst3) import Prelude hiding (not, repeat, fail, sequence) @@ -36,7 +34,7 @@ infixr 2 <%>, <@> infixr 3 <|> -infixr 4 |> +infixr 4 >|>, |> infixr 5 <*> -- | Put two strategies in sequence (first do this, then do that) @@ -111,9 +109,7 @@ -- | Check whether or not the argument strategy cannot be applied: the result -- strategy only succeeds if this is not the case (otherwise it fails). not :: IsStrategy f => f a -> Strategy a -not s = check (Prelude.not . applicable (toStrategy s)) - --- liftCore (Not . noLabels) +not = liftCore Not -- | Repeat a strategy zero or more times (greedy version of 'many') repeat :: IsStrategy f => f a -> Strategy a @@ -127,10 +123,16 @@ try :: IsStrategy f => f a -> Strategy a try s = s |> succeed +-- | Choose between the two strategies, with a preference for steps from the +-- left hand-side strategy. +(>|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +(>|>) = liftCore2 (:>|>) + -- | Left-biased choice: if the left-operand strategy can be applied, do so. Otherwise, -- try the right-operand strategy (|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a (|>) = liftCore2 (:|>:) +-- s |> t = s <|> (not s <*> t) -- | Repeat the strategy as long as the predicate holds while :: IsStrategy f => (a -> Bool) -> f a -> Strategy a @@ -141,8 +143,8 @@ until p = while (Prelude.not . p) -- | Apply a strategy at least once, but collapse into a single step -multi :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a -multi s = collapse . label s . repeat1 +multi :: (IsId l, IsStrategy f) => l -> f a -> Strategy a +multi l = collapse . label l . repeat1 -- | Apply the strategies from the list exhaustively (until this is no longer possible) exhaustive :: IsStrategy f => [f a] -> Strategy a @@ -152,6 +154,15 @@ -- (but dangerous) combinator fix :: (Strategy a -> Strategy a) -> Strategy a fix f = fromCore (coreFix (toCore . f . fromCore)) + +remove :: IsStrategy f => f a -> Strategy a +remove = liftCore Remove + +collapse :: IsStrategy f => f a -> Strategy a +collapse = liftCore Collapse + +hide :: IsStrategy f => f a -> Strategy a +hide = liftCore Hide -- Graph to strategy ----------------------
src/Ideas/Common/Strategy/Configuration.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,108 +9,100 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Configuration.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Configuration.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Strategy.Configuration - ( -- Types and constructors - StrategyConfiguration, makeStrategyConfiguration - , ConfigItem, ConfigLocation, byName, byGroup - , ConfigAction(..), configActions - -- Configure - , configure, configureNow - -- Combinators - , remove, reinsert, collapse, expand, hide, reveal + ( StrategyCfg, byName, ConfigAction(..) + , configure, configureS + , module Data.Monoid ) where -import Data.Maybe -import Ideas.Common.Classes +import Data.Char +import Data.Monoid import Ideas.Common.Id import Ideas.Common.Strategy.Abstract -import Ideas.Common.Strategy.Core +import Ideas.Common.Strategy.Core hiding (Remove, Collapse, Hide) +import Ideas.Common.Utils.Uniplate +import qualified Ideas.Common.Strategy.Core as Core --------------------------------------------------------------------- -- Types and constructors -newtype StrategyConfiguration = SC { configItems :: [ConfigItem] } - deriving Show +newtype StrategyCfg = Cfg [(ConfigLocation, ConfigAction)] -makeStrategyConfiguration :: [ConfigItem] -> StrategyConfiguration -makeStrategyConfiguration = SC +instance Show StrategyCfg where + show (Cfg xs) = show xs -type ConfigItem = (ConfigLocation, ConfigAction) +instance Monoid StrategyCfg where + mempty = Cfg [] + mconcat xs = Cfg [ y | Cfg ys <- xs, y <- ys ] + mappend (Cfg xs) (Cfg ys) = Cfg (xs ++ ys) -data ConfigLocation - = ByName Id - | ByGroup Id - deriving Show +data ConfigLocation = ByName Id +instance Show ConfigLocation where + show (ByName a) = show a + data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal - deriving (Show, Enum) + deriving (Show, Eq) -configActions :: [ConfigAction] -configActions = [Remove .. ] +instance Read ConfigAction where + readsPrec _ s = + let f = map toLower + in [ (x, "") | x <- concat actionGroups, f s == f (show x) ] -byName :: HasId a => a -> ConfigLocation -byName = ByName . getId +actionGroups :: [[ConfigAction]] +actionGroups = [[Remove, Reinsert], [Collapse, Expand], [Hide, Reveal]] -byGroup :: HasId a => a -> ConfigLocation -byGroup = ByGroup . getId +byName :: HasId a => ConfigAction -> a -> StrategyCfg +byName action a = Cfg [(ByName (getId a), action)] --------------------------------------------------------------------- -- Configure -configureNow :: LabeledStrategy a -> LabeledStrategy a -configureNow = - let lsToCore = toCore . toStrategy - coreToLS = fromMaybe err . toLabeledStrategy . fromCore - err = error "configureNow: label disappeared" - in coreToLS . processLabelInfo id . lsToCore - -configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a -configure cfg ls = - label (getId ls) (fromCore (configureCore cfg (toCore (unlabel ls)))) +configure :: StrategyCfg -> LabeledStrategy a -> LabeledStrategy a +configure cfg ls = label (getId ls) (configureS cfg (unlabel ls)) -configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a -configureCore cfg = mapFirst (change []) - where - change groups info = - let actions = getActions info groups cfg - in foldr doAction info actions +configureS :: StrategyCfg -> Strategy a -> Strategy a +configureS cfg = fromCore . configureCore cfg . toCore -getActions :: LabelInfo -> [String] - -> StrategyConfiguration -> [ConfigAction] -getActions info groups = map snd . filter (select . fst) . configItems +configureCore :: StrategyCfg -> Core a -> Core a +configureCore (Cfg pairs) = rec where - select (ByName a) = getId info == a - select (ByGroup s) = showId s `elem` groups - -doAction :: ConfigAction -> LabelInfo -> LabelInfo -doAction action = - case action of - Remove -> setRemoved True - Reinsert -> setRemoved False - Collapse -> setCollapsed True - Expand -> setCollapsed False - Hide -> setHidden True - Reveal -> setHidden False - ---------------------------------------------------------------------- --- Configuration combinators + rec core = + case core of + Core.Remove s | has Reinsert -> rec s + Core.Collapse s | has Expand -> rec s + Core.Hide s | has Reveal -> rec s + Label l s -> props (Label l (rec s)) + Rule r -> props (Rule r) + _ -> descend rec core + where + myLabel = getLabel core + actions = cancel [ a | (loc, a) <- pairs, maybe False (here loc) myLabel ] + has = (`elem` actions) + make x g = if has x then g else id -remove, reinsert :: IsLabeled f => f a -> LabeledStrategy a -remove = changeInfo (doAction Remove) -reinsert = changeInfo (doAction Reinsert) + props = make Remove Core.Remove + . make Hide Core.Hide + . make Collapse Core.Collapse -collapse, expand :: IsLabeled f => f a -> LabeledStrategy a -collapse = changeInfo (doAction Collapse) -expand = changeInfo (doAction Expand) +here :: ConfigLocation -> Id -> Bool +here (ByName a) info = getId info == a -hide, reveal :: IsLabeled f => f a -> LabeledStrategy a -hide = changeInfo (doAction Hide) -reveal = changeInfo (doAction Reveal) +getLabel :: Core a -> Maybe Id +getLabel (Label l _) = Just l +getLabel (Rule r) = Just (getId r) +getLabel (Core.Remove s) = getLabel s +getLabel (Core.Collapse s) = getLabel s +getLabel (Core.Hide s) = getLabel s +getLabel _ = Nothing --- helpers -setRemoved, setCollapsed, setHidden :: Bool -> LabelInfo -> LabelInfo -setRemoved b info = info {removed = b} -setCollapsed b info = info {collapsed = b} -setHidden b info = info {hidden = b}+cancel :: [ConfigAction] -> [ConfigAction] +cancel [] = [] +cancel (x:xs) = x : cancel (rec actionGroups) + where + rec (g:gs) + | x `elem` g = filter (`notElem` g) xs + | otherwise = rec gs + rec [] = xs
src/Ideas/Common/Strategy/Core.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,19 +13,19 @@ -- directly on it. -- ----------------------------------------------------------------------------- --- $Id: Core.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Core.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Strategy.Core ( GCore(..), Core - , coreFix, coreSubstAll - , noLabels, substCoreVar + , coreFix, coreSubstAll, substCoreVar ) where import Data.Maybe import Ideas.Common.Classes +import Ideas.Common.Id import Ideas.Common.Rule -import Ideas.Common.Strategy.Sequential -import Ideas.Common.Utils.QuickCheck +import Ideas.Common.Strategy.Choice +import Ideas.Common.Strategy.Sequence import Ideas.Common.Utils.Uniplate ----------------------------------------------------------------- @@ -33,98 +33,107 @@ -- of combinators infixr 2 :%:, :@: -infixr 3 :|:, :|>: +infixr 3 :|:, :>|>, :|>: infixr 5 :*: -- | Core expression, with rules -type Core l a = GCore l (Rule a) +type Core a = GCore (Rule a) -- | An environment with generalized Core expressions -type CoreEnv l a = [(Int, GCore l a)] +type CoreEnv a = [(Int, GCore a)] -- | A generalized Core expression, not restricted to rules. This makes GCore -- a (traversable and foldable) functor. -data GCore l a - = GCore l a :*: GCore l a - | GCore l a :|: GCore l a - | GCore l a :|>: GCore l a - | GCore l a :%: GCore l a -- interleave - | GCore l a :@: GCore l a -- alternate - | Label l (GCore l a) - | Atomic (GCore l a) +data GCore a + = GCore a :*: GCore a + | GCore a :|: GCore a + | GCore a :>|> GCore a -- left-preference (choice) + | GCore a :|>: GCore a -- left-biased choice + | GCore a :%: GCore a -- interleave + | GCore a :@: GCore a -- alternate + | Label Id (GCore a) + | Atomic (GCore a) + | Not (GCore a) + | Remove (GCore a) -- config: replaced by fail + | Collapse (GCore a) -- config: execute labeled sub-strategy as 1 step + | Hide (GCore a) -- config: make all steps invisible/minor | Succeed | Fail | Rule a -- ^ Generalized constructor (not restricted to rules) | Var Int - | Let (CoreEnv l a) (GCore l a) + | Let (CoreEnv a) (GCore a) deriving Show -instance Sequential (GCore l) where - ok = Succeed - stop = Fail +instance Choice GCore where + empty = Fail single = Rule (<|>) = (:|:) - (<?>) = (:|>:) - (<*>) = (:*:) + (>|>) = (:>|>) + (|>) = (:|>:) +instance Sequence GCore where + done = Succeed + (~>) = (:*:) . Rule + (<*>) = (:*:) + ----------------------------------------------------------------- -- Useful instances -instance Functor (GCore l) where - fmap = mapSecond - -instance Uniplate (GCore l a) where - uniplate core = - case core of - a :*: b -> plate (:*:) |* a |* b - a :|: b -> plate (:|:) |* a |* b - a :|>: b -> plate (:|>:) |* a |* b - a :%: b -> plate (:%:) |* a |* b - a :@: b -> plate (:@:) |* a |* b - Label l a -> plate Label |- l |* a - Atomic a -> plate Atomic |* a - Let ds a -> let (ns, bs) = unzip ds - make = Let . zip ns - in plate make ||* bs |* a - _ -> plate core - -instance BiFunctor GCore where - biMap f g = rec +instance Functor GCore where + fmap f = rec where rec core = case core of - a :*: b -> rec a :*: rec b - a :|: b -> rec a :|: rec b - a :|>: b -> rec a :|>: rec b - a :%: b -> rec a :%: rec b - a :@: b -> rec a :@: rec b - Atomic a -> Atomic (rec a) - Let ds a -> Let (map (mapSecond rec) ds) (rec a) - Label l a -> Label (f l) (rec a) - Rule a -> Rule (g a) - Var n -> Var n - Succeed -> Succeed - Fail -> Fail + a :*: b -> rec a :*: rec b + a :|: b -> rec a :|: rec b + a :>|> b -> rec a :>|> rec b + a :|>: b -> rec a :|>: rec b + a :%: b -> rec a :%: rec b + a :@: b -> rec a :@: rec b + Atomic a -> Atomic (rec a) + Not a -> Not (rec a) + Remove a -> Remove (rec a) + Collapse a -> Collapse (rec a) + Hide a -> Hide (rec a) + Let ds a -> Let (map (mapSecond rec) ds) (rec a) + Label l a -> Label l (rec a) + Rule a -> Rule (f a) + Var n -> Var n + Succeed -> Succeed + Fail -> Fail -instance (Arbitrary l, Arbitrary a) => Arbitrary (GCore l a) where - arbitrary = generators - [ constGens [Succeed, Fail] - , unaryGen Atomic, arbGen Rule, unaryArbGen Label - , binaryGens [(:*:), (:|:), (:%:)] - ] +instance Uniplate (GCore a) where + uniplate core = + case core of + a :*: b -> plate (:*:) |* a |* b + a :|: b -> plate (:|:) |* a |* b + a :>|> b -> plate (:>|>) |* a |* b + a :|>: b -> plate (:|>:) |* a |* b + a :%: b -> plate (:%:) |* a |* b + a :@: b -> plate (:@:) |* a |* b + Label l a -> plate Label |- l |* a + Atomic a -> plate Atomic |* a + Not a -> plate Not |* a + Remove a -> plate Remove |* a + Collapse a -> plate Collapse |* a + Hide a -> plate Hide |* a + Let ds a -> let (ns, bs) = unzip ds + make = Let . zip ns + in plate make ||* bs |* a + _ -> plate core ----------------------------------------------------------------- -- Definitions -coreFix :: (GCore l a -> GCore l a) -> GCore l a +coreFix :: (GCore a -> GCore a) -> GCore a coreFix f = -- disadvantage: function f is applied twice let i = nextVar (f (Var (-1))) in coreRec i (f (Var i)) -coreRec :: Int -> GCore l a -> GCore l a +coreRec :: Int -> GCore a -> GCore a coreRec n a = Let [(n, a)] (Var n) -coreSubstAll :: GCore l a -> GCore l a +coreSubstAll :: GCore a -> GCore a coreSubstAll = rec [] where rec xs (Var i) = fromMaybe (error "coreInf") (lookup i xs) @@ -135,27 +144,23 @@ ----------------------------------------------------------------- -- Utility functions -substCoreVar :: Int -> GCore l a -> GCore l a -> GCore l a +substCoreVar :: Int -> GCore a -> GCore a -> GCore a substCoreVar i a core = case core of Var j | i==j -> a Let ds _ | i `elem` map fst ds -> core _ -> descend (substCoreVar i a) core -nextVar :: GCore l a -> Int +nextVar :: GCore a -> Int nextVar p | null xs = 0 | otherwise = maximum xs + 1 where xs = coreVars p -coreVars :: GCore l a -> [Int] +coreVars :: GCore a -> [Int] coreVars core = case core of Var n -> [n] Let ds a -> let (ns, bs) = unzip ds in ns ++ concatMap coreVars (bs ++ [a]) - _ -> concatMap coreVars (children core) - -noLabels :: GCore l a -> GCore l a -noLabels (Label _ a) = noLabels a -noLabels core = descend noLabels core+ _ -> concatMap coreVars (children core)
+ src/Ideas/Common/Strategy/Derived.hs view
@@ -0,0 +1,62 @@+----------------------------------------------------------------------------- +-- Copyright 2015, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +-- $Id: Sequential.hs 6612 2014-06-12 07:57:59Z bastiaan $ + +module Ideas.Common.Strategy.Derived + ( filterP, hide + , fromAtoms, Sym(..), atomic, concurrent, (<@>) + ) where + +import Ideas.Common.Strategy.Choice +import Ideas.Common.Strategy.Process +import Ideas.Common.Strategy.Sequence + +useFirst :: Choice f => (a -> Process a -> f b) -> f b -> Process a -> f b +useFirst op e = onMenu (menuItem e op) . menu + +filterP :: (a -> Bool) -> Process a -> Process a +filterP cond = fold (\a q -> if cond a then a ~> q else empty) done + +hide :: (a -> Bool) -> Process a -> Process a +hide cond = fold (\a q -> if cond a then a ~> q else q) done + +data Sym a = Single a | Composed (Process a) + +fromAtoms :: Process (Sym a) -> Process a +fromAtoms = fold f done + where + f (Single a) = (a ~>) + f (Composed p) = (p <*>) + +atomic :: IsProcess f => f (Sym a) -> f (Sym a) +atomic = single . Composed . fromAtoms . toProcess + +concurrent :: IsProcess f => (a -> Bool) -> f a -> f a -> f a +concurrent switch x y = normal (toProcess x) (toProcess y) + where + normal p q = stepBoth q p <|> (stepRight q p <|> stepRight p q) + + stepBoth = useFirst stop2 . useFirst stop2 done + stop2 _ _ = empty + + stepRight p = useFirst op empty + where + op a = (a ~>) . (if switch a then normal else stepRight) p + +-- Alternate combinator +(<@>) :: IsProcess f => f a -> f a -> f a +p0 <@> q0 = rec (toProcess q0) (toProcess p0) + where + rec q = useFirst (\a r -> a ~> rec r q) (bothOk q) + bothOk = useFirst (\_ _ -> empty) done + +---------------------------------------------------------------------------
src/Ideas/Common/Strategy/Location.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,14 +11,15 @@ -- Locations in a strategy -- ----------------------------------------------------------------------------- --- $Id: Location.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Location.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Strategy.Location - ( subTaskLocation, nextTaskLocation - , strategyLocations, subStrategy + ( checkLocation, subTaskLocation, nextTaskLocation + , strategyLocations ) where import Data.Maybe +import Ideas.Common.Classes import Ideas.Common.Id import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Core @@ -27,6 +28,10 @@ ----------------------------------------------------------- --- Strategy locations +checkLocation :: Id -> LabeledStrategy a -> Bool +checkLocation loc = + any ((==loc) . getId . snd) . strategyLocations + -- old (current) and actual (next major rule) location subTaskLocation :: LabeledStrategy a -> Id -> Id -> Id subTaskLocation s xs ys = g (rec (f xs) (f ys)) @@ -50,27 +55,19 @@ | otherwise = [j] rec _ _ = [] --- | Returns a list of all strategy locations, paired with the labeled --- substrategy at that location -strategyLocations :: LabeledStrategy a -> [([Int], LabeledStrategy a)] -strategyLocations s = ([], s) : rec [] (toCore (unlabel s)) +-- | Returns a list of all strategy locations, paired with the label +strategyLocations :: LabeledStrategy a -> [([Int], Id)] +strategyLocations s = ([], getId s) : rec [] (toCore (unlabel s)) where rec is = concat . zipWith make (map (:is) [0..]) . collect - make is (l, core) = - let ls = makeLabeledStrategy l (fromCore core) - in (is, ls) : rec is core + make is (l, mc) = (is, l) : maybe [] (rec is) mc collect core = case core of - Label l t -> [(l, t)] + Label l c -> [(l, Just c)] + Rule r | isMajor r -> [(getId r, Nothing)] _ -> concatMap collect (children core) - --- | Returns the substrategy or rule at a strategy location. Nothing --- indicates that the location is invalid -subStrategy :: Id -> LabeledStrategy a -> Maybe (LabeledStrategy a) -subStrategy loc = - fmap snd . listToMaybe . filter ((==loc) . getId . snd) . strategyLocations fromLoc :: LabeledStrategy a -> [Int] -> Maybe Id fromLoc s loc = fmap getId (lookup loc (strategyLocations s))
src/Ideas/Common/Strategy/Parsing.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -8,147 +9,253 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- Basic machinery for executing a core strategy expression. +-- Basic machinery for fully executing a core strategy expression, or only +-- partially. Partial execution results in a prefix that keeps the current +-- locations in the strategy (a list of @Path@s) for continuing the execution +-- later on. A path can be used to reconstruct the sequence of steps already +-- performed (a so-called trace). Prefixes can be merged with the Monoid +-- operation. -- ----------------------------------------------------------------------------- --- $Id: Parsing.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Parsing.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Strategy.Parsing - ( Step(..) - , ParseState, makeState, choices, trace - , parseDerivationTree, replay, runCore, searchModeState, toProcess + ( -- * Running @Core@ strategies + runCore + -- * Prefix + , Prefix, noPrefix, makePrefix, replayCore + , isEmptyPrefix, majorPrefix, searchModePrefix, prefixPaths + -- * Step + , Step(..), stepRule, stepEnvironment + -- * Path + , Path, emptyPath, readPath, readPaths ) where -import Data.Function (on) -import Data.Monoid +import Control.Monad +import Data.Function +import Data.List import Ideas.Common.Classes -import Ideas.Common.DerivationTree import Ideas.Common.Environment +import Ideas.Common.Id import Ideas.Common.Rule +import Ideas.Common.Strategy.Choice import Ideas.Common.Strategy.Core -import Ideas.Common.Strategy.Path -import Ideas.Common.Strategy.Sequential hiding (replay) -import Ideas.Common.Utils (fst3) -import qualified Ideas.Common.Strategy.Sequential as Sequential - ----------------------------------------------------------------------- --- Step data type +import Ideas.Common.Strategy.Derived +import Ideas.Common.Strategy.Process +import Ideas.Common.Strategy.Sequence +import Ideas.Common.Utils (fst3, splitsWithElem, readM) +import Ideas.Common.Utils.Uniplate -data Step l a = Enter l | Exit l | RuleStep Environment (Rule a) - deriving (Eq) +-------------------------------------------------------------------------------- +-- Running Core strategies -instance Show (Step l a) where - show (Enter _) = "Enter" - show (Exit _) = "Exit" - show (RuleStep _ r) = show r +-- | Run a @Core@ strategy and return all results. +runCore :: Core a -> a -> [a] +runCore core a = bests $ accum applyAll a $ coreToProcess False core --- A core expression where the symbols are steps instead of "only" rules --- type StepCore l a = GCore l (Step l a) +coreToProcess :: Bool -> Core a -> Process (Step a) +coreToProcess useLabels = fromAtoms . toProcess . rec . coreSubstAll + where + rec :: Core a -> Builder (Sym (Step a)) + rec core = + case core of + a :*: b -> rec a <*> rec b + a :|: b -> rec a <|> rec b + a :>|> b -> rec a >|> rec b + a :|>: b -> rec a |> rec b + Rule r -> single (Single (RuleStep mempty r)) + Fail -> empty + Succeed -> done + Label l a + | useLabels -> Single (Enter l) ~> rec a + <*> single (Single (Exit l)) + | otherwise -> rec a + a :%: b -> concurrent switch (rec a) (rec b) + a :@: b -> rec a <@> rec b + Atomic a -> atomic (rec a) + Not a -> notCore a + Remove _ -> empty + Collapse a -> rec (collapse a) + Hide a -> rec (fmap minor a) + Let _ _ -> error "not substituted: let" + Var _ -> error "not substituted: var" -instance Apply (Step l) where - applyAll (RuleStep _ r) = applyAll r - applyAll _ = return + switch (Single (Enter _)) = False + switch _ = True -instance Minor (Step l a) where - setMinor b (RuleStep env r) = RuleStep env (setMinor b r) - setMinor _ step = step +collapse :: Core a -> Core a +collapse (Label l s) = Rule $ makeRule l (runCore s) +collapse core = descend collapse core - isMinor (RuleStep _ r) = isMinor r - isMinor _ = True +notCore :: Core a -> Builder (Sym (Step a)) +notCore core = single $ Single $ RuleStep mempty $ + checkRule "core.not" $ null . runCore core ----------------------------------------------------------------------- --- State data type +-------------------------------------------------------------------------------- +-- Prefix datatype -data ParseState l a = S - { trace :: [Step l a] - , choices :: Path - , remainder :: Process (Step l a, a, Path) +data Prefix a = Prefix + { getPaths :: [Path] + , remainder :: Process (Step a, a, Path) } -makeState :: a -> Core l a -> ParseState l a -makeState a = S [] emptyPath . applyMin a . withPath . toProcess - ----------------------------------------------------------------------- --- Parse derivation tree +instance Show (Prefix a) where + show = intercalate ";" . map show . prefixPaths -parseDerivationTree :: a -> ParseState l a -> DerivationTree (Step l a) (a, ParseState l a) -parseDerivationTree = curry (makeTree next) - where - next (_, st) = (empty (remainder st), stateFirsts st (remainder st)) +instance Monoid (Prefix a) where + mempty = noPrefix + mappend (Prefix xs p) (Prefix ys q) = Prefix (xs ++ ys) (p <|> q) - stateFirsts st p = - [ ( step - , (a, st {trace = step:trace st, remainder = q, choices = path}) - ) - | ((step, a, path), q) <- Sequential.firsts p - ] +instance Firsts (Prefix a) where + type Elem (Prefix a) = (Step a, a) -searchModeState :: (Step l a -> Bool) -> (Step l a -> Step l a -> Bool) -> ParseState l a -> ParseState l a -searchModeState p eq state = - state { remainder = tidyProcess eq' (not . p') $ - uniquePath p' eq' (remainder state) } - where - eq' = eq `on` fst3 - p' = p . fst3 + menu = fmap f . menu . remainder + where + f Done = Done + f ((st, a, path) :~> p) = (st, a) :~> Prefix [path] p ----------------------------------------------------------------------- --- Running the parser +-------------------------------------------------------------------------------- +-- Constructing a prefix -runCore :: Core l a -> a -> [a] -runCore = runProcess . toProcess . noLabels - where - runProcess p a = rec a (applyMin2 a p) +-- | The error prefix (i.e., without a location in the strategy). +noPrefix :: Prefix a +noPrefix = Prefix [] empty - rec a p = - (if empty p then (a:) else id) - [ c - | ((_, b), q) <- firsts p - , c <- rec b q - ] +-- | Make a prefix from a core strategy and a start term. +makePrefix :: Core a -> a -> Prefix a +makePrefix = snd . replayCore emptyPath ------------------------------ +-- | Construct a prefix by replaying a path in a core strategy: the third +-- argument is the current term. +replayCore :: Path -> Core a -> ([Step a], a -> Prefix a) +replayCore path core = + let (acc, p) = runPath path (withPath (coreToProcess True core)) + in (map fst acc, Prefix [path] . applySteps p) -toProcess :: Core l a -> Process (Step l a) -toProcess = fromAtoms . build . rec . coreSubstAll +runPath :: Path -> Process a -> ([a], Process a) +runPath (Path is) = rec [] is where - rec core = - case core of - a :*: b -> rec a <*> rec b - a :|: b -> rec a <|> rec b - Rule r -> single (Single (RuleStep mempty r)) - a :|>: b -> rec a <?> rec b - Fail -> stop - Succeed -> ok - Label l a -> Single (Enter l) ~> rec a - <*> single (Single (Exit l)) - a :%: b -> concurrent switch (build (rec a)) (build (rec b)) - a :@: b -> build (rec a) <@> build (rec b) - Atomic a -> atomic (build (rec a)) - Let _ _ -> error "toMin: let" - Var _ -> error "toMin: var" - - switch (Single (Enter _)) = False - switch _ = True + rec acc [] p = (reverse acc, p) + rec acc (n:ns) p = + case getByIndex n (menu p) of + Just (a :~> r) -> rec (a:acc) ns r + _ -> ([], empty) -applyMin2 :: a -> Process (Step l a) -> Process (Step l a, a) -applyMin2 a0 = prune (isMajor . fst) . scanChoice step a0 +applySteps :: Process (Step a, Path) -> a -> Process (Step a, a, Path) +applySteps p a0 = prune (isMajor . fst3) (scan f a0 p) where - step a (RuleStep _ r) = - [ (b, (RuleStep env r, b)) + f a (RuleStep _ r, path) = + [ (b, (RuleStep env r, b, path)) | (b, env) <- transApply (transformation r) a ] - step a st = [(a, (st, a))] + f a (st, path) = [(a, (st, a, path))] -applyMin :: a -> Process (Step l a, Path) -> Process (Step l a, a, Path) -applyMin a0 = prune (isMajor . fst3) . scanChoice step a0 +withPath :: Process a -> Process (a, Path) +withPath = rec [] where - step a (RuleStep _ r, bs) = - [ (b, (RuleStep env r, b, bs)) - | (b, env) <- transApply (transformation r) a - ] - step a (st, bs) = [(a, (st, a, bs))] + rec ns = mapWithIndex (menuItem done . f ns) . menu -replay :: Monad m => Path -> a -> Core l a -> m (ParseState l a) -replay path a core = do - (as, p) <- Sequential.replay path $ withPath $ toProcess core - return (S (map fst as) path (applyMin a p))+ f ns n a p = + let ms = n:ns + in (a, Path (reverse ms)) ~> rec ms p + +-------------------------------------------------------------------------------- +-- Prefix fuctions + +isEmptyPrefix :: Prefix a -> Bool +isEmptyPrefix = all (== emptyPath) . getPaths + +-- | Transforms the prefix such that only major steps are kept in the remaining +-- strategy. +majorPrefix :: Prefix a -> Prefix a +majorPrefix prfx = prfx { remainder = hide (isMajor . fst3) (remainder prfx) } + +-- | The searchModePrefix transformation changes the process in such a way that +-- all intermediate states can only be reached by one path. A prerequisite is +-- that symbols are unique (or only used once). +searchModePrefix :: (Step a -> Step a -> Bool) -> Prefix a -> Prefix a +searchModePrefix eq prfx = + prfx { remainder = rec (remainder (majorPrefix prfx)) } + where + eq3 = eq `on` fst3 + + rec p | ready p = done + | otherwise = process (firsts p) + + process [] = empty + process ((a, p):xs) = + let ys = map fst $ firsts (a ~> p) + in (a ~> rec p) <|> process (concatMap (change ys) xs) + + change ys (a, q) = + let f x = all (not . eq3 x) ys + in firsts $ filterP f (a ~> q) + +-- | Returns the current @Path@. +prefixPaths :: Prefix a -> [Path] +prefixPaths = getPaths + +-------------------------------------------------------------------------------- +-- Step + +-- | The steps during the parsing process: enter (or exit) a labeled +-- sub-strategy, or a rule. +data Step a = Enter Id -- ^ Enter a labeled sub-strategy + | Exit Id -- ^ Exit a labeled sub-strategy + | RuleStep Environment (Rule a) -- ^ Rule that was applied + deriving Eq + +instance Show (Step a) where + show (Enter l) = "enter " ++ showId l + show (Exit l) = "exit " ++ showId l + show (RuleStep _ r) = show r + +instance Apply Step where + applyAll (RuleStep _ r) = applyAll r + applyAll _ = return + +instance HasId (Step a) where + getId (Enter l) = getId l + getId (Exit l) = getId l + getId (RuleStep _ r) = getId r + + changeId f (Enter l) = Enter (changeId f l) + changeId f (Exit l) = Exit (changeId f l) + changeId f (RuleStep env r) = RuleStep env (changeId f r) + +instance Minor (Step a) where + setMinor b (RuleStep env r) = RuleStep env (setMinor b r) + setMinor _ st = st + + isMinor (RuleStep _ r) = isMinor r + isMinor _ = True + +stepRule :: Step a -> Rule a +stepRule (RuleStep _ r) = r +stepRule (Enter l) = idRule (l # "enter") +stepRule (Exit l) = idRule (l # "exit") + +stepEnvironment :: Step a -> Environment +stepEnvironment (RuleStep env _) = env +stepEnvironment _ = mempty + +-------------------------------------------------------------------------------- +-- Path + +-- | A path encodes a location in a strategy. Paths are represented as a list +-- of integers. +newtype Path = Path [Int] + deriving Eq + +instance Show Path where + show (Path is) = show is + +-- | The empty path. +emptyPath :: Path +emptyPath = Path [] + +readPath :: Monad m => String -> m Path +readPath = liftM Path . readM + +readPaths :: Monad m => String -> m [Path] +readPaths = mapM readPath . splitsWithElem ';'
− src/Ideas/Common/Strategy/Path.hs
@@ -1,70 +0,0 @@------------------------------------------------------------------------------ --- Copyright 2014, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A path encodes a location (sub-part) of a strategy by: --- * maintaining a list of directions (go left/go right) for each choice; --- * the depth (number of steps) --- Use Show/Read type classes for serialization/deserialization --- ------------------------------------------------------------------------------ --- $Id: Path.hs 6535 2014-05-14 11:05:06Z bastiaan $ - -module Ideas.Common.Strategy.Path - ( -- * datatype and constructor - Path, emptyPath - -- * extending a path - , toLeft, toRight, tick - -- * following a path - , leftOrRight, untick - ) where - -import Data.Foldable (toList) -import Data.Sequence (Seq, empty, (|>), viewl, ViewL(..), fromList) -import Ideas.Common.Classes - -data Path = Path !Int (Seq Bool) -- depth, choices - deriving Eq - -instance Show Path where - show = show . intList - -instance Read Path where - readsPrec _ = map (mapFirst fromIntList) . readList - -emptyPath :: Path -emptyPath = Path 0 empty - -toLeft, toRight, tick :: Path -> Path -toLeft (Path n bs) = Path (n+1) (bs |> True) -toRight (Path n bs) = Path (n+1) (bs |> False) -tick (Path n bs) = Path (n+1) bs - --- |Following a path without going left or right (counterpart of 'tick') -untick :: Monad m => Path -> m Path -untick (Path n bs) - | n > 0 = return (Path (n-1) bs) - | otherwise = fail "untick: invalid path" - -leftOrRight :: Monad m => Path -> m (Either Path Path) -leftOrRight (Path n bs) = - case viewl bs of - b :< cs | n > 0 && b -> return (Left (Path (n-1) cs)) - | n > 0 -> return (Right (Path (n-1) cs)) - _ -> fail "untick: invalid path" - --- local helpers -intList :: Path -> [Int] -intList (Path n bs) - | n == 0 = [] - | otherwise = n : map (\b -> if b then 0 else 1) (toList bs) - -fromIntList :: [Int] -> Path -fromIntList [] = emptyPath -fromIntList (n:is) = Path n (fromList (map (==0) is))
− src/Ideas/Common/Strategy/Prefix.hs
@@ -1,75 +0,0 @@------------------------------------------------------------------------------ --- Copyright 2014, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A prefix encodes a sequence of steps already performed (a so-called trace), --- and allows to continue the derivation at that particular point. --- ------------------------------------------------------------------------------ --- $Id: Prefix.hs 6535 2014-05-14 11:05:06Z bastiaan $ - -module Ideas.Common.Strategy.Prefix - ( Prefix, emptyPrefix, makePrefix, showPrefix - , prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix, activeLabels - , searchModePrefix - ) where - -import Data.List -import Data.Maybe -import Ideas.Common.DerivationTree -import Ideas.Common.Rule -import Ideas.Common.Strategy.Abstract -import Ideas.Common.Strategy.Parsing -import Ideas.Common.Strategy.Path - ------------------------------------------------------------ ---- Prefixes - --- | Abstract data type for a (labeled) strategy with a prefix (a sequence of --- executed rules). A prefix is still "aware" of the labels that appear in the --- strategy. A prefix is encoded as a list of integers (and can be reconstructed --- from such a list: see @makePrefix@). The list is stored in reversed order. -type Prefix = ParseState LabelInfo - -showPrefix :: Prefix a -> String -showPrefix = show . choices - --- | Construct the empty prefix for a labeled strategy -emptyPrefix :: LabeledStrategy a -> a -> Prefix a -emptyPrefix a = fromMaybe (error "emptyPrefix") . makePrefix emptyPath a - --- | Construct a prefix for a given list of integers and a labeled strategy. -makePrefix :: Monad m => Path -> LabeledStrategy a -> a -> m (Prefix a) -makePrefix path = flip (replay path) . mkCore - where - mkCore = processLabelInfo id . toCore . toStrategy - --- | Create a derivation tree with a "prefix" as annotation. -prefixTree :: a -> Prefix a -> DerivationTree (Prefix a) a -prefixTree a = fmap fst . updateAnnotations (\_ _ -> snd) . parseDerivationTree a - -searchModePrefix :: (Step LabelInfo a -> Bool) -> (Step LabelInfo a -> Step LabelInfo a -> Bool) -> Prefix a -> Prefix a -searchModePrefix = searchModeState - -prefixToSteps :: Prefix a -> [Step LabelInfo a] -prefixToSteps = reverse . trace - --- | Retrieves the rules from a list of steps -stepsToRules :: [Step l a] -> [Rule a] -stepsToRules xs = [ r | RuleStep _ r <- xs ] - --- | Returns the last rule of a prefix (if such a rule exists) -lastStepInPrefix :: Prefix a -> Maybe (Step LabelInfo a) -lastStepInPrefix = listToMaybe . trace - --- | Calculate the active labels -activeLabels :: Prefix a -> [LabelInfo] -activeLabels p = nub [l | Enter l <- steps] \\ [l | Exit l <- steps] - where - steps = prefixToSteps p
+ src/Ideas/Common/Strategy/Process.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- Copyright 2015, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Processes must support choices and sequences. This module defines a type +-- class, an implementation, and utility functions. +-- +----------------------------------------------------------------------------- +-- $Id: Process.hs 7524 2015-04-08 07:31:15Z bastiaan $ + +module Ideas.Common.Strategy.Process + ( -- * IsProcess type class + IsProcess(..) + -- * Process data type + , Process, menu, eqProcessBy + -- * Building sequences + , Builder + -- * Query functions on a Process + , ready, stopped, firsts + -- * Higher-order functions for iterating over a Process + , fold, accum, scan, prune + ) where + +import Ideas.Common.Strategy.Choice +import Ideas.Common.Strategy.Sequence + +------------------------------------------------------------------------ +-- IsProcess type class + +class (Choice f, Sequence f) => IsProcess f where + -- | Convert to the 'Process' data type. + toProcess :: f a -> Process a + +------------------------------------------------------------------------ +-- Process data type + +-- | This datatype implements choices and sequences, but is slow for +-- building sequences with the '<*>' combinator. See the 'Builder' data +-- type for a faster alternative. +newtype Process a = P (Menu (MenuItem a (Process a))) + +instance Eq a => Eq (Process a) where + (==) = eqProcessBy (==) + +instance Functor Process where + fmap f (P m) = P (fmap g m) + where + g Done = Done + g (a :~> p) = f a :~> fmap f p + +instance Choice Process where + single a = P (single (a :~> P (single Done))) + empty = P empty + P x <|> P y = P (x <|> y) + P x >|> P y = P (x >|> y) + P x |> P y = P (x |> y) + +instance Sequence Process where + done = P (return Done) + a ~> p = P (return (a :~> p)) + + p0 <*> P rest = rec p0 + where + rec (P m) = P $ do + st <- m -- cutOn (menuItem True (\_ _ -> False)) m + case st of + a :~> p -> return (a :~> rec p) + Done -> rest + +instance IsProcess Process where + toProcess = id + +instance Firsts (Process a) where + type Elem (Process a) = a + + menu (P m) = m + +-- | Generalized equality of processes, which takes an equality function for +-- the symbols. +eqProcessBy :: (a -> a -> Bool) -> Process a -> Process a -> Bool +eqProcessBy eq = rec + where + rec p q = eqMenuBy eqStep (menu p) (menu q) + + eqStep (a :~> p) (b :~> q) = eq a b && rec p q + eqStep Done Done = True + eqStep _ _ = False + +------------------------------------------------------------------------ +-- Building sequences + +-- | The 'Builder' data type offers a fast implementation for building +-- sequences. The data type implements the 'IsProcess' type class. +-- A 'Builder' value must be converted to a 'Process' (with 'toProcess') +-- it can be inspected in any way. + +newtype Builder a = B (Process a -> Process a) + +instance Choice Builder where + single a = B (a ~>) + empty = B (const empty) + B f <|> B g = B (\p -> f p <|> g p) + B f >|> B g = B (\p -> f p >|> g p) + B f |> B g = B (\p -> f p |> g p) + +instance Sequence Builder where + done = B id + a ~> B f = B ((a ~>) . f) + B f <*> B g = B (f . g) + +instance IsProcess Builder where + toProcess (B f) = f done + +------------------------------------------------------------------------ +-- Higher-order functions for iterating over a Process + +-- | Folding over a process takes a function for single steps and for 'done'. +{-# INLINE fold #-} +fold :: Choice f => (a -> f b -> f b) -> f b -> Process a -> f b +fold op e = rec + where + rec = onMenu (menuItem e (\a -> op a . rec)) . menu + +{-# INLINE accum #-} +accum :: (a -> b -> [b]) -> b -> Process a -> Menu b +accum f = rec + where + rec b p = menu p >>= g + where + g Done = single b + g (a :~> q) = choice [ rec b2 q | b2 <- f a b ] + +{-# INLINE scan #-} +scan :: (s -> a -> [(s, b)]) -> s -> Process a -> Process b +scan op = rec + where + rec s = + let f a q = choice [ b ~> rec s2 q | (s2, b) <- op s a ] + in onMenu (menuItem done f) . menu + +-- fail early +prune :: (a -> Bool) -> Process a -> Process a +prune f = fold op done + where + op a p + | not (f a) && stopped np = empty + | otherwise = a ~> np + where + np = P (cut (menu p))
+ src/Ideas/Common/Strategy/Sequence.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- Copyright 2015, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A type class for sequences together with the 'Step' datatype. +-- +----------------------------------------------------------------------------- +-- $Id: Sequential.hs 6612 2014-06-12 07:57:59Z bastiaan $ + +module Ideas.Common.Strategy.Sequence + ( -- * Sequence type class + Sequence(..) + -- * Firsts type class + , Firsts(..), firstsMenu, firstsOrdered, firstsTree, stopped + -- * MenuItem data type with some utility functions + , MenuItem(..), menuItem, isDone + ) where + +import Data.Function +import Ideas.Common.Classes +import Ideas.Common.DerivationTree +import Ideas.Common.Strategy.Choice + +infixr 5 :~>, ~>, <*> + +------------------------------------------------------------------------ +-- Sequence type class + +class Sequence f where + -- | The empty sequence. + done :: f a + -- | Prefix a sequence with one element. + (~>) :: a -> f a -> f a + -- | Append two sequences. + (<*>) :: f a -> f a -> f a + +------------------------------------------------------------------------ +-- Firsts type class + +class Firsts s where + -- | The type associated with a step in the first set. + type Elem s + -- | The ready predicate (we are done). + ready :: s -> Bool + ready = any isDone . bests . menu + -- | The first set. + firsts :: s -> [(Elem s, s)] + firsts = bests . firstsMenu + -- | The menu offers single steps (with the remainder) and 'done' steps. + menu :: s -> Menu (MenuItem (Elem s) s) + +firstsMenu :: Firsts s => s -> Menu (Elem s, s) +firstsMenu s = do + item <- cut (menu s) + case item of + a :~> t -> return (a, t) + Done -> empty + +firstsOrdered :: Firsts s => (Elem s -> Elem s -> Ordering) + -> s -> [(Elem s, s)] +firstsOrdered cmp = bestsOrdered (cmp `on` fst) . firstsMenu + +firstsTree :: Firsts s => s -> DerivationTree (Elem s) s +firstsTree x = addBranches bs tr + where + tr = singleNode x (ready x) + bs = [ (a, firstsTree y) | (a, y) <- firsts x ] + +-- | Not ready and no further steps to take. +stopped :: Firsts s => s -> Bool +stopped = isEmpty . menu + +------------------------------------------------------------------------ +-- MenuItem data type with some utility functions + +data MenuItem a s = a :~> s -- ^ A single step. + | Done -- ^ No step (we are done). + +instance Functor (MenuItem a) where + fmap = mapSecond + +instance BiFunctor MenuItem where + biMap f g = menuItem Done (\a s -> f a :~> g s) + +-- | The 'menuItem' function takes a default value for 'Done' and a function +-- to combine the values for a single step. +menuItem :: b -> (a -> s -> b) -> MenuItem a s -> b +menuItem b _ Done = b +menuItem _ f (a :~> x) = f a x + +-- | Is the item 'done'? +isDone :: MenuItem a s -> Bool +isDone Done = True +isDone _ = False
− src/Ideas/Common/Strategy/Sequential.hs
@@ -1,326 +0,0 @@------------------------------------------------------------------------------ --- Copyright 2014, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ --- $Id: Sequential.hs 6535 2014-05-14 11:05:06Z bastiaan $ - -module Ideas.Common.Strategy.Sequential - ( Sequential(..) - , Process - , Builder, build - , empty, firsts, scanChoice, prune - , fromAtoms - , Sym(..) - , atomic, concurrent, (<@>) - , withPath, replay - , uniquePath, tidyProcess - ) where - -import Ideas.Common.Strategy.Path - -class Sequential f where - ok, stop :: f a - single :: a -> f a - (~>) :: a -> f a -> f a - (<|>) :: f a -> f a -> f a - (<?>) :: f a -> f a -> f a - (<*>) :: f a -> f a -> f a - choice :: [f a] -> f a - -- default implementation - single a = a ~> ok - a ~> p = single a <*> p - p <?> q = p <|> q -- angelic by default - choice = foldr (<|>) stop - -infixr 3 :~>, ~> - -data Process a - = Process a :|: Process a -- choice (p or q) - | Process a :?: Process a -- non-deterministic choice (behaves as either p or q) - | a :~> Process a -- prefix (a then p) - | Ok -- successful termination - | Stop -- failure - deriving (Show, Eq) - -instance Sequential Process where - ok = Ok - stop = Stop - (~>) = (:~>) - (<?>) = (:?:) - (<|>) = (:|:) - - p <*> Ok = p - p <*> q = fold (Alg (<|>) (:?:) (:~>) q Stop) p - -newtype Builder a = B (Process a -> Process a) - -instance Sequential Builder where - ok = B id - stop = B (const Stop) - single a = B (a ~>) - a ~> B f = B ((a ~>) . f) - - B f <|> B g = B (\p -> f p <|> g p) - B f <?> B g = B (\p -> f p <?> g p) - B f <*> B g = B (f . g) - -build :: Builder a -> Process a -build (B f) = f Ok - -{- -data Menu a = Menu { empty :: Bool, firstsSeq :: S.Seq (a, Menu a) } - -firsts :: Menu a -> [(a, Menu a)] -firsts = toList . firstsSeq - -instance Sequential Menu where - ok = Menu True S.empty - stop = Menu False S.empty - a ~> m = Menu False (S.singleton (a, m)) - - Menu b1 xs <|> Menu b2 ys = Menu (b1 || b2) (xs <> ys) - - Menu b xs <*> m - | b = m <|> ys - | otherwise = ys - where - ys = Menu b $ fmap (\(a, p) -> (a, p <*> m)) xs -} - -data Alg a b = Alg - { forChoice :: b -> b -> b - , forEither :: b -> b -> b - , forPrefix :: a -> b -> b - , forOk :: b - , forStop :: b - } - -{- -instance Monoid (Process a) where - mempty = stop - mappend = (<|>) -} - ---instance Functor Process where --- fmap f = fold (Alg (:|:) (:?:) ((:~>) . f) Ok Stop) - -{- -instance Monad Process where - return = (:~> ok) - fail _ = Stop - p >>= f = fold (Alg (:|:) (:?:) ((<*>) . f) Ok Stop) p -} - -fold :: Alg a b -> Process a -> b -fold alg = rec - where - rec (p :|: q) = forChoice alg (rec p) (rec q) - rec (p :?: q) = forEither alg (rec p) (rec q) - rec (a :~> p) = forPrefix alg a (rec p) - rec Ok = forOk alg - rec Stop = forStop alg - - {- -join :: Process (Process a) -> Process a -join = fold (Alg (:|:) (:?:) (<*>) Ok Stop) --} - --- angelic for non-deterministic choice -empty :: Process a -> Bool -empty = fold $ Alg (||) (||) (\_ _ -> False) True False - --- angelic for non-deterministic choice -firsts :: Process a -> [(a, Process a)] -firsts = ($ []) . rec - where - rec (p :|: q) = rec p . rec q - rec (p :?: q) = rec p . rec q - rec (a :~> p) = ((a, p):) - rec Ok = id - rec Stop = id - -{- -run :: Process a -> [[a]] -run p = - [ [] | empty p ] ++ - [ a:as | (a, q) <- firsts p, as <- run q ] -} - -scanChoice :: (a -> b -> [(a, c)]) -> a -> Process b -> Process c -scanChoice f = rec - where - rec a (p :|: q) = rec a p :|: rec a q - rec a (p :?: q) = rec a p :?: rec a q - rec a (b :~> p) = choice [ c :~> rec a2 p | (a2, c) <- f a b ] - rec _ Ok = Ok - rec _ Stop = Stop - --- remove left-biased choice -prune :: (a -> Bool) -> Process a -> Process a -prune f = fst . fold Alg - { forChoice = \ ~(p, b1) ~(q, b2) -> (p <|> q, b1 || b2) - , forEither = \p q -> if snd p then p else q - , forPrefix = \a ~(p, b) -> (a ~> p, f a || b) - , forOk = (ok, True) - , forStop = (stop, False) - } - -useFirst :: Sequential f => (a -> Process a -> f b) -> f b -> Process a -> f b -useFirst op e = rec - where - rec (p :|: q) = rec p <|> rec q - rec (p :?: q) = rec p <?> rec q - rec (a :~> p) = op a p - rec Ok = e - rec Stop = stop - -data Sym a = Single a | Composed (Process a) - -fromAtoms :: Process (Sym a) -> Process a -fromAtoms (Single a :~> q) = a ~> fromAtoms q -fromAtoms (Composed p :~> q) = p <*> fromAtoms q -fromAtoms (p :|: q) = fromAtoms p <|> fromAtoms q -fromAtoms (p :?: q) = fromAtoms p <?> fromAtoms q -fromAtoms Ok = ok -fromAtoms Stop = stop - -atomic :: Sequential f => Process (Sym a) -> f (Sym a) -atomic = single . Composed . fromAtoms - -concurrent :: Sequential f => (a -> Bool) -> Process a -> Process a -> f a -concurrent switch = normal - where - normal p q = stepBoth q p <|> (stepRight q p <|> stepRight p q) - - stepBoth = useFirst stop2 . useFirst stop2 ok - stop2 _ _ = stop - - stepRight p = useFirst op stop - where - op a = (a ~>) . (if switch a then normal else stepRight) p - --- Alternate combinator -(<@>) :: Sequential f => Process a -> Process a -> f a -p <@> q = useFirst (\a r -> a ~> (q <@> r)) bothOk p - where - bothOk = useFirst (\_ _ -> stop) ok q - --------------------------------- -{- -abc, de :: Process Char -abc = 'a' :~> 'b' :~> 'c' :~> ok -de = 'd' :~> 'e' :~> ok - -go = run (concurrent undefined undefined abc de) - -indep :: Char -> Char -> Bool -indep x y = x `elem` "abc" && y `elem` "def" - -(%) :: Sequential f => Process a -> Process a -> f a -(%) = concurrent (const True) --} -withPath :: Process a -> Process (a, Path) -withPath = rec emptyPath - where - rec path (p :|: q) = rec (toLeft path) p :|: rec (toRight path) q - rec path (p :?: q) = rec (toLeft path) p :?: rec (toRight path) q - rec path (a :~> p) = let next = tick path - in (a, next) :~> rec next p - rec _ Ok = Ok - rec _ Stop = Stop - -replay :: Monad m => Path -> Process a -> m ([a], Process a) -replay = flip (rec []) - where - rec acc process path - | path == emptyPath = return (acc, process) - | otherwise = - case process of - p :|: q -> choose p q - p :?: q -> choose p q - a :~> p -> untick path >>= rec (a:acc) p - _ -> fail "replay: invalid path" - where - choose p q = leftOrRight path >>= either (rec acc p) (rec acc q) - --------------------------------- - -filterP :: (a -> Bool) -> Process a -> Process a -filterP p = fold idAlg - { forPrefix = \a q -> if p a then a ~> q else stop } - -idAlg :: Sequential f => Alg a (f a) -idAlg = Alg - { forChoice = (<|>) - , forEither = (<?>) - , forPrefix = (~>) - , forOk = ok - , forStop = stop - } - -tidyProcess :: (a -> a -> Bool) -> (a -> Bool) -> Process a -> Process a -tidyProcess eq cond = step2 . step1 - where - step1 = fold idAlg { forChoice = rmChoiceUnitZero - , forPrefix = rmPrefix - } - - step2 = fold idAlg { forChoice = rmSameChoice } - - rmChoiceUnitZero p q = - case (p, q) of - (Stop, _) -> q - (_, Stop) -> p - (Ok, _) -> ok - (_, Ok) -> ok - _ -> p <|> q - - rmPrefix a p | cond a = p - | otherwise = a ~> p - - rmSameChoice p q = if cmpProcesses eq p q - then p - else p <|> q - --- | Structural comparison of processes -cmpProcesses :: (a -> b -> Bool) -> Process a -> Process b -> Bool -cmpProcesses f = rec - where - rec (p :|: q) (r :|: s) = rec p r && rec q s - rec (p :?: q) (r :?: s) = rec p r && rec q s - rec (a :~> p) (b :~> q) = f a b && rec p q - rec Ok Ok = True - rec Stop Stop = True - rec _ _ = False - --- | The uniquePath transformation changes the process in such a way that all --- intermediate states can only be reached by one path. A prerequisite is that --- symbols are unique (or only used once). -uniquePath :: (a -> Bool) -> (a -> a -> Bool) -> Process a -> Process a -uniquePath cond eq = rec - where - rec (p :|: q) = let f x = not $ any (eq x) (map fst $ firstsWith cond p) - in rec p <|> rec (filterP f q) - rec (p :?: q) = rec p :?: rec q - rec (a :~> p) = a :~> rec p - rec Ok = Ok - rec Stop = Stop - -{- -prefixes :: Process a -> [[a]] -prefixes p = concatMap (\(a, q) -> [a] : (map (a:) $ prefixes q)) $ firsts p - ---uniquePath_prop :: Eq a => Process a -> Property -uniquePath_prop pred eq = unique_prop . prefixes . uniquePath pred eq - where - unique_prop xs = forAll (elements xs) $ \x -> filter (== x) xs == [x] -} - --- | This functions returns the first symbols that hold for predicate p -firstsWith :: (a -> Bool) -> Process a -> [(a, Process a)] -firstsWith p = concatMap f . firsts - where - f (r, q) | p r = [(r, q)] - | otherwise = firstsWith p q
− src/Ideas/Common/Strategy/Tests.hs
@@ -1,183 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- Copyright 2014, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Testing strategy combinator properties --- ------------------------------------------------------------------------------ --- $Id: Tests.hs 6535 2014-05-14 11:05:06Z bastiaan $ - -module Ideas.Common.Strategy.Tests (tests) where - -import Data.Function -import Data.List -import Data.Ord -import Ideas.Common.Algebra.Group -import Ideas.Common.Algebra.GroupLaws -import Ideas.Common.Algebra.Law -import Ideas.Common.Classes -import Ideas.Common.Strategy -import Ideas.Common.Strategy.Abstract -import Ideas.Common.Strategy.Parsing -import Ideas.Common.Utils.QuickCheck hiding (label, Result) -import Ideas.Common.Utils.TestSuite -import Prelude hiding (fail) -import qualified Ideas.Common.Algebra.Field as F -import qualified Ideas.Common.Algebra.FieldLaws as F - ---------------------------------------------------------- --- Properties - -tests :: TestSuite -tests = suite "Strategy combinator properties" - [ -- monoids and semi-rings - fs (commutative : idempotent : monoidLaws :: [Law Choice]) - , fs (monoidZeroLaws :: [Law Sequence]) - , fs (commutative : monoidZeroLaws :: [Law Interleave]) - , fs (F.distributiveLaws :: [Law Sequence]) - , fs (F.distributiveLaws :: [Law Interleave]) - - -- properties of atomic - , useProperty "atomic-twice" $ \a -> - atomic (atomic a) === atomic (idS a) - , assertTrue "atomic-succeed" $ - atomic succeed === succeed - , assertTrue "atomic-fail" $ - atomic fail === fail - , useProperty "atomic-choice" $ \a b -> - atomic (idS a <|> idS b) === atomic a <|> atomic b - - -- splits theorm parallel/atomic - , useProperty "atomic-split" $ \x y a b -> - (atomic x <*> a) <%> (atomic y <*> b) - === - (idS x <*> (a <%> (atomic y <*> b))) - <|> - (idS y <*> ((atomic x <*> idS a) <%> idS b)) - ] - where - fs :: (Arbitrary a, Show a, Eq a) => [Law a] -> TestSuite - fs ps = mconcat [ useProperty (show p) p | p <- ps ] - ---------------------------------------------------------- --- Algebraic instances - -newtype Choice = Choice (Strategy Int) deriving (Show, Arbitrary) -newtype Sequence = Sequence (Strategy Int) deriving (Show, Arbitrary) -newtype Interleave = Interleave (Strategy Int) deriving (Show, Arbitrary) - -instance Eq Choice where Choice a == Choice b = a === b -instance Eq Sequence where Sequence a == Sequence b = a === b -instance Eq Interleave where Interleave a == Interleave b = a === b - -instance Monoid Choice where - mempty = Choice fail - mappend (Choice a) (Choice b) = Choice (a <|> b) - -instance Monoid Sequence where - mempty = Sequence succeed - mappend (Sequence a) (Sequence b) = Sequence (a <*> b) - -instance MonoidZero Sequence where - mzero = Sequence fail - -instance Monoid Interleave where - mempty = Interleave succeed - mappend (Interleave a) (Interleave b) = Interleave (a <%> b) - -instance MonoidZero Interleave where - mzero = Interleave fail - -instance F.SemiRing Sequence where - Sequence a <+> Sequence b = Sequence (a <|> b) - zero = Sequence fail - (<*>) = mappend - one = mempty - -instance F.SemiRing Interleave where - Interleave a <+> Interleave b = Interleave (a <|> b) - zero = Interleave fail - (<*>) = mappend - one = mempty - ---------------------------------------------------------- --- Helper functions for equality - -idS :: Strategy Int -> Strategy Int -idS = id - -infix 1 === - -(===) :: Strategy Int -> Strategy Int -> Bool -s1 === s2 = rec 100 [(start s1, start s2)] - where - start = return . makeState 0 . toCore - - rec :: Int -> [([ParseState LabelInfo Int], [ParseState LabelInfo Int])] -> Bool - rec _ [] = True - rec n (pair:rest) - | n == 0 = True - | otherwise = testReady xs ys - && testFirsts gxs gys - && rec (n-1) (rest ++ new) - - where - p@(xs, ys) = mapBoth (concatMap myFirsts) pair - gp@(gxs, gys) = mapBoth f p - new = uncurry zip (mapBoth (map snd) gp) - - testReady = (==) `on` any (isReady . fst) - testFirsts = (==) `on` map fst - - f = map merge . groupBy eqFst . sortBy cmpFst . results - merge as = (fst (head as), map snd as) - results as = [ (a, b) | (a, b) <- as ] - - cmpFst = comparing (show . fst) - eqFst = (==) `on` fst - -firsts :: Bool -> ParseState l a -> [(Step l a, ParseState l a)] -firsts = undefined -- fix me - -isReady :: Step l a -> Bool -isReady = undefined -- fix me - -myFirsts :: ParseState l a -> [(Step l a, ParseState l a)] -myFirsts = concatMap f . firsts False - where - f pair@(result, a) = - case result of - Enter _ -> myFirsts a - Exit _ -> myFirsts a - _ -> [pair] - -{- -debug :: Show a => Strategy a -> a -> IO () -debug s = rec . makeState (toCore s) - where - rec st = do - print st - putStrLn $ "\nReady: " ++ show (any (isReady . fst) xs) - putStrLn $ unlines $ - zipWith (\i y -> show i ++ ". " ++ show (fst y)) [1::Int ..] ys - if (null xs) then print "(no choices)" else do - n <- ask - rec (snd (ys !! n)) - where - xs = firsts st - ys = [ (a, b) | (Result a, b) <- xs ] - - ask = do - putStr "? " - input <- getLine - case readInt input of - Just n | n > 0 && n <= length ys -> - return (n-1) - _ -> if input == "q" then error "QUIT" else ask -}
src/Ideas/Common/Strategy/Traversal.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Traversal.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Traversal.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Strategy.Traversal ( layer, traverse, Option @@ -19,6 +19,7 @@ , traversalFilter, parentFilter -- * One-pass traversals , fulltd, fullbu, oncetd, oncebu, leftmostbu, leftmosttd, somewhere + , oncetdPref, oncebuPref -- * Fixpoint traversals , innermost, outermost , ruleDown, ruleDownLast, ruleUp @@ -77,13 +78,16 @@ OrElse | getTopDown tr -> s |> descend a | otherwise -> descend a |> s + Prefer + | getTopDown tr -> s >|> descend a + | otherwise -> descend a >|> s Choice -> s <|> descend a where descend = layerWith tr ----------------------------------------------------------------------- -data Combinator = Sequence | OrElse | Choice +data Combinator = Sequence | OrElse | Choice | Prefer data Info a = Info { getVisit :: Visit @@ -146,8 +150,14 @@ oncetd :: (IsStrategy f, Navigator a) => f a -> Strategy a oncetd = traverse [once, topdown] +oncetdPref :: (IsStrategy f, Navigator a) => f a -> Strategy a +oncetdPref = traverse [setCombinator Prefer, once, topdown] + oncebu :: (IsStrategy f, Navigator a) => f a -> Strategy a oncebu = traverse [once, bottomup] + +oncebuPref :: (IsStrategy f, Navigator a) => f a -> Strategy a +oncebuPref = traverse [setCombinator Prefer, once, bottomup] leftmostbu :: (IsStrategy f, Navigator a) => f a -> Strategy a leftmostbu = traverse [setCombinator OrElse, setVisit VisitFirst, bottomup]
src/Ideas/Common/Traversal/Iterator.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Iterator.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Iterator.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Traversal.Iterator ( -- * Iterator type class
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Navigator.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Navigator.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Traversal.Navigator ( -- * Location information
src/Ideas/Common/Traversal/Tests.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Tests.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Tests.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Traversal.Tests ( testIterator, testNavigator, tests
src/Ideas/Common/Traversal/Utils.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Utils.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Utils.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Traversal.Utils ( -- * Update type class
src/Ideas/Common/Utils.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- A collection of general utility functions -- ----------------------------------------------------------------------------- --- $Id: Utils.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Utils.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Utils ( Some(..), ShowString(..), readInt, readM
src/Ideas/Common/Utils/QuickCheck.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Extensions to the QuickCheck library -- ----------------------------------------------------------------------------- --- $Id: QuickCheck.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: QuickCheck.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Utils.QuickCheck ( module Test.QuickCheck
src/Ideas/Common/Utils/StringRef.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,7 +15,7 @@ -- Virutal Machine (LVM) identifiers. -- ----------------------------------------------------------------------------- --- $Id: StringRef.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: StringRef.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Utils.StringRef ( StringRef, stringRef, toString, tableStatus
src/Ideas/Common/Utils/TestSuite.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,7 +14,7 @@ -- is a monoid. -- ----------------------------------------------------------------------------- --- $Id: TestSuite.hs 6541 2014-05-14 18:44:36Z bastiaan $ +-- $Id: TestSuite.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Utils.TestSuite ( -- * TestSuite
src/Ideas/Common/Utils/Uniplate.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- class and its utility plus constructor functions) -- ----------------------------------------------------------------------------- --- $Id: Uniplate.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Uniplate.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.Utils.Uniplate ( -- * Uniplate type class and utility functions
src/Ideas/Common/View.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,7 @@ -- in Interactive Exercise Assistants" -- ----------------------------------------------------------------------------- --- $Id: View.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: View.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Common.View ( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..)
src/Ideas/Encoding/DecoderJSON.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,121 +12,116 @@ -- Services using JSON notation -- ----------------------------------------------------------------------------- --- $Id: DecoderJSON.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: DecoderJSON.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.DecoderJSON - ( JSONDecoder, JSONDecoderState(..), jsonDecoder + ( JSONDecoder, jsonDecoder ) where import Control.Monad -import Ideas.Common.Library hiding (exerciseId) -import Ideas.Encoding.Evaluator -import Ideas.Service.FeedbackScript.Syntax (Script) +import Data.Maybe +import Ideas.Common.Library hiding (exerciseId, symbol) +import Ideas.Common.Traversal.Navigator +import Ideas.Encoding.Encoder import Ideas.Service.State import Ideas.Service.Types hiding (String) import Ideas.Text.JSON -import System.Random hiding (getStdGen) import qualified Ideas.Service.Types as Tp -type JSONDecoder a = EncoderState (JSONDecoderState a) JSON - -data JSONDecoderState a = JSONDecoderState - { getExercise :: Exercise a - , getScript :: Script - , getStdGen :: StdGen - } +type JSONDecoder a = Decoder a JSON -jsonDecoder :: Type a t -> JSONDecoder a t -jsonDecoder tp = encoderFor $ \json -> +jsonDecoder :: TypedDecoder a JSON +jsonDecoder tp = decoderFor $ \json -> case json of - Array xs -> liftM fst (decodeType tp // xs) + Array xs -> decodeType tp // xs _ -> fail "expecting an array" -decodeType :: Type a t -> EncoderState (JSONDecoderState a) [JSON] (t, [JSON]) +decodeType :: Type a t -> Decoder a [JSON] t decodeType tp = case tp of Tag _ t -> decodeType t - Iso p t -> change (from p) (decodeType t) + Iso p t -> liftM (from p) (decodeType t) Pair t1 t2 -> do - (a, xs) <- decodeType t1 - (b, ys) <- decodeType t2 // xs - return ((a, b), ys) + a <- decodeType t1 + b <- decodeType t2 + return (a, b) t1 :|: t2 -> - change Left (decodeType t1) `mplus` - change Right (decodeType t2) - Unit -> result () - Const StdGen -> withState getStdGen >>= result - Const Script -> withState getScript >>= result - Const t -> encoderFor $ \xs -> - case xs of - hd:tl -> do a <- decodeConst t // hd - return (a, tl) - _ -> fail "no more elements" + liftM Left (decodeType t1) `mplus` + liftM Right (decodeType t2) + Unit -> return () + Const StdGen -> getStdGen + Const Script -> getScript + Const t -> symbol >>= \a -> decodeConst t // a _ -> fail $ "No support for argument type: " ++ show tp - where - result a = simpleEncoder (\xs -> (a, xs)) - change f = liftM (first f) decodeConst :: Const a t -> JSONDecoder a t decodeConst tp = case tp of State -> decodeState Context -> decodeContext - Exercise -> withState getExercise + Exercise -> getExercise Environment -> decodeEnvironment Location -> decodeLocation - Int -> maybeEncoder fromJSON - Tp.String -> maybeEncoder fromJSON + Int -> decoderFor fromJSON + Tp.String -> decoderFor fromJSON Id -> decodeId Rule -> decodeRule _ -> fail $ "No support for argument type: " ++ show tp decodeRule :: JSONDecoder a (Rule (Context a)) decodeRule = do - ex <- withState getExercise - encoderFor $ \json -> + ex <- getExercise + decoderFor $ \json -> case json of String s -> getRule ex (newId s) _ -> fail "expecting a string for rule" decodeId :: JSONDecoder a Id -decodeId = encoderFor $ \json -> +decodeId = decoderFor $ \json -> case json of String s -> return (newId s) _ -> fail "expecting a string for id" decodeLocation :: JSONDecoder a Location -decodeLocation = encoderFor $ \json -> +decodeLocation = decoderFor $ \json -> case json of String s -> liftM toLocation (readM s) _ -> fail "expecting a string for a location" decodeState :: JSONDecoder a (State a) decodeState = do - ex <- withState getExercise - encoderFor $ \json -> + ex <- getExercise + decoderFor $ \json -> case json of - Array [a] -> decodeState // a + Array [a] -> setInput a >> decodeState Array [String _code, pref, term, jsonContext] -> do - iss <- decodePrefixes // pref + pts <- decodePaths // pref a <- decodeTerm // term env <- decodeEnvironment // jsonContext - let ctx = setEnvironment env (inContext ex a) - ps <- mapM (\is -> makePrefix is (strategy ex) ctx) iss - return $ makeState ex ps ctx + let loc = envToLoc env + ctx = navigateTowards loc $ deleteRef locRef $ + setEnvironment env $ inContext ex a + prfx = replayPaths pts (strategy ex) ctx + return $ makeState ex prfx ctx _ -> fail $ "invalid state" ++ show json -decodePrefixes :: JSONDecoder a [Path] -decodePrefixes = - encoderFor $ \json -> +envToLoc :: Environment -> Location +envToLoc env = toLocation $ fromMaybe [] $ locRef ? env >>= readM + +locRef :: Ref String +locRef = makeRef "location" + +decodePaths :: JSONDecoder a [Path] +decodePaths = + decoderFor $ \json -> case json of - String p -> mapM readM (deintercalate p) + String p -> readPaths p _ -> fail "invalid prefixes" decodeEnvironment :: JSONDecoder a Environment -decodeEnvironment = encoderFor $ \json -> +decodeEnvironment = decoderFor $ \json -> case json of - String "" -> decodeEnvironment // Object [] + String "" -> return mempty Object xs -> foldM (flip add) mempty xs _ -> fail $ "invalid context: " ++ show json where @@ -135,21 +130,13 @@ decodeContext :: JSONDecoder a (Context a) decodeContext = do - ex <- withState getExercise + ex <- getExercise liftM (inContext ex) decodeTerm decodeTerm :: JSONDecoder a a decodeTerm = do - ex <- withState getExercise - eitherEncoder $ \json -> + ex <- getExercise + decoderFor $ \json -> case json of - String s -> parser ex s - _ -> Left "Expecting a string when reading a term" - --- local helper -deintercalate :: String -> [String] -deintercalate xs - | null zs = [ys] - | otherwise = ys : deintercalate (drop 1 zs) - where - (ys, zs) = break (== ';') xs+ String s -> either fail return (parser ex s) + _ -> fail "Expecting a string when reading a term"
src/Ideas/Encoding/DecoderXML.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,50 +12,38 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- --- $Id: DecoderXML.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: DecoderXML.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.DecoderXML - ( XMLDecoder, XMLDecoderState(..), xmlDecoder + ( XMLDecoder, xmlDecoder ) where import Control.Monad import Data.Char -import Data.List -import Data.Maybe -import Ideas.Common.Library hiding (exerciseId, (:=)) -import Ideas.Encoding.Evaluator +import Ideas.Common.Library hiding ((<|>)) +import Ideas.Common.Traversal.Navigator +import Ideas.Encoding.Encoder import Ideas.Encoding.OpenMathSupport -import Ideas.Service.FeedbackScript.Syntax (Script) +import Ideas.Service.Request import Ideas.Service.State import Ideas.Service.Types import Ideas.Text.OpenMath.Object import Ideas.Text.XML -import System.Random (StdGen) -type XMLDecoder a = EncoderState (XMLDecoderState a) XML - -data XMLDecoderState a = XMLDecoderState - { getExercise :: Exercise a - , getScript :: Script - , getStdGen :: StdGen - , isOpenMath :: Bool - , decodeTerm :: XML -> Either String a - } +type XMLDecoder a = Decoder a XML -xmlDecoder :: Type a t -> XMLDecoder a t +xmlDecoder :: TypedDecoder a XML xmlDecoder tp = case tp of Tag s t - | s == "answer" -> do - c <- encoderFor (findChild "answer") - xmlDecoder t // c + | s == "answer" -> + decodeChild "answer" (xmlDecoder t) | s == "Difficulty" -> do - g <- equalM typed tp - a <- encoderFor (findAttribute "difficulty") + g <- equalM tDifficulty tp + a <- decoderFor (findAttribute "difficulty") maybe (fail "unknown difficulty level") (return . g) (readDifficulty a) - | otherwise -> do - cx <- encoderFor (findChild s) - xmlDecoder t // cx + | otherwise -> + decodeChild s (xmlDecoder t) Iso p t -> liftM (from p) (xmlDecoder t) Pair t1 t2 -> do x <- xmlDecoder t1 @@ -73,70 +61,91 @@ Environment -> decodeArgEnvironment Location -> decodeLocation StratCfg -> decodeConfiguration - StdGen -> withState getStdGen - Script -> withState getScript - Exercise -> withState getExercise - Id -> do -- improve! - a <- encoderFor (findChild "location") - return (newId (getData a)) + StdGen -> getStdGen + Script -> getScript + Exercise -> getExercise + Id -> -- improve! + decodeChild "location" $ + makeDecoder (newId . getData) _ -> fail $ "No support for argument type in XML: " ++ show tp _ -> fail $ "No support for argument type in XML: " ++ show tp +-- <ruleid> decodeRule :: XMLDecoder a (Rule (Context a)) -decodeRule = do - ex <- withState getExercise - xml0 <- encoderFor (findChild "ruleid") - getRule ex (newId (getData xml0)) +decodeRule = decodeChild "ruleid" $ do + ex <- getExercise + decoderFor (getRule ex . newId . getData) +-- <location> decodeLocation :: XMLDecoder a Location -decodeLocation = do - xml <- encoderFor (findChild "location") - return (toLocation (read (getData xml))) +decodeLocation = decodeChild "location" $ + makeDecoder (toLocation . read . getData) +-- <state> decodeState :: XMLDecoder a (State a) -decodeState = do - ex <- withState getExercise - xml <- encoderFor (findChild "state") - mp <- decodePrefix // xml - ctx <- decodeContext // xml - prs <- forM (maybeToList mp) $ \path -> - makePrefix path (strategy ex) ctx - return (makeState ex prs ctx) +decodeState = decodeChild "state" $ do + ex <- getExercise + ps <- decodePaths + ctx <- decodeContext + let prf = replayPaths ps (strategy ex) ctx + return (makeState ex prf ctx) -decodePrefix :: XMLDecoder a (Maybe Path) -decodePrefix = do - prefixText <- simpleEncoder (maybe "" getData . findChild "prefix") +-- <prefix> +decodePaths :: XMLDecoder a [Path] +decodePaths = do + prefixText <- makeDecoder (maybe "" getData . findChild "prefix") if all isSpace prefixText - then return (Just emptyPath) + then return [emptyPath] else if prefixText ~= "no prefix" - then return Nothing - else liftM Just (readM prefixText) + then return [] + else readPaths prefixText where a ~= b = g a == g b g = map toLower . filter (not . isSpace) decodeContext :: XMLDecoder a (Context a) decodeContext = do - ex <- withState getExercise - f <- withState decodeTerm - expr <- encoderFor (either fail return . f) + ex <- getExercise + expr <- decodeTerm env <- decodeEnvironment - return (setEnvironment env (inContext ex expr)) + let ctx = setEnvironment env (inContext ex expr) + locRef = makeRef "location" + case locRef ? env of + Just s -> maybe (fail "invalid location") return $ do + loc <- liftM toLocation (readM s) + navigateTo loc (deleteRef locRef ctx) + Nothing -> + return ctx +decodeTerm :: XMLDecoder a a +decodeTerm = withOpenMath f + where + f True = decodeOMOBJ + f False = decodeChild "expr" $ do + ex <- getExercise + decoderFor $ either fail return . parser ex . getData + +decodeOMOBJ :: XMLDecoder a a +decodeOMOBJ = decodeChild "OMOBJ" $ decoderFor $ \xml -> do + ex <- getExercise + omobj <- fromXML xml + case fromOpenMath ex omobj of + Just a -> return a + Nothing -> fail "Invalid OpenMath object for this exercise" + decodeEnvironment :: XMLDecoder a Environment -decodeEnvironment = encoderFor $ \xml -> - case findChild "context" xml of - Just this -> foldM add mempty (children this) - Nothing -> return mempty +decodeEnvironment = + decodeChild "context" (decoderFor $ foldM add mempty . children) + <|> return mempty where add env item = do unless (name item == "item") $ fail $ "expecting item tag, found " ++ name item - n <- findAttribute "name" item - isOM <- withState isOpenMath + n <- findAttribute "name" item + req <- getRequest case findChild "OMOBJ" item of -- OpenMath object found inside item tag - Just this | isOM -> + Just this | useOpenMath req -> case xml2omobj this >>= fromOMOBJ of Left err -> fail err Right term -> @@ -146,36 +155,30 @@ value <- findAttribute "value" item return $ insertRef (makeRef n) value env -decodeConfiguration :: XMLDecoder a StrategyConfiguration -decodeConfiguration = do - xml <- encoderFor (findChild "configuration") - liftM makeStrategyConfiguration $ - mapM decodeAction (children xml) +-- <configuration> +decodeConfiguration :: XMLDecoder a StrategyCfg +decodeConfiguration = decodeChild "configuration" $ + decoderFor $ \xml -> + liftM mconcat $ + mapM decodeAction (children xml) where decodeAction item = do guard (null (children item)) - action <- - case find (\a -> map toLower (show a) == name item) configActions of - Just a -> return a - Nothing -> fail $ "unknown action " ++ show (name item) + action <- readM (name item) cfgloc <- findAttribute "name" item - return (byName (newId cfgloc), action) + return (action `byName` newId cfgloc) decodeArgEnvironment :: XMLDecoder a Environment -decodeArgEnvironment = encoderFor $ \xml -> - liftM makeEnvironment $ sequence - [ decodeBinding // x - | x <- children xml - , name x == "argument" - ] +decodeArgEnvironment = decoderFor $ + liftM makeEnvironment . mapM (decodeBinding //) . findChildren "argument" decodeBinding :: XMLDecoder a Binding -decodeBinding = encoderFor $ \xml -> do - a <- findAttribute "description" xml - isOM <- withState isOpenMath +decodeBinding = decoderFor $ \xml -> do + a <- findAttribute "description" xml + req <- getRequest case findChild "OMOBJ" xml of -- OpenMath object found inside tag - Just this | isOM -> + Just this | useOpenMath req -> case xml2omobj this >>= fromOMOBJ of Left err -> fail err Right term -> return (termBinding a term) @@ -183,4 +186,12 @@ _ -> return (makeBinding (makeRef a) (getData xml)) where termBinding :: String -> Term -> Binding - termBinding = makeBinding . makeRef+ termBinding = makeBinding . makeRef + +decodeChild :: String -> XMLDecoder a b -> XMLDecoder a b +decodeChild s m = split f >>= (m //) + where + p = either (const False) ((==s) . name) + f xml = case break p (content xml) of + (xs, Right y:ys) -> Right (y, xml { content = xs ++ ys }) + _ -> Left $ "Could not find child " ++ s
+ src/Ideas/Encoding/Encoder.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- Copyright 2015, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +-- $Id: Evaluator.hs 6535 2014-05-14 11:05:06Z bastiaan $ + +module Ideas.Encoding.Encoder + ( -- * Converter type class + Converter(..) + , getExercise, getStdGen, getScript, getRequest + , withExercise, withOpenMath, (//) + -- * Options + , Options, simpleOptions, makeOptions + -- * Encoder datatype + , Encoder, TypedEncoder + , makeEncoder, encoderFor, exerciseEncoder + , (<?>), encodeTyped + -- * Decoder datatype + , Decoder, TypedDecoder + , makeDecoder, decoderFor + , split, symbol, setInput + -- re-export + , module Data.Monoid, module Control.Applicative + , module Control.Arrow + ) where + +import Control.Applicative hiding (Const) +import Control.Arrow +import Control.Monad +import Data.Monoid +import Ideas.Common.Library hiding (exerciseId, symbol) +import Ideas.Common.Utils (Some(..)) +import Ideas.Service.DomainReasoner +import Ideas.Service.FeedbackScript.Parser (parseScriptSafe, Script) +import Ideas.Service.Request +import Ideas.Service.Types +import Ideas.Text.XML +import System.Random (newStdGen, mkStdGen, StdGen) +import qualified Control.Category as C + +------------------------------------------------------------------- +-- Converter type class + +class Converter f where + fromOptions :: (Options a -> t) -> f a s t + run :: Monad m => f a s t -> Options a -> s -> m t + +getExercise :: Converter f => f a s (Exercise a) +getExercise = fromOptions exercise + +getStdGen :: Converter f => f a s StdGen +getStdGen = fromOptions stdGen + +getScript :: Converter f => f a s Script +getScript = fromOptions script + +getRequest :: Converter f => f a s Request +getRequest = fromOptions request + +withExercise :: (Converter f, Monad (f a s)) => (Exercise a -> f a s t) -> f a s t +withExercise = (getExercise >>=) + +withOpenMath :: (Converter f, Monad (f a s)) => (Bool -> f a s t) -> f a s t +withOpenMath = (liftM useOpenMath getRequest >>=) + +(//) :: (Converter f, Monad (f a s2)) => f a s t -> s -> f a s2 t +p // a = do + xs <- fromOptions id + run p xs a + +------------------------------------------------------------------- +-- Options + +data Options a = Options + { exercise :: Exercise a -- the current exercise + , request :: Request -- meta-information about the request + , stdGen :: StdGen -- random number generator + , script :: Script -- feedback script + } + +simpleOptions :: Exercise a -> Options a +simpleOptions ex = + let req = emptyRequest {encoding = [EncHTML]} + in Options ex req (mkStdGen 0) mempty + +makeOptions :: DomainReasoner -> Request -> IO (Some Options) +makeOptions dr req = do + Some ex <- + case exerciseId req of + Just code -> findExercise dr code + Nothing -> return (Some emptyExercise) + + scr <- case feedbackScript req of + Just s -> parseScriptSafe s + Nothing + | getId ex == mempty -> return mempty + | otherwise -> defaultScript dr (getId ex) + stdgen <- newStdGen + return $ Some Options + { exercise = ex + , request = req + , stdGen = stdgen + , script = scr + } + +------------------------------------------------------------------- +-- Encoder datatype + +newtype Encoder a s t = Enc { runEnc :: Options a -> s -> Error t } + +type TypedEncoder a = Encoder a (TypedValue (Type a)) + +instance C.Category (Encoder a) where + id = arr id + f . g = Enc $ \xs -> runEnc g xs >=> runEnc f xs + +instance Arrow (Encoder a) where + arr f = Enc $ \_ -> return . f + first f = Enc $ \xs (a, b) -> runEnc f xs a >>= \c -> return (c, b) + +instance Monad (Encoder a s) where + return a = Enc $ \_ _ -> return a + fail s = Enc $ \_ _ -> fail s + p >>= f = Enc $ \xs s -> do + (a) <- runEnc p xs s + runEnc (f a) xs s + +instance MonadPlus (Encoder a s) where + mzero = fail "Decoder: mzero" + mplus p q = Enc $ \xs s -> + runEnc p xs s `mplus` runEnc q xs s + +instance Functor (Encoder a s) where + fmap = liftM + +instance Applicative (Encoder a s) where + pure = return + (<*>) = liftM2 ($) + +instance Converter Encoder where + fromOptions f = Enc $ \xs _ -> return (f xs) + run f xs = runErrorM . runEnc f xs + +instance Monoid t => Monoid (Encoder a s t) where + mempty = pure mempty + mappend = liftA2 (<>) + +instance BuildXML t => BuildXML (Encoder a s t) where + n .=. s = pure (n .=. s) + unescaped = pure . unescaped + builder = pure . builder + tag = liftA . tag + +makeEncoder :: (s -> t) -> Encoder a s t +makeEncoder = arr + +encoderFor :: (s -> Encoder a s t) -> Encoder a s t +encoderFor f = C.id >>= f + +exerciseEncoder :: (Exercise a -> s -> t) -> Encoder a s t +exerciseEncoder f = withExercise $ makeEncoder . f + +infixr 5 <?> + +(<?>) :: (Encoder a t b, Type a1 t) -> Encoder a (TypedValue (Type a1)) b + -> Encoder a (TypedValue (Type a1)) b +(p, t) <?> q = do + val ::: tp <- makeEncoder id + case equal tp t of + Just f -> p // f val + Nothing -> q + +encodeTyped :: Encoder st t b -> Type a t -> Encoder st (TypedValue (Type a)) b +encodeTyped p t = (p, t) <?> fail "Types do not match" + +------------------------------------------------------------------- +-- Decoder datatype + +newtype Decoder a s t = Dec { runDec :: Options a -> s -> Error (t, s) } + +type TypedDecoder a s = forall t . Type a t -> Decoder a s t + +instance Monad (Decoder a s) where + return a = Dec $ \_ s -> return (a, s) + fail s = Dec $ \_ _ -> fail s + p >>= f = Dec $ \xs s1 -> do + (a, s2) <- runDec p xs s1 + runDec (f a) xs s2 + +instance MonadPlus (Decoder a s) where + mzero = fail "Decoder: mzero" + mplus p q = Dec $ \xs s -> + runDec p xs s `mplus` runDec q xs s + +instance Functor (Decoder a s) where + fmap = liftM + +instance Applicative (Decoder a s) where + pure = return + (<*>) = liftM2 ($) + +instance Alternative (Decoder a s) where + empty = fail "Decoder: empty" + (<|>) = mplus + +get :: Decoder a s s +get = Dec $ \_ s -> return (s, s) + +put :: s -> Decoder a s () +put s = Dec $ \_ _ -> return ((), s) + +instance Converter Decoder where + fromOptions f = Dec $ \xs s -> return (f xs, s) + run f xs = liftM fst . runErrorM . runDec f xs + +split :: (s -> Either String (t, s)) -> Decoder a s t +split f = get >>= either fail (\(a, s2) -> put s2 >> return a) . f + +symbol :: Decoder a [s] s +symbol = split f + where + f [] = Left "Empty input" + f (x:xs) = Right (x, xs) + +setInput :: s -> Decoder a s () +setInput inp = split (\_ -> Right ((), inp)) + +makeDecoder:: (s -> t) -> Decoder a s t +makeDecoder f = fmap f get + +decoderFor :: (s -> Decoder a s t) -> Decoder a s t +decoderFor f = get >>= f + +------------------------------------------------------------------- +-- Error monad (helper) + +newtype Error a = Error { runError :: Either String a } + +instance Monad Error where + fail = Error . Left + return = Error . Right + m >>= f = Error $ either Left (runError . f) (runError m) + +instance MonadPlus Error where + mzero = fail "mzero" + mplus p q = Error $ + case (runError p, runError q) of + (Right a, _) -> Right a + (_, Right a) -> Right a + (Left s, _) -> Left s + +runErrorM :: Monad m => Error a -> m a +runErrorM = either fail return . runError
src/Ideas/Encoding/EncoderHTML.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,19 +12,18 @@ -- Encoding in HTML -- ----------------------------------------------------------------------------- --- $Id: EncoderHTML.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: EncoderHTML.hs 7524 2015-04-08 07:31:15Z bastiaan $ -module Ideas.Encoding.EncoderHTML (htmlEncoder) where +module Ideas.Encoding.EncoderHTML (htmlEncoder, htmlEncoderAt) where -import Control.Monad import Data.Char import Data.List import Data.Maybe import Data.Ord -import Ideas.Common.Library hiding (ready) +import Ideas.Common.Library hiding (alternatives) import Ideas.Common.Utils import Ideas.Common.Utils.TestSuite -import Ideas.Encoding.Evaluator +import Ideas.Encoding.Encoder import Ideas.Encoding.LinkManager import Ideas.Encoding.RulePresenter import Ideas.Encoding.RulesInfo @@ -32,22 +31,29 @@ import Ideas.Service.BasicServices import Ideas.Service.Diagnose import Ideas.Service.DomainReasoner +import Ideas.Service.Request import Ideas.Service.State import Ideas.Service.Types import Ideas.Text.HTML import Ideas.Text.OpenMath.FMP import Ideas.Text.OpenMath.Object import Ideas.Text.XML +import System.IO.Unsafe -type HTMLEncoder a t = EncoderState (HTMLEncoderState a) t HTMLBuilder +type HTMLEncoder a t = Encoder a t HTMLBuilder -data HTMLEncoderState a = HTMLEncoderState - { getLinkManager :: LinkManager - , getExercise :: Exercise a - } +htmlEncoder :: DomainReasoner -> TypedEncoder a HTMLPage +htmlEncoder = htmlEncoderAt 0 -htmlEncoder :: LinkManager -> DomainReasoner -> Exercise a -> TypedValue (Type a) -> HTMLPage -htmlEncoder lm dr ex tv = +htmlEncoderAt :: Int -> DomainReasoner -> TypedEncoder a HTMLPage +htmlEncoderAt n dr = do + req <- getRequest + let lm = f (maybe staticLinks dynamicLinks (cgiBinary req)) + f = if n==0 then id else linksUp n + makePage lm dr <$> encodeType lm dr + +makePage :: LinkManager -> DomainReasoner -> HTMLBuilder -> HTMLPage +makePage lm dr a = addCSS (urlForCSS lm "ideas.css") $ htmlPage "Ideas: documentation pages" $ mconcat [ divClass "page-header" $ mconcat @@ -55,60 +61,59 @@ , divClass "ounl-logo" space , spanClass "menuitem" $ linkToIndex lm $ string "Index" , spanClass "menuitem" $ linkToExercises lm $ string "Exercises" - , spanClass "menuitem" $ linkToServices lm $ string "Services" + , spanClass "menuitem" $ linkToServices lm $ string "Services" ] - , divClass "page-content" $ - let hes = HTMLEncoderState lm ex in - case runEncoderState (encodeType lm ex) hes tv of - Left err -> string err - Right ok -> ok + , divClass "page-content" a , divClass "page-footer" $ string (fullVersion dr) ] -encodeType :: LinkManager -> Exercise a -> HTMLEncoder a (TypedValue (Type a)) -encodeType lm ex = msum - [ encodeTyped encodeIndex - , encodeTyped (exerciseHeader // () <> htmlDiagnosis) - , encodeTyped (exerciseHeader // () <> encodeExampleList lm ex) - , encodeTyped (exerciseHeader // () <> htmlAllFirsts) - , encodeTyped (exerciseHeader // () <> htmlAllApplications) - , encodeTyped (exerciseHeader // () <> encodeDerivation lm ex) - , encodeTyped (exerciseHeader // () <> encodeDerivationList lm ex) - , encoderFor $ \(val ::: tp) -> +encodeType :: LinkManager -> DomainReasoner -> HTMLEncoder a (TypedValue (Type a)) +encodeType lm dr = + (encodeIndex, tDomainReasoner) <?> + (exerciseHeader lm <> htmlDiagnosis lm dr, tDiagnosis) <?> + (exerciseHeader lm <> encodeExampleList lm, tList (tPair tDifficulty tContext)) <?> + (exerciseHeader lm <> htmlFirsts lm, tList (tPair tStepInfo tState)) <?> + (exerciseHeader lm <> htmlAllApplications lm, tList (tTuple3 tRule tLocation tState)) <?> + (exerciseHeader lm <> encodeDerivation lm, tDerivation (tPair tRule tEnvironment) tContext) <?> + (exerciseHeader lm <> encodeDerivationList lm, tList (tDerivation (tPair tRule tEnvironment) tContext)) <?> + encoderFor (\(val ::: tp) -> case tp of - Iso iso t -> encodeType lm ex // (to iso val ::: t) - Tag _ t -> encodeType lm ex // (val ::: t) - Pair t1 t2 -> encodeType lm ex // (fst val ::: t1) <> - encodeType lm ex // (snd val ::: t2) + Iso iso t -> encodeType lm dr // (to iso val ::: t) + Tag _ t -> encodeType lm dr // (val ::: t) + Pair t1 t2 -> encodeType lm dr // (fst val ::: t1) <> + encodeType lm dr // (snd val ::: t2) t1 :|: t2 -> case val of - Left x -> encodeType lm ex // (x ::: t1) - Right x -> encodeType lm ex // (x ::: t2) + Left x -> encodeType lm dr // (x ::: t1) + Right x -> encodeType lm dr // (x ::: t2) List (Const Service) -> encodeServiceList lm // val List (Const SomeExercise) -> encodeExerciseList lm // val - List (Const Rule) -> (exerciseHeader // ()) <> encodeRuleList lm ex // val - List t -> ul [ encodeType lm ex // (x ::: t) | x <- val ] - Const t -> encodeConst lm ex // (val ::: t) - _ -> string $ "unknown: " ++ show tp - ] + List (Const Rule) -> exerciseHeader lm <> encodeRuleList lm // val + List t -> ul [ encodeType lm dr // (x ::: t) | x <- val ] + Const t -> encodeConst lm dr // (val ::: t) + _ -> string $ "unknown: " ++ show tp) -encodeConst :: LinkManager -> Exercise a -> HTMLEncoder a (TypedValue (Const a)) -encodeConst lm ex = encoderFor $ \tv@(val ::: tp) -> +encodeConst :: LinkManager -> DomainReasoner -> HTMLEncoder a (TypedValue (Const a)) +encodeConst lm dr = encoderFor $ \tv@(val ::: tp) -> case tp of Service -> encodeService // val - Exercise -> (exerciseHeader // ()) <> encodeExercise lm // val - Strategy -> (exerciseHeader // ()) <> encodeStrategy ex // val - Rule -> encodeRule ex // val - State -> (exerciseHeader // ()) <> (encodeState // val) + Exercise -> exerciseHeader lm <> encodeExercise lm // val + Strategy -> exerciseHeader lm <> encodeStrategy // val + Rule -> encodeRule // val + State -> exerciseHeader lm <> (encodeState lm dr // val) Location -> text val Environment -> text val - Context -> string $ prettyPrinterContext ex val + Context -> encodeContext // val String -> string val - Result -> (exerciseHeader // ()) <> encodeResult lm val + Result -> exerciseHeader lm <> encodeResult lm val _ -> text tv +encodeContext :: HTMLEncoder a (Context a) +encodeContext = exerciseEncoder $ \ex -> + string . prettyPrinterContext ex + encodeIndex :: HTMLEncoder a DomainReasoner -encodeIndex = simpleEncoder $ \dr -> mconcat +encodeIndex = makeEncoder $ \dr -> mconcat [ h1 $ "Domain reasoner " ++ showId dr , htmlDescription dr , keyValueTable @@ -133,7 +138,7 @@ ] encodeServiceList :: LinkManager -> HTMLEncoder a [Service] -encodeServiceList lm = simpleEncoder $ \srvs -> +encodeServiceList lm = makeEncoder $ \srvs -> h1 "Services" <> mconcat [ h2 (show i ++ ". " ++ s) <> table False (map make xs) @@ -146,7 +151,7 @@ ] encodeExerciseList :: LinkManager -> HTMLEncoder a [Some Exercise] -encodeExerciseList lm = simpleEncoder $ \exs -> +encodeExerciseList lm = makeEncoder $ \exs -> h1 "Exercises" <> mconcat [ h2 (show i ++ ". " ++ dom) <> table False (map make xs) @@ -177,7 +182,7 @@ f i xs = (i, showf (get (head xs)), xs) encodeService :: HTMLEncoder a Service -encodeService = simpleEncoder $ \srv -> mconcat +encodeService = makeEncoder $ \srv -> mconcat [ h1 $ "Service " ++ showId srv , mwhen (serviceDeprecated srv) $ para $ spanClass "warning" $ string "Warning: this service is deprecated" @@ -214,7 +219,7 @@ _ -> [Some tp] encodeExercise :: LinkManager -> HTMLEncoder a (Exercise a) -encodeExercise lm = simpleEncoder $ \ex -> mconcat +encodeExercise lm = makeEncoder $ \ex -> mconcat [ generalInfo ex , h2 "Example exercises" , ul $ [ para $ linkToExamples lm ex $ string "list of examples" @@ -248,17 +253,15 @@ (nrOfBuggyRules, nrOfSoundRules) = mapBoth length (partition isBuggy (ruleset ex)) -exerciseHeader :: HTMLEncoder a () -exerciseHeader = do - ex <- withState getExercise - mconcat - [ exerciseMenu - , h1 $ "Exercise " ++ showId ex - , return $ htmlDescription ex - ] +exerciseHeader :: LinkManager -> HTMLEncoder a b +exerciseHeader lm = withExercise $ \ex -> mconcat + [ exerciseMenu lm + , h1 $ "Exercise " ++ showId ex + , pure $ htmlDescription ex + ] -exerciseMenu :: HTMLEncoder a () -exerciseMenu = divClass "menubox" $ +exerciseMenu :: LinkManager -> HTMLEncoder a b +exerciseMenu lm = divClass "menubox" $ bold (string "Exercise") <> ul [ with linkToExercise "information" , with linkToStrategy " strategy" @@ -268,13 +271,11 @@ , with linkToTestReport "test report" ] where - with f s = do - lm <- withState getLinkManager - ex <- withState getExercise - return $ f lm ex $ string s + with f s = withExercise $ \ex -> + pure $ f lm ex (string s) -encodeStrategy :: Exercise a -> HTMLEncoder a (Strategy (Context a)) -encodeStrategy ex = simpleEncoder $ \s -> mconcat +encodeStrategy :: HTMLEncoder a (Strategy (Context a)) +encodeStrategy = exerciseEncoder $ \ex s -> mconcat [ h2 "Strategy" , highlightXML True (strategyToXML s) , h2 "Locations" @@ -360,29 +361,31 @@ | a == 1 = "star_2.png" | otherwise = "star_3.png" -encodeRuleList :: LinkManager -> Exercise a -> HTMLEncoder a [Rule (Context a)] -encodeRuleList lm ex = simpleEncoder $ \rs -> +encodeRuleList :: LinkManager -> HTMLEncoder a [Rule (Context a)] +encodeRuleList lm = exerciseEncoder $ \ex rs -> let (rs1, rs2) = partition isBuggy rs + + header = [ string "Rule name", string "Args" + , string "Used", string "Siblings", string "Rewrite rule" + ] + used = rulesInStrategy (strategy ex) + f r = [ linkToRule lm ex r $ ttText (showId r) + , text $ length $ getRefs r + , bool $ r `elem` used + , string $ intercalate ", " $ map show $ ruleSiblings r + , mwhen (isRewriteRule r) $ + ruleToHTML (Some ex) r + ] + in mconcat [ h2 $ "Rules for " ++ showId ex , table True (header:map f rs2) , h2 $ "Buggy rules for " ++ showId ex , table True (header:map f rs1) ] - where - header = [ string "Rule name", string "Args" - , string "Used", string "Rewrite rule" - ] - used = rulesInStrategy (strategy ex) - f r = [ linkToRule lm ex r $ ttText (showId r) - , text $ length $ getRefs r - , bool $ r `elem` used - , mwhen (isRewriteRule r) $ - ruleToHTML (Some ex) r - ] -encodeRule :: Exercise a -> HTMLEncoder a (Rule (Context a)) -encodeRule ex = simpleEncoder $ \r -> mconcat +encodeRule :: HTMLEncoder a (Rule (Context a)) +encodeRule = exerciseEncoder $ \ex r -> mconcat [ h1 $ "Rule " ++ showId r , htmlDescription r , let commas = string . intercalate ", " @@ -408,15 +411,15 @@ ] ] -encodeExampleList :: LinkManager -> Exercise a -> HTMLEncoder a [(Difficulty, Context a)] -encodeExampleList lm ex = simpleEncoder $ \pairs -> mconcat $ +encodeExampleList :: LinkManager -> HTMLEncoder a [(Difficulty, Context a)] +encodeExampleList lm = exerciseEncoder $ \ex pairs -> mconcat $ h2 "Examples" : [ h3 (s ++ " (" ++ show (length xs) ++ ")") - <> (if isStatic lm then ul else mconcat) (map make xs) + <> (if isStatic lm then ul else mconcat) (map (make ex) xs) | (_, s, xs) <- orderedGroupsWith show fst pairs ] where - make (_, x) = para $ + make ex (_, x) = para $ munless (isStatic lm) ( let st = emptyStateContext ex x in spanClass "statelink" $ linkToState lm st $ external lm) @@ -426,144 +429,164 @@ external lm = element "img" ["src" .=. urlForImage lm "external.png", "width" .=. "15"] -encodeDerivation :: LinkManager -> Exercise a -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a)) -encodeDerivation lm ex = - h2 "Derivation" <> htmlDerivation lm ex +encodeDerivation :: LinkManager -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a)) +encodeDerivation lm = + h2 "Derivation" <> htmlDerivation lm -encodeDerivationList :: LinkManager -> Exercise a -> HTMLEncoder a [Derivation (Rule (Context a), Environment) (Context a)] -encodeDerivationList lm ex = encoderFor $ \ds -> +encodeDerivationList :: LinkManager -> HTMLEncoder a [Derivation (Rule (Context a), Environment) (Context a)] +encodeDerivationList lm = encoderFor $ \ds -> h2 "Derivations" <> mconcat - [ h3 (show i ++ ".") <> htmlDerivation lm ex // d + [ h3 (show i ++ ".") <> htmlDerivation lm // d | (i, d) <- zip [1::Int ..] ds ] -htmlDerivation :: LinkManager -> Exercise a -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a)) -htmlDerivation lm ex = encoderFor $ \d -> - arr diffEnvironment - >>> htmlDerivationWith (before d) forStep forTerm - where - before d = - stateLink lm (emptyStateContext ex (firstTerm d)) - <> case fmap (isReady ex) (fromContext (lastTerm d)) of - Just True -> mempty - _ -> spanClass "error" (string "Final term is not finished") - forStep ((r, env1), env2) = - let showEnv e = munless (noBindings e) $ string $ ", " ++ show e in - spanClass "derivation-step" $ mconcat - [ unescaped "⇒ " - , linkToRule lm ex r $ string $ showId r - , showEnv env1 -- local environment - , showEnv env2 -- global environment (diff) - ] - forTerm a = - divClass "term" $ string $ prettyPrinterContext ex a +htmlDerivation :: LinkManager -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a)) +htmlDerivation lm = exerciseEncoder $ \ex d -> + let before = + stateLink lm (emptyStateContext ex (firstTerm d)) + <> case fmap (isReady ex) (fromContext (lastTerm d)) of + Just True -> mempty + _ -> spanClass "error" (string "Final term is not finished") + forStep ((r, env1), env2) = + let showEnv e = munless (noBindings e) $ string $ ", " ++ show e in + spanClass "derivation-step" $ mconcat + [ unescaped "⇒ " + , linkToRule lm ex r $ string $ showId r + , showEnv env1 -- local environment + , showEnv env2 -- global environment (diff) + ] + forTerm a = + divClass "term" $ string $ prettyPrinterContext ex a + in htmlDerivationWith before forStep forTerm (diffEnvironment d) -htmlState :: HTMLEncoder a (State a) -htmlState = do - lm <- withState getLinkManager - simpleEncoder $ \state -> - para $ divClass "state" $ - stateLink lm state - <> divClass "term" (string $ prettyPrinterContext (exercise state) (stateContext state)) - <> string "ready: " <> bool (ready state) +htmlState :: LinkManager -> HTMLEncoder a (State a) +htmlState lm = makeEncoder $ \state -> + para $ divClass "state" $ + stateLink lm state + <> divClass "term" (string $ prettyPrinterContext (exercise state) (stateContext state)) + <> string "ready: " <> bool (finished state) stateLink :: LinkManager -> State a -> HTMLBuilder -stateLink lm st = munless (isStatic lm) $ - spanClass "derivation-statelink" $ linkToState lm st $ external lm +stateLink lm st + | isStatic lm = mempty + | otherwise = + spanClass "derivation-statelink" $ linkToState lm st $ external lm -encodeState :: HTMLEncoder a (State a) -encodeState = do - lm <- withState getLinkManager - htmlState <> simpleEncoder (\state -> mconcat - [ h2 "Feedback" - , submitDiagnose lm state - , ul [ linkToFirsts lm state $ string "allfirsts" - , linkToApplications lm state $ string "allapplications" - , linkToDerivation lm state $ string "derivation" - ] - , munless (noBindings state) $ - h2 "Environment" <> text (environment state) - , encodePrefixes (statePrefixes state) - ]) +encodeState :: LinkManager -> DomainReasoner -> HTMLEncoder a (State a) +encodeState lm dr = + htmlState lm <> + makeEncoder (\state -> + let xs = useAllFirsts dr state + n = either (const 0) length xs + in mconcat + [ h2 "Feedback" + , submitDiagnose lm state + , ul [ case xs of + Right (hd:_) -> linkToState lm (snd hd) $ string "onefirst" + _ -> string "(no onefirst)" + , linkToFirsts lm state $ string $ "allfirsts (" ++ show n ++ ")" + , linkToApplications lm state $ string "allapplications" + , linkToDerivation lm state $ string "derivation" + , linkToMicrosteps lm state $ string "microsteps" + ] + , munless (noBindings state) $ + h2 "Environment" <> text (environment state) + , encodePrefix state (statePrefix state) + ]) -encodePrefixes :: [Prefix (Context a)] -> HTMLBuilder -encodePrefixes = mconcat . zipWith make [1::Int ..] +-- use allfirsts service of domain reasoner, instead of calling the service +-- directly. Note that the service can be redefined (e.g. for the Ask-Elle tutor) +useAllFirsts :: DomainReasoner -> State a -> Either String [(StepInfo a, State a)] +useAllFirsts dr = unsafePerformIO . useAllFirstsIO dr + +useAllFirstsIO :: DomainReasoner -> State a -> IO (Either String [(StepInfo a, State a)]) +useAllFirstsIO dr st = do + srv <- findService dr (newId "allfirsts") + case serviceFunction srv of + f ::: tp -> do + conv <- equalM tp (tState .-> tError (tList (tPair tStepInfo tState))) + return (conv f st) + +encodePrefix :: State a -> Prefix (Context a) -> HTMLBuilder +encodePrefix st = + mconcat . zipWith3 make [1::Int ..] (stateLabels st) . prefixPaths where - make i pr = mconcat - [ h2 $ "Prefix " ++ show i + make i ls path = mconcat + [ h2 $ "Path " ++ show i , let count p = text $ length $ filter p prSteps enter = spanClass "step-enter" . text + comma c = if c == ',' then ", " else [c] in keyValueTable - [ ("steps", count (const True)) - , ("rules", count isRuleStep) + [ ("path", string $ concatMap comma $ show path) + , ("steps", count (const True)) , ("major rules", count isMajor) - , ("active labels", ul $ map enter $ activeLabels pr) + , ("active labels", ul $ map enter ls) ] , mconcat $ intersperse (string ", ") $ map htmlStep prSteps ] where - prSteps = prefixToSteps pr - -isRuleStep :: Step l a -> Bool -isRuleStep (RuleStep _ _) = True -isRuleStep _ = False + ex = exercise st + ctx = stateContext st + prSteps = fst $ replayPath path (strategy ex) ctx -htmlStep :: Show l => Step l a -> HTMLBuilder +htmlStep :: Step a -> HTMLBuilder htmlStep (Enter l) = spanClass "step-enter" $ string $ "enter " ++ show l htmlStep (Exit l) = spanClass "step-exit" $ string $ "exit " ++ show l htmlStep (RuleStep _ r) = let s = if isMinor r then "minor" else "major" in spanClass ("step-"++s) $ string $ showId r -htmlDerivationWith :: HTMLBuilder -> (s -> HTMLBuilder) -> (t -> HTMLBuilder) -> HTMLEncoder a (Derivation s t) -htmlDerivationWith before forStep forTerm = simpleEncoder $ \d -> +htmlDerivationWith :: HTMLBuilder -> (s -> HTMLBuilder) -> (t -> HTMLBuilder) -> Derivation s t -> HTMLBuilder +htmlDerivationWith before forStep forTerm d = divClass "derivation" $ mconcat $ before : forTerm (firstTerm d) : [ forStep s <> forTerm a | (_, s, a) <- triples d ] -htmlAllFirsts :: HTMLEncoder a [(StepInfo a, State a)] -htmlAllFirsts = encoderFor $ \xs -> - h2 "All firsts" <> +htmlFirsts :: LinkManager -> HTMLEncoder a [(StepInfo a, State a)] +htmlFirsts lm = encoderFor $ \xs -> + h2 "Firsts" <> ul [ keyValueTable [ ("Rule", string $ showId r) , ("Location", text loc) + , ("Term", text $ show $ currentTerm (top $ stateContext s) ) + , ("Focus", text $ show $ currentTerm (stateContext s) ) , ("Environment", text env) - ] <> htmlState // s + ] <> htmlState lm // s | ((r, loc, env), s) <- xs ] -htmlAllApplications :: HTMLEncoder a [(Rule (Context a), Location, State a)] -htmlAllApplications = encoderFor $ \xs -> +htmlAllApplications :: LinkManager -> HTMLEncoder a [(Rule (Context a), Location, State a)] +htmlAllApplications lm = encoderFor $ \xs -> h2 "All applications" <> ul [ keyValueTable [ ("Rule", string $ showId r) , ("Location", text loc) - ] <> (if isBuggy r then mempty else htmlState // s) + ] <> (if isBuggy r then mempty else htmlState lm // s) | (r, loc, s) <- xs ] -htmlDiagnosis :: HTMLEncoder a (Diagnosis a) -htmlDiagnosis = encoderFor $ \diagnosis -> +htmlDiagnosis :: LinkManager -> DomainReasoner -> HTMLEncoder a (Diagnosis a) +htmlDiagnosis lm dr = encoderFor $ \diagnosis -> case diagnosis of Buggy _ r -> 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 // s + h2 "Similar term" <> encodeState lm dr // s WrongRule _ s mr -> h2 ("WrongRule " ++ maybe "" showId mr) - <> encodeState // s + <> encodeState lm dr // s Expected _ s r -> h2 ("Expected (" ++ show r ++ ")") - <> encodeState // s + <> encodeState lm dr // s Detour _ s _ r -> h2 ("Detour (" ++ show r ++ ")") - <> encodeState // s + <> encodeState lm dr // s Correct _ s -> - h2 "Correct" <> encodeState // s + h2 "Correct" <> encodeState lm dr // s Unknown _ s -> - h2 "Unknown" <> encodeState // s + h2 "Unknown" <> encodeState lm dr // s htmlDescription :: HasId a => a -> HTMLBuilder htmlDescription a = munless (null (description a)) $ @@ -598,11 +621,12 @@ ++ "' encoding='html'>" ++ ststr ++ "<expr>\" + getTerm() + \"</expr></request>" ststr = case fromBuilder (stateToXML st) of - Just el -> concatMap f (show el) + Just el -> concatMap f (compactXML el) Nothing -> "" f '\\' = "\\\\" - f c = [c] + f '"' = "\\\"" + f c = [c] submitRequest :: LinkManager -> String -> HTMLBuilder submitRequest lm request = submitURL $ @@ -621,8 +645,11 @@ \ var result = '';\ \ for (var i=0;i<s.length;i++) {\ \ if (s[i]=='<') result+='<';\ + \ else if (s[i]=='>') result+='>';\ \ else if (s[i]=='&') result+='&';\ - \ else result+=s[i];\ + \ else if (s[i]=='\"') result+='"';\ + \ else if (s[i]==\"'\") result+=''';\ + \ else result+=s[i];\ \ }\ \ return result;\ \}\
src/Ideas/Encoding/EncoderJSON.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,15 +12,13 @@ -- Services using JSON notation -- ----------------------------------------------------------------------------- --- $Id: EncoderJSON.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: EncoderJSON.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.EncoderJSON (jsonEncoder) where -import Control.Monad -import Data.List (intercalate) -import Ideas.Common.Library hiding (exerciseId) +import Ideas.Common.Library hiding (exerciseId, (<|>), (<*>)) import Ideas.Common.Utils (Some(..), distinct) -import Ideas.Encoding.Evaluator +import Ideas.Encoding.Encoder import Ideas.Service.State import Ideas.Service.Types hiding (String) import Ideas.Text.JSON @@ -28,9 +26,9 @@ import qualified Ideas.Service.Submit as Submit import qualified Ideas.Service.Types as Tp -type JSONEncoder a t = EncoderState (a -> JSON) t JSON +type JSONEncoder a t = Encoder a t JSON -jsonEncoder :: JSONEncoder a (TypedValue (Type a)) +jsonEncoder :: TypedEncoder a JSON jsonEncoder = encoderFor $ \tv@(val ::: tp) -> case tp of _ | length (tupleList tv) > 1 -> @@ -46,10 +44,10 @@ List (Const Rule) -> pure $ Array $ map ruleShortInfo val Tp.Tag s t - | s == "Result" -> encodeTyped encodeResult - | s == "Diagnosis" -> encodeTyped encodeDiagnosis - | s == "Derivation" -> encodeTyped encodeDerivation <+> - encodeTyped encodeDerivationText + | s == "Result" -> encodeTyped encodeResult Submit.tResult + | s == "Diagnosis" -> encodeTyped encodeDiagnosis Diagnose.tDiagnosis + | s == "Derivation" -> (encodeDerivation, tDerivation (tPair tRule tEnvironment) tContext) <?> + encodeTyped encodeDerivationText (tDerivation tString tContext) | s == "elem" -> jsonEncoder // (val ::: t) | otherwise -> (\b -> Object [(s, b)]) <$> jsonEncoder // (val ::: t) Tp.Unit -> pure Null @@ -69,13 +67,13 @@ tupleList tv = [tv] jsonEncodeConst :: JSONEncoder a (TypedValue (Const a)) -jsonEncodeConst = encoderStateFor $ \encTerm (val ::: tp) -> +jsonEncodeConst = encoderFor $ \(val ::: tp) -> case tp of SomeExercise -> case val of Some ex -> pure (exerciseInfo ex) State -> encodeState // val Rule -> pure (toJSON (showId val)) - Context -> maybe zeroArrow (pure . encTerm) (fromContext val) + Context -> encodeContext // val Location -> pure (toJSON (show val)) Environment -> encodeEnvironment // val Text -> pure (toJSON (show val)) @@ -88,34 +86,43 @@ -- legacy representation encodeEnvironment :: JSONEncoder a Environment -encodeEnvironment = encoderFor $ \env -> +encodeEnvironment = makeEncoder $ \env -> let f a = Object [(showId a, String (showValue a))] - in pure $ Array [ f a | a <- bindings env ] + in Array [ f a | a <- bindings env ] +encodeContext :: JSONEncoder a (Context a) +encodeContext = exerciseEncoder $ \ex ctx -> + String $ prettyPrinterContext ex ctx + encodeState :: JSONEncoder a (State a) -encodeState = encoderStateFor $ \encTerm st -> - let f x = [ String (showId (exercise st)) - , String $ case statePrefixes st of - [] -> "NoPrefix" - ps -> intercalate ";" $ map showPrefix ps - , encTerm (stateTerm st) - , x - ] - in Array . f <$> encodeContext // stateContext st +encodeState = encoderFor $ \st -> + let ctx = stateContext st + make pp env = Array + [ String $ showId (exercise st) + , String $ if withoutPrefix st + then "NoPrefix" + else show (statePrefix st) + , pp + , env + ] + in make <$> (encodeContext // ctx) <*> (encodeStateEnvironment // ctx) -encodeContext :: JSONEncoder a (Context a) -encodeContext = encoderFor $ \ctx -> - pure $ Object [ (showId a, String $ showValue a) | a <- bindings ctx ] +encodeStateEnvironment :: JSONEncoder a (Context a) +encodeStateEnvironment = makeEncoder $ \ctx -> + let loc = fromLocation (location ctx) + env = (if null loc then id else insertRef (makeRef "location") loc) + $ environment ctx + in Object [ (showId a, String $ showValue a) | a <- bindings env ] encodeDerivation :: JSONEncoder a (Derivation (Rule (Context a), Environment) (Context a)) encodeDerivation = encoderFor $ \d -> let xs = [ (s, a) | (_, s, a) <- triples d ] - in jsonEncoder // (xs ::: typed) + in jsonEncoder // (xs ::: tList (tPair (tPair tRule tEnvironment) tContext)) encodeDerivationText :: JSONEncoder a (Derivation String (Context a)) encodeDerivationText = encoderFor $ \d -> let xs = [ (s, a) | (_, s, a) <- triples d ] - in jsonEncoder // (xs ::: typed) + in jsonEncoder // (xs ::: tList (tPair tString tContext)) encodeResult :: JSONEncoder a (Submit.Result a) encodeResult = encoderFor $ \result -> Object <$> @@ -133,20 +140,20 @@ , ("rules", Array $ map (String . showId) rs) , ("state", x) ] - in f <$> jsonEncoder // (st ::: typed) + in f <$> jsonEncoder // (st ::: tState) Submit.Detour rs st -> let f x = [ ("result", String "Detour") , ("rules", Array $ map (String . showId) rs) , ("state", x) ] - in f <$> jsonEncoder // (st ::: typed) + in f <$> jsonEncoder // (st ::: tState) Submit.Unknown st -> let f x = [ ("result", String "Unknown") , ("state", x) ] - in f <$> jsonEncoder // (st ::: typed) + in f <$> jsonEncoder // (st ::: tState) encodeDiagnosis :: JSONEncoder a (Diagnose.Diagnosis a) encodeDiagnosis = encoderFor $ \diagnosis -> @@ -169,13 +176,13 @@ Diagnose.Unknown b st -> make "unknown" [fromReady b, fromState st] where - make s = liftM (\xs -> Object [(s, Array xs)]) . sequence - fromEnv env = jsonEncoder // (env ::: typed) - fromRule r = return (toJSON (showId r)) - fromMaybeRule mr = return (maybe Null (toJSON . showId) mr) - fromReady b = return (Object [("ready", toJSON b)]) - fromState st = jsonEncoder // (st ::: typed) - fromReason s = return (Object [("reason", toJSON s)]) + make s = liftA (\xs -> Object [(s, Array xs)]) . sequence + fromEnv env = jsonEncoder // (env ::: tEnvironment) + fromRule r = pure (toJSON (showId r)) + fromMaybeRule mr = pure (maybe Null (toJSON . showId) mr) + fromReady b = pure (Object [("ready", toJSON b)]) + fromState st = jsonEncoder // (st ::: tState) + fromReason s = pure (Object [("reason", toJSON s)]) {- encodeTree :: Tree JSON -> JSON
src/Ideas/Encoding/EncoderXML.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,20 +12,19 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- --- $Id: EncoderXML.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: EncoderXML.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.EncoderXML - ( XMLEncoder, XMLEncoderState(..) + ( XMLEncoder , xmlEncoder, encodeState ) where -import Control.Monad import Data.Char import Data.Maybe import Data.Monoid -import Ideas.Common.Library hiding (exerciseId, (:=), (<|>)) +import Ideas.Common.Library hiding (exerciseId, (:=), alternatives) import Ideas.Common.Utils (Some(..)) -import Ideas.Encoding.Evaluator +import Ideas.Encoding.Encoder import Ideas.Encoding.OpenMathSupport import Ideas.Encoding.RulesInfo (rulesInfoXML) import Ideas.Encoding.StrategyInfo @@ -40,23 +39,17 @@ ----------------- -type XMLEncoder a t = EncoderState (XMLEncoderState a) t XMLBuilder - -data XMLEncoderState a = XMLEncoderState - { getExercise :: Exercise a - , isOpenMath :: Bool - , encodeTerm :: a -> XMLBuilder - } +type XMLEncoder a t = Encoder a t XMLBuilder -xmlEncoder :: XMLEncoder a (TypedValue (Type a)) -xmlEncoder = msum - [ encodeTyped encodeDiagnosis - , encodeTyped encodeDecompositionReply - , encodeTyped encodeDerivation - , encodeTyped encodeDerivationText - , encodeTyped encodeDifficulty - , encodeTyped encodeMessage - , encoderStateFor $ \xp (val ::: tp) -> +xmlEncoder :: TypedEncoder a XMLBuilder +xmlEncoder = + (encodeDiagnosis, tDiagnosis) <?> + (encodeDecompositionReply, PD.tReply) <?> + (encodeDerivation, tDerivation (tPair tRule tEnvironment) tContext) <?> + (encodeDerivationText, tDerivation tString tContext) <?> + (encodeDifficulty, tDifficulty) <?> + (encodeMessage, FeedbackText.tMessage) <?> + encoderFor (\(val ::: tp) -> case tp of -- meta-information Tag "RuleShortInfo" t -> @@ -64,7 +57,9 @@ Just f -> ruleShortInfo // f val Nothing -> fail "rule short info" Tag "RulesInfo" _ -> - return (rulesInfoXML (getExercise xp) (encodeTerm xp)) + withExercise $ \ex -> + withOpenMath $ \useOM -> + pure (rulesInfoXML ex (buildTerm useOM ex)) Tag "elem" t -> tag "elem" (xmlEncoder // (val ::: t)) -- special cases for lists @@ -82,8 +77,7 @@ Right b -> xmlEncoder // (b ::: t2) Unit -> mempty Const t -> xmlEncoderConst // (val ::: t) - _ -> fail $ show tp - ] + _ -> fail $ show tp) xmlEncoderConst :: XMLEncoder a (TypedValue (Const a)) xmlEncoderConst = encoderFor $ \tv@(val ::: tp) -> @@ -102,56 +96,59 @@ encodeState :: XMLEncoder a (State a) encodeState = encoderFor $ \st -> element "state" - [ encodePrefixes // statePrefixes st + [ if withoutPrefix st + then mempty + else element "prefix" [string (show (statePrefix st))] , encodeContext // stateContext st ] -encodePrefixes :: XMLEncoder a [Prefix (Context a)] -encodePrefixes = encoderFor $ \ps -> - case ps of - [] -> mempty - _ -> element "prefix" $ map (string . showPrefix) ps - encodeContext :: XMLEncoder a (Context a) -encodeContext = encoderStateFor $ \xp ctx -> - liftM (encodeTerm xp) (fromContext ctx) +encodeContext = withOpenMath $ \useOM -> exerciseEncoder $ \ex ctx -> + maybe (error "encodeContext") (buildTerm useOM ex) (fromContext ctx) <> let values = bindings (withLoc ctx) loc = fromLocation (location ctx) withLoc | null loc = id | otherwise = insertRef (makeRef "location") loc - in return $ munless (null values) $ element "context" + in munless (null values) $ element "context" [ element "item" [ "name" .=. showId tb , case getTermValue tb of - term | isOpenMath xp -> + term | useOM -> builder (omobj2xml (toOMOBJ term)) _ -> "value" .=. showValue tb ] | tb <- values ] +buildTerm :: BuildXML b => Bool -> Exercise a -> a -> b +buildTerm useOM ex + | useOM = either msg (builder . toXML) . toOpenMath ex + | otherwise = tag "expr" . string . prettyPrinter ex + where + msg s = error ("Error encoding term in OpenMath: " ++ s) + encodeLocation :: XMLEncoder a Location -encodeLocation = encoderFor $ \loc -> return ("location" .=. show loc) +encodeLocation = encoderFor $ \loc -> "location" .=. show loc encodeEnvironment :: HasEnvironment env => XMLEncoder a env encodeEnvironment = encoderFor $ \env -> mconcat [ encodeTypedBinding // b | b <- bindings env ] encodeTypedBinding :: XMLEncoder a Binding -encodeTypedBinding = encoderStateFor $ \xp tb -> +encodeTypedBinding = withOpenMath $ \useOM -> makeEncoder $ \tb -> tag "argument" $ ("description" .=. showId tb) <> case getTermValue tb of - term | isOpenMath xp -> builder $ + term | useOM -> builder $ omobj2xml $ toOMOBJ term _ -> string (showValue tb) encodeDerivation :: XMLEncoder a (Derivation (Rule (Context a), Environment) (Context a)) encodeDerivation = encoderFor $ \d -> let xs = [ (s, a) | (_, s, a) <- triples d ] - in xmlEncoder // (xs ::: typed) + in xmlEncoder // (xs ::: tList (tPair (tPair tRule tEnvironment) tContext)) encodeDerivationText :: XMLEncoder a (Derivation String (Context a)) encodeDerivationText = encoderFor $ \d -> encodeAsList @@ -160,7 +157,7 @@ ] ruleShortInfo :: XMLEncoder a (Rule (Context a)) -ruleShortInfo = simpleEncoder $ \r -> mconcat +ruleShortInfo = makeEncoder $ \r -> mconcat [ "name" .=. showId r , "buggy" .=. showBool (isBuggy r) , "arguments" .=. show (length (getRefs r)) @@ -168,19 +165,19 @@ ] encodeDifficulty :: XMLEncoder a Difficulty -encodeDifficulty = simpleEncoder $ \d -> +encodeDifficulty = makeEncoder $ \d -> "difficulty" .=. show d encodeText :: XMLEncoder a Text encodeText = encoderFor $ \txt -> mconcat [ encodeItem // item | item <- textItems txt ] where - encodeItem = encoderStateFor $ \xp item -> return $ + encodeItem = withOpenMath $ \useOM -> exerciseEncoder $ \ex item -> case item of TextTerm a -> fromMaybe (text item) $ do - v <- hasTermView (getExercise xp) + v <- hasTermView ex b <- match v a - return (encodeTerm xp b) + return (buildTerm useOM ex b) _ -> text item encodeMessage :: XMLEncoder a FeedbackText.Message @@ -198,7 +195,7 @@ Buggy env r -> element "buggy" [encodeEnvironment // env, "ruleid" .=. showId r] NotEquivalent s -> - if null s then return (emptyTag "notequiv") + if null s then emptyTag "notequiv" else element "notequiv" [ "reason" .=. s ] Similar b st -> element "similar" ["ready" .=. showBool b, encodeState // st]
src/Ideas/Encoding/Evaluator.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,163 +10,35 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Evaluator.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Evaluator.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.Evaluator - ( EncoderState, simpleEncoder, maybeEncoder, eitherEncoder - , encoderFor, encoderStateFor, encodeTyped - , runEncoderState, runEncoderStateM, (//) - , getState, withState - -- re-export - , pure, (<$>), (<**>) - , module Data.Monoid, liftA2 - -- old - , Evaluator(..), evalService + ( Evaluator(..), evalService ) where -import Control.Applicative hiding (Const) -import Control.Arrow -import Control.Monad -import Data.List -import Data.Monoid -import Ideas.Common.Classes +import Ideas.Encoding.Encoder import Ideas.Service.Types -import Ideas.Text.XML -import qualified Control.Category as C -newtype EncoderState st a b = Enc (st -> a -> Either [String] b) - -instance C.Category (EncoderState st) where - id = Enc $ const Right - Enc f . Enc g = Enc $ \st -> either Left (f st) . g st - -instance Arrow (EncoderState st) where - arr f = Enc $ \_ -> Right . f - first (Enc f) = Enc $ \st (a, c) -> fmap (\b -> (b, c)) (f st a) - second (Enc f) = Enc $ \st (a, b) -> fmap (\c -> (a, c)) (f st b) - Enc f *** Enc g = Enc $ \st (a, b) -> - case (f st a, g st b) of - (Right c, Right d) -> Right (c, d) - (Left err, _) -> Left err - (_, Left err) -> Left err - -instance ArrowZero (EncoderState st) where - zeroArrow = Enc $ \_ _ -> Left [] - -instance ArrowPlus (EncoderState st) where - Enc f <+> Enc g = Enc $ \st a -> - case (f st a, g st a) of - (Right b, _ ) -> Right b - (_, Right b) -> Right b - (Left e1, Left e2) -> Left (e1 ++ e2) - -instance ArrowChoice (EncoderState st) where - left (Enc f) = Enc $ \st -> either (fmap Left . f st) (Right . Right) - right (Enc f) = Enc $ \st -> either (Right . Left) (fmap Right . f st) - Enc f +++ Enc g = Enc $ \st -> either (fmap Left . f st) (fmap Right . g st) - -instance ArrowApply (EncoderState st) where - app = Enc $ \st (Enc f, a) -> f st a - -instance Functor (EncoderState st a) where - fmap = liftA - -instance Applicative (EncoderState st a) where - pure = arr . const - f <*> g = f &&& g >>> arr (uncurry ($)) - -instance Monoid b => Monoid (EncoderState st a b) where - mempty = pure mempty - mappend = liftA2 (<>) - -instance Monad (EncoderState st a) where - return = pure - fail s = Enc $ \_ _ -> Left [ s | not (null s) ] - Enc f >>= g = Enc $ \st a -> - case f st a of - Left err -> Left err - Right b -> let Enc h = g b in h st a - -instance MonadPlus (EncoderState st a) where - mzero = zeroArrow - mplus = (<+>) - -instance BuildXML b => BuildXML (EncoderState st a b) where - n .=. s = return (n .=. s) - unescaped = return . unescaped - builder = return . builder - tag = liftM . tag - -getState :: EncoderState st a st -getState = Enc $ const . Right - -withState :: (st -> b) -> EncoderState st a b -withState f = liftM f getState - -runEncoderState :: EncoderState st a b -> st -> a -> Either String b -runEncoderState (Enc f) st = mapFirst (intercalate ", ") . f st - ---- - -simpleEncoder :: (a -> b) -> EncoderState st a b -simpleEncoder = arr - -maybeEncoder :: (a -> Maybe b) -> EncoderState st a b -maybeEncoder f = C.id >>= maybe mzero return . f - -eitherEncoder :: (a -> Either String b) -> EncoderState st a b -eitherEncoder f = C.id >>= either fail return . f - -encoderFor :: (a -> EncoderState st a b) -> EncoderState st a b -encoderFor = encoderStateFor . const - -encoderStateFor :: (st -> a -> EncoderState st a b) -> EncoderState st a b -encoderStateFor f = do - st <- getState - a <- C.id - f st a - -runEncoderStateM :: Monad m => EncoderState st a b -> st -> a -> m b -runEncoderStateM f st = either fail return . runEncoderState f st - -encodeTyped :: Typed a t => EncoderState st t b -> EncoderState st (TypedValue (Type a)) b -encodeTyped enc = fromTyped >>> enc - -infixl 8 // - -(//) :: EncoderState st a c -> a -> EncoderState st b c -f // a = arr (const a) >>> f - ----- - -fromTyped :: Typed a t => EncoderState st (TypedValue (Type a)) t -fromTyped = maybeEncoder $ \(val ::: tp) -> fmap ($ val) (equal tp typed) - -------------------------------------------------------------------- - -evalService :: Evaluator a b -> Service -> IO b -evalService f = eval f . serviceFunction +data Evaluator a b c = Evaluator (TypedDecoder a b) (TypedEncoder a c) -data Evaluator a b where - Evaluator :: (TypedValue (Type a) -> IO b) -- encoder - -> (forall t . Type a t -> IO t) -- decoder - -> Evaluator a b +evalService :: Options a -> Evaluator a b c -> Service -> b -> IO c +evalService opts f = eval opts f . serviceFunction -eval :: Evaluator a b -> TypedValue (Type a) -> IO b -eval f@(Evaluator enc dec) tv@(val ::: tp) = +eval :: Options a -> Evaluator a b c -> TypedValue (Type a) -> b -> IO c +eval opts f@(Evaluator dec enc) tv@(val ::: tp) b = case tp of -- handle exceptions Const String :|: t -> - either fail (\a -> eval f (a ::: t)) val + either fail (\a -> eval opts f (a ::: t) b) val -- uncurry function if possible t1 :-> t2 :-> t3 -> - eval f (uncurry val ::: Pair t1 t2 :-> t3) + eval opts f (uncurry val ::: Pair t1 t2 :-> t3) b t1 :-> t2 -> do - a <- dec t1 - eval f (val a ::: t2) + a <- run (dec t1) opts b + eval opts f (val a ::: t2) b -- perform IO IO t -> do a <- val - eval f (a ::: t) + eval opts f (a ::: t) b _ -> - enc tv+ run enc opts tv
src/Ideas/Encoding/LinkManager.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- Manages links to information -- ----------------------------------------------------------------------------- --- $Id: LinkManager.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: LinkManager.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.LinkManager ( LinkManager(..) @@ -25,12 +25,13 @@ , linkToDerivations, linkToRule, linkToRandomExample, linkToTestReport -- links to state information (dynamic) , linkToState, linkToFirsts, linkToApplications, linkToDerivation + , linkToMicrosteps ) where import Data.Maybe import Ideas.Common.Library +import Ideas.Encoding.Encoder import Ideas.Encoding.EncoderXML -import Ideas.Encoding.Evaluator import Ideas.Service.State import Ideas.Service.Types import Ideas.Text.HTML @@ -61,6 +62,7 @@ , urlForFirsts :: forall a . State a -> String , urlForApplications :: forall a . State a -> String , urlForDerivation :: forall a . State a -> String + , urlForMicrosteps :: forall a . State a -> String } --------------------------------------------------------------------- @@ -117,6 +119,9 @@ linkToFirsts :: LinkManager -> State a -> HTMLBuilder -> HTMLBuilder linkToFirsts = linkWith . urlForFirsts +linkToMicrosteps :: LinkManager -> State a -> HTMLBuilder -> HTMLBuilder +linkToMicrosteps = linkWith . urlForMicrosteps + linkToApplications :: LinkManager -> State a -> HTMLBuilder -> HTMLBuilder linkToApplications = linkWith . urlForApplications @@ -153,10 +158,11 @@ , urlForFirsts = url . stateRequest "allfirsts" , urlForApplications = url . stateRequest "allapplications" , urlForDerivation = url . stateRequest "derivation" + , urlForMicrosteps = url . stateRequest "microsteps" } where prefix = cgiBinary ++ "?input=" - url req = prefix ++ show req + url req = prefix ++ compactXML req simpleRequest :: String -> XML simpleRequest s = makeRequest s mempty @@ -180,10 +186,8 @@ -- assume nothing goest wrong stateToXML :: State a -> XMLBuilder -stateToXML st = fromMaybe mempty (runEncoderStateM encodeState xes st) - where - enc = tag "expr" . string . prettyPrinter (exercise st) - xes = XMLEncoderState (exercise st) False enc +stateToXML st = fromMaybe (error "LinkManager: Invalid state") $ + run encodeState (simpleOptions (exercise st)) st linkWith :: (a -> String) -> a -> HTMLBuilder -> HTMLBuilder linkWith f = link . escapeInURL . f @@ -228,6 +232,7 @@ , urlForFirsts = const "" , urlForApplications = const "" , urlForDerivation = const "" + , urlForMicrosteps = const "" } linksUp :: Int -> LinkManager -> LinkManager @@ -252,6 +257,7 @@ , urlForFirsts = f1 urlForFirsts , urlForApplications = f1 urlForApplications , urlForDerivation = f1 urlForDerivation + , urlForMicrosteps = f1 urlForMicrosteps } where f0 g = pathUp n $ g lm
src/Ideas/Encoding/ModeJSON.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Services using JSON notation -- ----------------------------------------------------------------------------- --- $Id: ModeJSON.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: ModeJSON.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.ModeJSON (processJSON) where @@ -19,21 +19,20 @@ import Ideas.Common.Library hiding (exerciseId) import Ideas.Common.Utils (Some(..), timedSeconds) import Ideas.Encoding.DecoderJSON +import Ideas.Encoding.Encoder (makeOptions) import Ideas.Encoding.EncoderJSON import Ideas.Encoding.Evaluator import Ideas.Service.DomainReasoner -import Ideas.Service.FeedbackScript.Syntax (Script) import Ideas.Service.Request import Ideas.Text.JSON -import System.Random hiding (getStdGen) -processJSON :: Maybe Int -> Bool -> DomainReasoner -> String -> IO (Request, String, String) -processJSON maxTime cgiMode dr input = do +processJSON :: Maybe Int -> Maybe String -> DomainReasoner -> String -> IO (Request, String, String) +processJSON maxTime cgiBin dr input = do json <- either fail return (parseJSON input) - req <- jsonRequest json + req <- jsonRequest cgiBin json resp <- jsonRPC json $ \fun arg -> - maybe id timedSeconds maxTime (myHandler dr fun arg) - let f = if compactOutputDefault cgiMode req then compactJSON else show + maybe id timedSeconds maxTime (myHandler dr req fun arg) + let f = if compactOutput req then compactJSON else show out = addVersion (version dr) (toJSON resp) return (req, f out, "application/json") @@ -58,12 +57,13 @@ where info = ("version", String str) -jsonRequest :: Monad m => JSON -> m Request -jsonRequest json = do +jsonRequest :: Monad m => Maybe String -> JSON -> m Request +jsonRequest cgiBin json = do srv <- case lookupM "method" json of - Just (String s) -> return s + Just (String s) -> return (Just (newId s)) + Nothing -> return Nothing _ -> fail "Invalid method" - let a = lookupM "params" json >>= extractExerciseId + let exId = lookupM "params" json >>= extractExerciseId enc <- case lookupM "encoding" json of Nothing -> return [] Just (String s) -> readEncoding s @@ -72,28 +72,25 @@ Nothing -> return Nothing Just (String s) -> return (Just s) _ -> fail "Invalid source" - return Request - { service = srv - , exerciseId = a + let uid = case lookupM "id" json of + Just (String s) -> Just s + Just (Number (I n)) -> Just (show n) + _ -> Nothing + return emptyRequest + { serviceId = srv + , exerciseId = exId + , user = uid , source = src + , cgiBinary = cgiBin , dataformat = JSON , encoding = enc } -myHandler :: DomainReasoner -> RPCHandler -myHandler dr fun json = do +myHandler :: DomainReasoner -> Request -> RPCHandler +myHandler dr request fun json = do srv <- findService dr (newId fun) - Some ex <- - if fun == "exerciselist" - then return (Some emptyExercise) - else extractExerciseId json >>= findExercise dr - script <- defaultScript dr (getId ex) - stdgen <- newStdGen - evalService (jsonConverter script ex stdgen json) srv + Some options <- makeOptions dr request + evalService options jsonEvaluator srv json -jsonConverter :: Script -> Exercise a -> StdGen -> JSON -> Evaluator a JSON -jsonConverter script ex stdgen json = Evaluator - (runEncoderStateM jsonEncoder (String . prettyPrinter ex)) - (\tp -> runEncoderStateM (jsonDecoder tp) jds json) - where - jds = JSONDecoderState ex script stdgen+jsonEvaluator :: Evaluator a JSON JSON +jsonEvaluator = Evaluator jsonDecoder jsonEncoder
src/Ideas/Encoding/ModeXML.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- --- $Id: ModeXML.hs 6541 2014-05-14 18:44:36Z bastiaan $ +-- $Id: ModeXML.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.ModeXML (processXML) where @@ -21,29 +21,24 @@ import Ideas.Common.Library hiding (exerciseId, (:=)) import Ideas.Common.Utils (Some(..), timedSeconds) import Ideas.Encoding.DecoderXML +import Ideas.Encoding.Encoder (makeOptions) import Ideas.Encoding.EncoderHTML import Ideas.Encoding.EncoderXML import Ideas.Encoding.Evaluator -import Ideas.Encoding.LinkManager -import Ideas.Encoding.OpenMathSupport import Ideas.Service.DomainReasoner -import Ideas.Service.FeedbackScript.Parser (parseScriptSafe) -import Ideas.Service.FeedbackScript.Syntax (Script) import Ideas.Service.Request import Ideas.Text.HTML -import Ideas.Text.OpenMath.Object import Ideas.Text.XML import Prelude hiding (catch) import System.IO.Error hiding (catch) -import System.Random (StdGen, newStdGen) -processXML :: Maybe Int -> DomainReasoner -> Maybe String -> String -> IO (Request, String, String) -processXML maxTime dr cgiBin input = do +processXML :: Maybe Int -> Maybe String -> DomainReasoner -> String -> IO (Request, String, String) +processXML maxTime cgiBin dr input = do xml <- either fail return (parseXML input) - req <- either fail return (xmlRequest xml) - resp <- maybe id timedSeconds maxTime (xmlReply dr cgiBin req xml) + req <- xmlRequest cgiBin xml + resp <- maybe id timedSeconds maxTime (xmlReply dr req xml) `catch` handler - let showXML | compactOutputDefault (isJust cgiBin) req = compactXML + let showXML | compactOutput req = compactXML | otherwise = show if htmlOutput req then return (req, showXML resp, "text/html") @@ -58,54 +53,40 @@ let info = [ "version" := s ] in xml { attributes = attributes xml ++ info } -xmlRequest :: XML -> Either String Request -xmlRequest xml = do +xmlRequest :: Monad m => Maybe String -> XML -> m Request +xmlRequest cgiBin xml = do unless (name xml == "request") $ fail "expected xml tag request" - srv <- findAttribute "service" xml - let a = extractExerciseId xml enc <- case findAttribute "encoding" xml of Just s -> readEncoding s Nothing -> return [] - return Request - { service = srv - , exerciseId = a - , source = findAttribute "source" xml - , dataformat = XML - , encoding = enc + return emptyRequest + { serviceId = fmap newId $ findAttribute "service" xml + , exerciseId = extractExerciseId xml + , user = findAttribute "userid" xml + , source = findAttribute "source" xml + , feedbackScript = findAttribute "script" xml + , cgiBinary = cgiBin + , dataformat = XML + , encoding = enc } -xmlReply :: DomainReasoner -> Maybe String -> Request -> XML -> IO XML -xmlReply dr cgiBin request xml = do - srv <- findService dr (newId (service request)) - Some ex <- - case exerciseId request of - Just code -> findExercise dr code - Nothing - | service request `elem` ["exerciselist", "servicelist", "serviceinfo", "index"] -> - return (Some emptyExercise) - | otherwise -> - fail "unknown exercise code" - script <- case findAttribute "script" xml of - Just s -> parseScriptSafe s - Nothing - | getId ex == mempty -> return mempty - | otherwise -> defaultScript dr (getId ex) - stdgen <- newStdGen +xmlReply :: DomainReasoner -> Request -> XML -> IO XML +xmlReply dr request xml = do + srv <- case serviceId request of + Just a -> findService dr a + Nothing -> fail "No service" - -- HTML encoder + Some options <- makeOptions dr request + + -- HTML evaluator if htmlOutput request then do - res <- evalService (htmlConverter dr cgiBin script ex stdgen xml) srv + res <- evalService options (htmlEvaluator dr) srv xml return (toXML res) - -- OpenMath encoder - else if useOpenMath request - then do - res <- evalService (openMathConverter True script ex stdgen xml) srv - return (resultOk res) - -- String encoder + -- xml evaluator else do - res <- evalService (stringFormatConverter script ex stdgen xml) srv + res <- evalService options xmlEvaluator srv xml return (resultOk res) extractExerciseId :: Monad m => XML -> m Id @@ -122,41 +103,9 @@ <> tag "message" (string txt) ------------------------------------------------------------ --- Mixing abstract syntax (OpenMath format) and concrete syntax (string) -stringFormatConverter :: Script -> Exercise a -> StdGen -> XML -> Evaluator a XMLBuilder -stringFormatConverter script ex stdgen xml = - Evaluator (runEncoderStateM xmlEncoder xes) - (\tp -> runEncoderStateM (xmlDecoder tp) xds xml) - where - xes = XMLEncoderState ex False (tag "expr" . string . prettyPrinter ex) - xds = XMLDecoderState ex script stdgen False g - g = (liftM getData . findChild "expr") >=> parser ex - -htmlConverter :: DomainReasoner -> Maybe String -> Script -> Exercise a -> StdGen -> XML -> Evaluator a HTMLPage -htmlConverter dr cgiBin script ex stdgen xml = - Evaluator (return . htmlEncoder lm dr ex) d - where - lm = maybe staticLinks dynamicLinks cgiBin - Evaluator _ d = stringFormatConverter script ex stdgen xml +xmlEvaluator :: Evaluator a XML XMLBuilder +xmlEvaluator = Evaluator xmlDecoder xmlEncoder -openMathConverter :: Bool -> Script -> Exercise a -> StdGen -> XML -> Evaluator a XMLBuilder -openMathConverter withMF script ex stdgen xml = - Evaluator (runEncoderStateM xmlEncoder xes) - (\tp -> runEncoderStateM (xmlDecoder tp) xds xml) - where - xes = XMLEncoderState ex True h - xds = XMLDecoderState ex script stdgen True g - h a = case toOpenMath ex a of - Left _ -> error "Error encoding term in OpenMath" -- fix me! - Right omobj -> builder (toXML (handleMixedFractions omobj)) - g xml0 = do - xob <- findChild "OMOBJ" xml0 - case xml2omobj xob of - Left msg -> Left msg - Right omobj -> - case fromOpenMath ex omobj of - Just a -> Right a - Nothing -> Left "Invalid OpenMath object for this exercise" - -- Remove special mixed-fraction symbol (depending on boolean argument) - handleMixedFractions = if withMF then id else noMixedFractions+htmlEvaluator :: DomainReasoner -> Evaluator a XML HTMLPage +htmlEvaluator dr = Evaluator xmlDecoder (htmlEncoder dr)
src/Ideas/Encoding/OpenMathSupport.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: OpenMathSupport.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: OpenMathSupport.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.OpenMathSupport ( -- * Conversion functions to/from OpenMath
src/Ideas/Encoding/RulePresenter.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: RulePresenter.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: RulePresenter.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.RulePresenter (ruleToHTML) where
src/Ideas/Encoding/RulesInfo.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: RulesInfo.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: RulesInfo.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.RulesInfo ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap @@ -68,11 +68,9 @@ collectExamples :: Exercise a -> ExampleMap a collectExamples ex = foldr (add . snd) M.empty (examples ex) where - add a m = let tree = derivationTree (strategy ex) (inContext ex a) - f Nothing = m - f (Just d) = foldr g m (triples d) + add a m = let f = foldr g m . maybe [] triples g (x, (r, _), y) = case fromContextWith2 (,) x y of Just p -> M.insertWith (++) (getId r) [p] Nothing -> id - in f (derivation tree)+ in f (defaultDerivation ex a)
src/Ideas/Encoding/StrategyInfo.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,14 +11,12 @@ -- Converting a strategy to XML, and the other way around. -- ----------------------------------------------------------------------------- --- $Id: StrategyInfo.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: StrategyInfo.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Encoding.StrategyInfo (strategyToXML, xmlToStrategy) where import Control.Monad -import Data.Char -import Data.Maybe -import Ideas.Common.Library +import Ideas.Common.Library hiding (Remove, Collapse, Hide, (:=)) import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Core import Ideas.Common.Utils (readInt) @@ -30,62 +28,71 @@ strategyToXML :: IsStrategy f => f a -> XML strategyToXML = coreToXML . toCore . toStrategy -infoToXML :: LabelInfo -> XMLBuilder -infoToXML info = mconcat - [ "name" .=. showId info - , mwhen (removed info) ("removed" .=. "true") - , mwhen (collapsed info) ("collapsed" .=. "true") - , mwhen (hidden info) ("hidden" .=. "true") - ] +nameAttr :: Id -> XMLBuilder +nameAttr info = "name" .=. showId info -coreToXML :: Core LabelInfo a -> XML +coreToXML :: Core a -> XML coreToXML core = makeXML "label" $ case core of - Label l a -> infoToXML l <> coreBuilder infoToXML a - _ -> coreBuilder infoToXML core + Label l a -> nameAttr l <> coreBuilder a + _ -> coreBuilder core -coreBuilder :: HasId l => (l -> XMLBuilder) -> Core l a -> XMLBuilder -coreBuilder f = rec +coreBuilder :: Core a -> XMLBuilder +coreBuilder core = + case core of + _ :*: _ -> asList "sequence" isSequence + _ :|: _ -> asList "choice" isChoice + _ :>|> _ -> asList "preference" isPreference + _ :|>: _ -> asList "orelse" isOrElse + _ :%: _ -> asList "interleave" isInterleave + a :@: b -> tag "alternate" (coreBuilder a <> coreBuilder b) + Label l (Rule r) | getId l == getId r + -> tag "rule" (nameAttr l) + Label l a -> tag "label" (nameAttr l <> coreBuilder a) + Atomic a -> tag "atomic" (coreBuilder a) + Not a -> tag "not" (coreBuilder a) + Remove a -> cfgItem "removed" (coreBuilder a) + Collapse a -> cfgItem "collapsed" (coreBuilder a) + Hide a -> cfgItem "hidden" (coreBuilder a) + Let ds a -> tag "let" (decls ds <> coreBuilder a) + Rule r -> tag "rule" ("name" .=. show r) + Var n -> tag "var" ("var" .=. show n) + Succeed -> emptyTag "succeed" + Fail -> emptyTag "fail" where - rec core = - case core of - _ :*: _ -> asList "sequence" isSequence - _ :|: _ -> asList "choice" isChoice - _ :|>: _ -> asList "orelse" isOrElse - _ :%: _ -> asList "interleave" isInterleave - a :@: b -> tag "alternate" (rec a <> rec b) - Label l (Rule r) | getId l == getId r - -> tag "rule" (f l) - Label l a -> tag "label" (f l <> rec a) - Atomic a -> tag "atomic" (rec a) - Let ds a -> tag "let" (decls ds <> rec a) - Rule r -> tag "rule" ("name" .=. show r) - Var n -> tag "var" ("var" .=. show n) - Succeed -> emptyTag "succeed" - Fail -> emptyTag "fail" - where - asList s g = element s (map rec (collect g core)) - decls ds = mconcat [ tag "decl" (("var" .=. show n) <> rec a) - | (n, a) <- ds - ] + asList s g = element s (map coreBuilder (collect g core)) + decls ds = mconcat [ tag "decl" (("var" .=. show n) <> coreBuilder a) + | (n, a) <- ds + ] +cfgItem :: String -> XMLBuilder -> XMLBuilder +cfgItem s a = + case fromBuilder a of + Just e | name e `elem` ["label", "rule"] -> + builder e { attributes = attributes e ++ [s := "true"] } + _ -> tag s a + collect :: (a -> Maybe (a, a)) -> a -> [a] collect f = ($ []) . rec where rec a = maybe (a:) (\(x, y) -> rec x . rec y) (f a) -isSequence :: Core l a -> Maybe (Core l a, Core l a) +isSequence :: Core a -> Maybe (Core a, Core a) isSequence (a :*: b) = Just (a, b) isSequence _ = Nothing -isChoice :: Core l a -> Maybe (Core l a, Core l a) +isChoice :: Core a -> Maybe (Core a, Core a) isChoice (a :|: b) = Just (a, b) isChoice _ = Nothing -isOrElse :: Core l a -> Maybe (Core l a, Core l a) +isPreference :: Core a -> Maybe (Core a, Core a) +isPreference (a :>|> b) = Just (a, b) +isPreference _ = Nothing + +isOrElse :: Core a -> Maybe (Core a, Core a) isOrElse (a :|>: b) = Just (a, b) isOrElse _ = Nothing -isInterleave :: Core l a -> Maybe (Core l a, Core l a) +isInterleave :: Core a -> Maybe (Core a, Core a) isInterleave (a :%: b) = Just (a, b) isInterleave _ = Nothing @@ -99,25 +106,21 @@ Just r -> return r Nothing -> fail $ "Unknown rule: " ++ showId info -xmlToInfo :: Monad m => XML -> m LabelInfo +xmlToInfo :: Monad m => XML -> m Id xmlToInfo xml = do n <- findAttribute "name" xml - let boolAttr s = fromMaybe False (findBool s xml) - return (makeInfo n) - { removed = boolAttr "removed" - , collapsed = boolAttr "collapsed" - , hidden = boolAttr "hidden" - } - + -- let boolAttr s = fromMaybe False (findBool s xml) + return (newId n) +{- findBool :: Monad m => String -> XML -> m Bool findBool attr xml = do s <- findAttribute attr xml case map toLower s of "true" -> return True "false" -> return False - _ -> fail "not a boolean" + _ -> fail "not a boolean" -} -readStrategy :: Monad m => (XML -> m l) -> (l -> m (Rule a)) -> XML -> m (Core l a) +readStrategy :: Monad m => (XML -> m Id) -> (Id -> m (Rule a)) -> XML -> m (Core a) readStrategy toLabel findRule xml = do xs <- mapM (readStrategy toLabel findRule) (children xml) let s = name xml
src/Ideas/Main/BlackBoxTests.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,12 +9,12 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: BlackBoxTests.hs 6537 2014-05-14 12:23:17Z bastiaan $ +-- $Id: BlackBoxTests.hs 7528 2015-04-08 09:44:10Z bastiaan $ module Ideas.Main.BlackBoxTests (blackBoxTests) where -import Control.Exception import Control.Monad +import Data.Char import Data.List import Ideas.Common.Utils (useFixedStdGen, snd3) import Ideas.Common.Utils.TestSuite @@ -24,6 +24,7 @@ import Ideas.Service.Request import System.Directory import System.IO +import qualified Data.Algorithm.Diff as Diff -- Returns the number of tests performed blackBoxTests :: DomainReasoner -> String -> IO TestSuite @@ -54,23 +55,43 @@ hSetBinaryMode h1 True txt <- hGetContents h1 out <- case format of - JSON -> liftM snd3 (processJSON Nothing False dr txt) - XML -> liftM snd3 (processXML Nothing dr Nothing txt) + JSON -> liftM snd3 (processJSON Nothing Nothing dr txt) + XML -> liftM snd3 (processXML Nothing Nothing dr txt) withFile expPath ReadMode $ \h2 -> do hSetBinaryMode h2 True expt <- hGetContents h2 -- Force evaluation of the result, to make sure that -- all file handles are closed afterwards. - if out ~= expt then return mempty else return (message path) + let list1 = prepare expt + list2 = prepare out + 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) where expPath = baseOf path ++ ".exp" baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse - x ~= y = filterVersion x == filterVersion y -- compare line-based -filterVersion :: String -> [String] -filterVersion = - let p s = not (null s || "version" `isInfixOf` s) - in filter p . lines . filter (/= '\r') +force :: String -> IO () +force s | sum (map ord s) >= 0 = return () + | otherwise = error "force" + +prepare :: String -> [String] +prepare = filter (not . null) . lines . filter (/= '\r') . noVersion + where + noVersion s | "version\": \"" `isPrefixOf` s = + "version\": \"X" ++ dropWhile (/='"') (drop 11 s) + noVersion s | "version=\"" `isPrefixOf` s = + "version=\"X" ++ dropWhile (/='"') (drop 9 s) + noVersion (x:xs) = x:noVersion xs + noVersion [] = [] + +diffs :: [String] -> [String] -> [String] +diffs xs ys = concatMap f $ Diff.getDiff xs ys + where + f (Diff.First a) = ["- " ++ a] + f (Diff.Second a) = ["+ " ++ a] + f _ = [] simplerDirectory :: String -> String simplerDirectory s
src/Ideas/Main/Default.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,10 +11,10 @@ -- Main module for feedback services -- ----------------------------------------------------------------------------- --- $Id: Default.hs 6541 2014-05-14 18:44:36Z bastiaan $ +-- $Id: Default.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Main.Default - ( defaultMain, newDomainReasoner + ( defaultMain, defaultCGI -- extra exports , Some(..), serviceList, metaServiceList, Service , module Ideas.Service.DomainReasoner @@ -23,10 +22,8 @@ import Control.Exception import Control.Monad -import Data.IORef import Data.Maybe import Data.Time -import Ideas.Common.Id import Ideas.Common.Utils (useFixedStdGen, Some(..)) import Ideas.Common.Utils.TestSuite import Ideas.Encoding.ModeJSON (processJSON) @@ -44,45 +41,56 @@ import Prelude hiding (catch) import System.IO import System.IO.Error (ioeGetErrorString) -import qualified Ideas.Main.Options as Options defaultMain :: DomainReasoner -> IO () defaultMain dr = do - startTime <- getCurrentTime - flags <- getFlags + flags <- getFlags if null flags - then defaultCGI dr startTime + then defaultCGI dr else defaultCommandLine dr flags -- Invoked as a cgi binary -defaultCGI :: DomainReasoner -> UTCTime -> IO () -defaultCGI dr startTime = do - logRef <- newIORef (return ()) - runCGI $ do - addr <- remoteAddr -- the IP address of the remote host making the request - cgiBin <- scriptName -- get name of binary - raw <- getInput "input" -- read input - input <- case raw of - Nothing -> fail "Invalid request: environment variable \"input\" is empty" - Just s -> return s - (req, txt, ctp) <- liftIO $ process dr (Just cgiBin) input - -- save logging action for later - when (useLogging req) $ - liftIO $ writeIORef logRef $ - logMessage req input txt addr startTime - setHeader "Content-type" ctp - -- Cross-Origin Resource Sharing (CORS) prevents browser warnings - -- about cross-site scripting - setHeader "Access-Control-Allow-Origin" "*" - output txt +defaultCGI :: DomainReasoner -> IO () +defaultCGI dr = runCGI $ handleErrors $ do + -- query environment + startTime <- liftIO getCurrentTime + addr <- remoteAddr -- the IP address of the remote host + cgiBin <- scriptName -- get name of binary + input <- inputOrDefault + -- process request + (req, txt, ctp) <- liftIO $ + process dr (Just cgiBin) input -- log request to database - join (readIORef logRef) - -- if something goes wrong - `catch` \ioe -> runCGI $ do - setHeader "Content-type" "text/plain" + when (useLogging req) $ + liftIO $ logMessage req input txt addr startTime + -- write header and output + setHeader "Content-type" ctp + -- Cross-Origin Resource Sharing (CORS) prevents browser warnings + -- about cross-site scripting setHeader "Access-Control-Allow-Origin" "*" - output ("Invalid request\n" ++ ioeGetErrorString ioe) + output txt +inputOrDefault :: CGI String +inputOrDefault = do + inHtml <- acceptsHTML + ms <- getInput "input" -- read variable 'input' + case ms of + Just s -> return s + Nothing + | inHtml -> return defaultBrowser + | otherwise -> fail "environment variable 'input' is empty" + where + -- Invoked from browser + defaultBrowser :: String + defaultBrowser = "<request service='index' encoding='html'/>" + + acceptsHTML :: CGI Bool + acceptsHTML = do + maybeAcceptCT <- requestAccept + let htmlCT = ContentType "text" "html" [] + xs = negotiate [htmlCT] maybeAcceptCT + return (isJust maybeAcceptCT && not (null xs)) + -- Invoked from command-line with flags defaultCommandLine :: DomainReasoner -> [Flag] -> IO () defaultCommandLine dr flags = do @@ -114,15 +122,12 @@ AnalyzeScript file -> parseAndAnalyzeScript dr file process :: DomainReasoner -> Maybe String -> String -> IO (Request, String, String) -process dr cgiBin input = - case discoverDataFormat input of - Just XML -> processXML (Just 5) dr cgiBin input - Just JSON -> processJSON (Just 5) (isJust cgiBin) dr input - _ -> fail "Invalid input" - -newDomainReasoner :: IsId a => a -> DomainReasoner -newDomainReasoner a = mempty - { reasonerId = newId a - , version = shortVersion - , fullVersion = Options.fullVersion - }+process dr cgiBin input = do + format <- discoverDataFormat input + run format (Just 5) cgiBin dr input + `catch` \ioe -> + let msg = "Error: " ++ ioeGetErrorString ioe + in return (emptyRequest, msg, "text/plain") + where + run XML = processXML + run JSON = processJSON
src/Ideas/Main/Documentation.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,13 +11,14 @@ -- Manages links to information -- ----------------------------------------------------------------------------- --- $Id: Documentation.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Documentation.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Main.Documentation (makeDocumentation) where import Control.Monad import Ideas.Common.Library import Ideas.Common.Utils +import Ideas.Encoding.Encoder (run, simpleOptions) import Ideas.Encoding.EncoderHTML import Ideas.Encoding.LinkManager import Ideas.Service.BasicServices @@ -30,27 +31,29 @@ makeDocumentation :: DomainReasoner -> String -> IO () makeDocumentation dr dir = do putStrLn "Generating index pages" - makeIndex urlForIndex (dr ::: typed) - makeIndex urlForExercises (exercises dr ::: typed) - makeIndex urlForServices (services dr ::: typed) + makeIndex urlForIndex (dr ::: tDomainReasoner) + makeIndex urlForExercises (exercises dr ::: tList tSomeExercise) + makeIndex urlForServices (services dr ::: tList tService) putStrLn "Generating service pages" forM_ (services dr) $ \srv -> - makeIndex (`urlForService` srv) (srv ::: typed) + makeIndex (`urlForService` srv) (srv ::: tService) putStrLn "Generating exercise pages" forM_ (exercises dr) $ \(Some ex) -> do - makeEx ex urlForExercise (ex ::: typed) - makeEx ex urlForStrategy (toStrategy (strategy ex) ::: typed) - makeEx ex urlForRules (ruleset ex ::: typed) - makeEx ex urlForExamples (map (second (inContext ex)) (examples ex) ::: typed) - makeEx ex urlForDerivations (exampleDerivations ex ::: typed) + makeEx ex urlForExercise (ex ::: tExercise) + makeEx ex urlForStrategy (toStrategy (strategy ex) ::: tStrategy) + makeEx ex urlForRules (ruleset ex ::: tList tRule) + makeEx ex urlForExamples (map (second (inContext ex)) (examples ex) ::: tList (tPair tDifficulty tContext)) + makeEx ex urlForDerivations (exampleDerivations ex ::: tError (tList (tDerivation (tPair tRule tEnvironment) tContext))) forM_ (ruleset ex) $ \r -> - make ex (urlForRule lm ex r) (r ::: typed) + make ex (urlForRule lm ex r) (r ::: tRule) where lm = staticLinks makeIndex f = make emptyExercise (f lm) makeEx ex f = make ex (f lm ex) - make ex url tv = safeWrite (dir </> url) $ - showHTML $ htmlEncoder (linksUp (pathLevel url) lm) dr ex tv + make ex url tv = do + let enc = htmlEncoderAt (pathLevel url) dr + html <- run enc (simpleOptions ex) tv + safeWrite (dir </> url) (showHTML html) safeWrite :: FilePath -> String -> IO () safeWrite filename txt = do
src/Ideas/Main/LoggingDatabase.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- Facilities to create a log database -- ----------------------------------------------------------------------------- --- $Id: LoggingDatabase.hs 6534 2014-05-14 06:02:03Z bastiaan $ +-- $Id: LoggingDatabase.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Main.LoggingDatabase (logMessage, logEnabled) where @@ -42,7 +42,7 @@ -- insert data into database run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" - [ toSql $ service req + [ toSql $ maybe "unknown" show (serviceId req) , toSql $ maybe "unknown" show (exerciseId req) , toSql $ fromMaybe "unknown" (source req) , toSql $ show (dataformat req)
src/Ideas/Main/Options.hs view
@@ -1,5 +1,5 @@ ---------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Options and command-line flags for services -- ----------------------------------------------------------------------------- --- $Id: Options.hs 6517 2014-05-06 16:01:59Z bastiaan $ +-- $Id: Options.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Main.Options ( Flag(..), getFlags @@ -33,7 +33,7 @@ header :: String header = "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++ - "Copyright 2014, Open Universiteit Nederland\n" ++ + "Copyright 2015, Open Universiteit Nederland\n" ++ versionText ++ "\n\nUsage: ideas [OPTION] (by default, CGI protocol)\n" ++ "\nOptions:"
src/Ideas/Main/Revision.hs view
@@ -2,10 +2,10 @@ module Ideas.Main.Revision where ideasVersion :: String-ideasVersion = "1.2"+ideasVersion = "1.3" ideasRevision :: Int-ideasRevision = 6534+ideasRevision = 7519 ideasLastChanged :: String-ideasLastChanged = "wo, 14 mei 2014"+ideasLastChanged = "wo, 08 apr 2015"
src/Ideas/Service/BasicServices.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,22 +9,23 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: BasicServices.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: BasicServices.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.BasicServices ( -- * Basic Services - stepsremaining, findbuggyrules, ready, allfirsts, derivation + stepsremaining, findbuggyrules, allfirsts, solution , onefirst, applicable, allapplications, apply, generate, create - , StepInfo, exampleDerivations, recognizeRule + , StepInfo, tStepInfo, exampleDerivations, recognizeRule ) where import Control.Monad import Data.List import Data.Maybe -import Ideas.Common.Library hiding (derivation, applicable, apply, ready) +import Ideas.Common.Library hiding (applicable, apply, ready) import Ideas.Common.Traversal.Navigator (downs, navigateTo) import Ideas.Common.Utils (fst3) import Ideas.Service.State +import Ideas.Service.Types import System.Random import qualified Ideas.Common.Classes as Apply import qualified Ideas.Common.Library as Library @@ -45,23 +46,23 @@ | otherwise -> Left "Not suitable" -- TODO: add a location to each step -derivation :: Maybe StrategyConfiguration -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a)) -derivation mcfg state = +solution :: Maybe StrategyCfg -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a)) +solution mcfg state = mapSecond (biMap (\(r, _, as) -> (r, as)) stateContext) $ case mcfg of - _ | null ps -> Left "Prefix is required" + _ | withoutPrefix state -> Left "Prefix is required" -- configuration is only allowed beforehand: hence, the prefix -- should be empty (or else, the configuration is ignored). This -- restriction should probably be relaxed later on. - Just cfg | all (null . prefixToSteps) ps -> + Just cfg | isEmptyPrefix prfx -> let newStrategy = configure cfg (strategy ex) newExercise = ex {strategy = newStrategy} in rec timeout d0 (emptyStateContext newExercise (stateContext state)) _ -> rec timeout d0 state where - d0 = emptyDerivation state - ex = exercise state - ps = statePrefixes state + d0 = emptyDerivation state + ex = exercise state + prfx = statePrefix state timeout = 50 :: Int rec i acc st = @@ -76,38 +77,22 @@ type StepInfo a = (Rule (Context a), Location, Environment) -- find a good place --- Note that we have to inspect the last step of the prefix afterwards, because --- the remaining part of the derivation could consist of minor rules only. +tStepInfo :: Type a (StepInfo a) +tStepInfo = tTuple3 tRule tLocation tEnvironment + allfirsts :: State a -> Either String [(StepInfo a, State a)] allfirsts state - | null ps = Left "Prefix is required" - | otherwise = - let trees = map tree ps - tree p = cutOnStep (justMajor . lastStepInPrefix) - (prefixTree (stateContext state) p) - f ((r1, _, _), _) ((r2, _, _), _) = - ruleOrdering (exercise state) r1 r2 - justMajor = maybe False isMajor - in Right $ noDuplicates $ sortBy f $ mapMaybe make $ concatMap derivations trees + | withoutPrefix state = Left "Prefix is required" + | otherwise = Right $ + noDuplicates $ map make $ firsts state where - ps = statePrefixes state - - make d = do - prefixEnd <- lastStep d - case lastStepInPrefix prefixEnd of - Just (RuleStep env r) | isMajor r -> return - ( (r - , location (lastTerm d) - , env) - , makeState (exercise state) [prefixEnd] (lastTerm d) - ) - _ -> Nothing + make ((s, ctx), st) = ((stepRule s, location ctx, stepEnvironment s), st) noDuplicates [] = [] noDuplicates (x:xs) = x : noDuplicates (filter (not . eq x) xs) - eq ((r1, l1, a1), s1) ((r2, l2, a2), s2) = - r1==r2 && l1==l2 && a1==a2 && exercise s1 == exercise s2 + eq (x1, s1) (x2, s2) = + x1 == x2 && exercise s1 == exercise s2 && similarity (exercise s1) (stateContext s1) (stateContext s2) onefirst :: State a -> Either String (StepInfo a, State a) @@ -151,8 +136,8 @@ -- 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 - | null (statePrefixes state) = applyOff - | otherwise = applyOn + | withoutPrefix state = applyOff + | otherwise = applyOn where applyOn = -- scenario 1: on-strategy maybe applyOff Right $ listToMaybe @@ -164,11 +149,8 @@ (new, _):_ -> Right (makeNoState (exercise state) new) [] -> Left ("Cannot apply " ++ show r) -ready :: State a -> Bool -ready state = isReady (exercise state) (stateTerm state) - stepsremaining :: State a -> Either String Int -stepsremaining = mapSecond derivationLength . derivation Nothing +stepsremaining = mapSecond derivationLength . solution Nothing findbuggyrules :: State a -> Context a -> [(Rule (Context a), Location, Environment)] findbuggyrules state a = @@ -192,4 +174,4 @@ concatMap rec (downs x) exampleDerivations :: Exercise a -> Either String [Derivation (Rule (Context a), Environment) (Context a)] -exampleDerivations ex = mapM (derivation Nothing . emptyState ex . snd) (examples ex)+exampleDerivations ex = mapM (solution Nothing . emptyState ex . snd) (examples ex)
src/Ideas/Service/Diagnose.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,10 +12,10 @@ -- Diagnose a term submitted by a student -- ----------------------------------------------------------------------------- --- $Id: Diagnose.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Diagnose.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.Diagnose - ( Diagnosis(..), diagnose, restartIfNeeded, newState + ( Diagnosis(..), tDiagnosis, diagnose, restartIfNeeded, newState , difference, differenceEqual ) where @@ -90,32 +90,32 @@ -- 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 - Just (r, _) -> WrongRule (ready state) state (Just r) + Just (r, _) -> WrongRule (finished state) state (Just r) Nothing -> case discovered True Nothing of -- search for buggy rule Just (r, as) -> Buggy as r -- report the buggy rule Nothing -> - WrongRule (ready state) state Nothing + 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 (ready ns) ns r + in Expected (finished ns) ns 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 (ready state) state + | similar = Similar (finished state) state -- Is the rule used discoverable by trying all known rules? | otherwise = case discovered False Nothing of Just (r, as) -> -- If yes, report the found rule as a detour - Detour (ready restarted) restarted as r + Detour (finished restarted) restarted as r Nothing -> -- If not, we give up - Correct (ready restarted) restarted + Correct (finished restarted) restarted where ex = exercise state restarted = restartIfNeeded (makeNoState ex new) @@ -148,15 +148,19 @@ -- When resetting the prefix, also make sure that the context is refreshed restartIfNeeded :: State a -> State a restartIfNeeded state - | null (statePrefixes state) && canBeRestarted ex = + | withoutPrefix state && canBeRestarted ex = emptyState ex (stateTerm state) | otherwise = state where ex = exercise state -instance Typed a (Diagnosis a) where - typed = Tag "Diagnosis" $ Iso (f <-> g) typed +tDiagnosis :: Type a (Diagnosis a) +tDiagnosis = Tag "Diagnosis" $ Iso (f <-> g) tp where + tp = (tPair tEnvironment tRule :|: (tString :|: tTuple3 tBool tState (tMaybe tRule))) + :|: tPair tBool tState :|: tTuple3 tBool tState tRule + :|: tTuple4 tBool tState tEnvironment tRule :|: tPair tBool tState :|: tPair tBool tState + f (Left (Left (as, r))) = Buggy as r -- f (Left (Right (Left ()))) = Missing -- f (Left (Right (Right (Left xs)))) = IncorrectPart xs
src/Ideas/Service/DomainReasoner.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,10 +10,10 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: DomainReasoner.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: DomainReasoner.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.DomainReasoner - ( DomainReasoner(..) + ( DomainReasoner(..), tDomainReasoner, newDomainReasoner , exercisesSorted, servicesSorted , findExercise, findService , defaultScript -- , readScript @@ -28,6 +28,7 @@ import Ideas.Common.Utils.TestSuite import Ideas.Service.FeedbackScript.Parser import Ideas.Service.Types +import qualified Ideas.Main.Options as Options ----------------------------------------------------------------------- -- Domain Reasoner data type @@ -62,16 +63,25 @@ getId = reasonerId changeId f dr = dr { reasonerId = f (reasonerId dr) } -instance Typed a DomainReasoner where - -- ignores views, testSuite - typed = Tag "DomainReasoner" $ Iso (f <-> g) typed +tDomainReasoner :: Type a DomainReasoner +tDomainReasoner = Tag "DomainReasoner" $ Iso (f <-> g) tp where + tp = tTuple3 (tTuple3 tId (tList tSomeExercise) (tList tService)) + (tPair (tList (tPair tId tId)) (tList (tPair tId tString))) + (tPair tString tString) f ((rid, ex, serv), (al, scr), (v, fv)) = DR rid ex serv [] al scr mempty v fv g dr = ( (reasonerId dr, exercises dr, services dr) , (aliases dr, scripts dr) , (version dr, fullVersion dr) ) + +newDomainReasoner :: IsId a => a -> DomainReasoner +newDomainReasoner a = mempty + { reasonerId = newId a + , version = Options.shortVersion + , fullVersion = Options.fullVersion + } ----------------------------------------------------------------------- -- Domain Reasoner functions
src/Ideas/Service/FeedbackScript/Analysis.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Analysis of a feedbackscript -- ----------------------------------------------------------------------------- --- $Id: Analysis.hs 6540 2014-05-14 15:13:00Z bastiaan $ +-- $Id: Analysis.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.FeedbackScript.Analysis ( -- Analysis functions
src/Ideas/Service/FeedbackScript/Parser.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Simple parser for feedback scripts -- ----------------------------------------------------------------------------- --- $Id: Parser.hs 6541 2014-05-14 18:44:36Z bastiaan $ +-- $Id: Parser.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.FeedbackScript.Parser ( parseScript, parseScriptSafe, Script @@ -154,7 +154,7 @@ lexString s = skip (lexeme (try (string s))) <?> "string " ++ show s comment :: Parser () -comment = skip (char '#' <* manyTill (noneOf "\n") (skip newline <|> eof)) +comment = char '#' *> many (satisfy (/= '\n')) *> (skip newline <|> eof) -- parse white space and comments afterwards lexeme :: Parser a -> Parser a
src/Ideas/Service/FeedbackScript/Run.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Run a feedbackscript -- ----------------------------------------------------------------------------- --- $Id: Run.hs 6536 2014-05-14 11:29:55Z bastiaan $ +-- $Id: Run.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.FeedbackScript.Run ( Script @@ -26,7 +26,6 @@ import Data.Maybe import Data.Monoid import Ideas.Common.Library hiding (ready, Environment) -import Ideas.Common.Strategy.Abstract (LabelInfo) import Ideas.Service.BasicServices import Ideas.Service.Diagnose import Ideas.Service.FeedbackScript.Syntax @@ -37,7 +36,6 @@ , expected :: Maybe (Rule (Context a)) , recognized :: Maybe (Rule (Context a)) , motivation :: Maybe (Rule (Context a)) - , actives :: Maybe [LabelInfo] , diffPair :: Maybe (String, String) , before :: Maybe Term , after :: Maybe Term @@ -51,11 +49,10 @@ newEnvironmentFor :: State a -> Maybe (Rule (Context a)) -> Maybe ((Rule (Context a), b, c), State a) -> Environment a newEnvironmentFor st motivationRule next = Env - { oldReady = ready st + { oldReady = finished st , expected = fmap (\((x,_,_),_) -> x) next , motivation = motivationRule , recognized = Nothing - , actives = listToMaybe (stateLabels st) , diffPair = Nothing , before = f st , after = liftM snd next >>= f
src/Ideas/Service/FeedbackScript/Syntax.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Abstract syntax for feedback scripts, and pretty-printer (Show instance) -- ----------------------------------------------------------------------------- --- $Id: Syntax.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Syntax.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.FeedbackScript.Syntax ( Script, makeScript, scriptDecls, makeText, textItems
src/Ideas/Service/FeedbackText.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,14 +10,14 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: FeedbackText.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: FeedbackText.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.FeedbackText - ( Message, accept, text + ( Message, tMessage, accept, text , onefirsttext, submittext, derivationtext, feedbacktext ) where -import Ideas.Common.Library hiding (derivation) +import Ideas.Common.Library import Ideas.Service.BasicServices import Ideas.Service.Diagnose import Ideas.Service.FeedbackScript.Run @@ -27,11 +27,12 @@ data Message = M { accept :: Maybe Bool, text :: Text } -instance Typed a Message where - typed = Tag "Message" $ Iso (f <-> g) typed - where - f = either (\(b, t) -> M (Just b) t) (M Nothing) - g m = maybe (Right (text m)) (\b -> Left (b, text m)) (accept m) +tMessage :: Type a Message +tMessage = Tag "Message" $ Iso (f <-> g) tp + where + tp = tPair tBool tText :|: tText + f = either (\(b, t) -> M (Just b) t) (M Nothing) + g m = maybe (Right (text m)) (\b -> Left (b, text m)) (accept m) ------------------------------------------------------------ -- Services @@ -39,7 +40,7 @@ derivationtext :: Script -> State a -> Either String (Derivation String (Context a)) derivationtext script state = let f = ruleToString (newEnvironment state Nothing) script . fst - in right (mapFirst f) (derivation Nothing state) + in right (mapFirst f) (solution Nothing state) onefirsttext :: Script -> State a -> Maybe String -> (Message, Maybe (State a)) onefirsttext script old event =
src/Ideas/Service/ProblemDecomposition.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,97 +10,81 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: ProblemDecomposition.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: ProblemDecomposition.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.ProblemDecomposition - ( problemDecomposition, Reply(..) + ( problemDecomposition, Reply(..), Answer, tAnswer, tReply ) where import Data.Maybe import Ideas.Common.Library +import Ideas.Common.Utils (fst3) import Ideas.Service.State import Ideas.Service.Types problemDecomposition :: Maybe Id -> State a -> Maybe (Answer a) -> Either String (Reply a) problemDecomposition msloc state maybeAnswer - | isNothing $ subStrategy sloc (strategy ex) = + | not (checkLocation sloc strat) = Left "request error: invalid location for strategy" | null answers = Left "strategy error: not able to compute an expected answer" - | otherwise = - case maybeAnswer of - Just (Answer answeredTerm) | not (null witnesses) -> Right $ - Ok newLocation newState - where - witnesses = filter (similarity ex answeredTerm . fst) $ take 1 answers - (newCtx, newPrefix) = head witnesses - newLocation = nextTaskLocation (strategy ex) sloc $ - fromMaybe topId $ nextMajorForPrefix newCtx newPrefix - newState = makeState ex [newPrefix] newCtx - _ -> Right $ - Incorrect isEquiv newLocation expState arguments - where - newLocation = subTaskLocation (strategy ex) sloc loc - expState = makeState ex [pref] expected - isEquiv = maybe False (equivalence ex expected . fromAnswer) maybeAnswer - (expected, pref) = head answers - (loc, arguments) = fromMaybe (topId, mempty) $ - firstMajorInPrefix prefix pref + | otherwise = Right $ + case maybeAnswer of + + Just (Answer answeredTerm) | not (null witnesses) -> + Ok newLocation newState + where + witnesses = filter (similarity ex answeredTerm . fst3) $ take 1 answers + (newCtx, _, newPrefix) = head witnesses + newLocation = nextTaskLocation strat sloc $ + fromMaybe topId $ nextMajorForPrefix newPrefix + newState = makeState ex newPrefix newCtx + + _ -> Incorrect isEquiv newLocation expState arguments + where + newLocation = subTaskLocation strat sloc loc + expState = makeState ex pref expected + isEquiv = maybe False (equivalence ex expected . fromAnswer) maybeAnswer + (expected, answerSteps, pref) = head answers + (loc, arguments) = fromMaybe (topId, mempty) $ + firstMajorInSteps answerSteps where ex = exercise state - topId = getId (strategy ex) + strat = strategy ex + topId = getId strat sloc = fromMaybe topId msloc - answers = runPrefixLocation sloc (stateContext state) prefix - prefix = case statePrefixes state of - [] -> emptyPrefix (strategy ex) (stateContext state) - hd:_ -> hd + answers = runPrefixLocation sloc prefix + prefix + | withoutPrefix state = emptyPrefix strat (stateContext state) + | otherwise = statePrefix state --- | Continue with a prefix until a certain strategy location is reached. At least one --- major rule should have been executed -runPrefixLocation :: Id -> a -> Prefix a -> [(a, Prefix a)] -runPrefixLocation loc a0 p0 = - concatMap (checkPair . f) $ derivations $ - cutOnStep (stop . lastStepInPrefix) $ prefixTree a0 p0 +-- | Continue with a prefix until a certain strategy location is reached. +runPrefixLocation :: Id -> Prefix a -> [(a, [Step a], Prefix a)] +runPrefixLocation loc = rec [] where - f d = (lastTerm d, fromMaybe p0 (lastStep d)) - stop (Just (Exit info)) = getId info == loc - stop _ = False - - checkPair result@(a, p) - | null rules = [result] - | all isMinor rules = runPrefixLocation loc a p - | otherwise = [result] - where - rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p + rec acc p = do + ((st, a), q) <- firsts p + if isLoc st then return (a, reverse (st:acc), q) + else rec (st:acc) q -firstMajorInPrefix :: Prefix a -> Prefix a -> Maybe (Id, Environment) -firstMajorInPrefix p0 = rec . drop len . prefixToSteps - where - len = length (prefixToSteps p0) - rec xs = - case xs of - Enter info:RuleStep env r:_ | isMajor r -> - Just (getId info, env) - _:rest -> rec rest - [] -> Nothing + isLoc (Exit l) = l == loc + isLoc (RuleStep _ r) = getId r == loc + isLoc _ = False -nextMajorForPrefix :: a -> Prefix a -> Maybe Id -nextMajorForPrefix a p0 = do - (_, p1) <- listToMaybe $ runPrefixMajor a p0 - rec (reverse (prefixToSteps p1)) - where - rec [] = Nothing - rec (Enter info:_) = Just (getId info) - rec (Exit info:_) = Just (getId info) - rec (_:rest) = rec rest +firstMajorInSteps :: [Step a] -> Maybe (Id, Environment) +firstMajorInSteps (RuleStep env r:_) | isMajor r = Just (getId r, env) +firstMajorInSteps (_:xs) = firstMajorInSteps xs +firstMajorInSteps [] = Nothing --- Copied from TypedAbstractService: clean me up -runPrefixMajor :: a -> Prefix a -> [(a, Prefix a)] -runPrefixMajor a p0 = - map f $ derivations $ cutOnStep (stop . lastStepInPrefix) $ prefixTree a p0 +nextMajorForPrefix :: Prefix a -> Maybe Id +nextMajorForPrefix = listToMaybe . rec where - f d = (lastTerm d, fromMaybe p0 (lastStep d)) - stop = maybe False isMajor + rec prfx = do + ((st, _), p) <- firsts prfx + case st of + Enter l -> [l] + RuleStep _ r | isMajor r -> [getId r] + _ -> rec p ------------------------------------------------------------------------ -- Data types for replies @@ -113,12 +97,14 @@ ------------------------------------------------------------------------ -- Type definition -instance Typed a (Answer a) where - typed = Tag "answer" $ Iso (Answer <-> fromAnswer) (Const Context) +tAnswer :: Type a (Answer a) +tAnswer = Tag "answer" $ Iso (Answer <-> fromAnswer) (Const Context) -instance Typed a (Reply a) where - typed = Tag "DecompositionReply" (Iso (f <-> g) typed) +tReply :: Type a (Reply a) +tReply = Tag "DecompositionReply" (Iso (f <-> g) tp) where + tp = tPair tId tState :|: tTuple4 tBool tId tState tEnvironment + f (Left (a, b)) = Ok a b f (Right (a, b, c, d)) = Incorrect a b c d
src/Ideas/Service/Request.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,23 +9,30 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Request.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Request.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.Request where import Data.Char import Data.List +import Data.Maybe import Ideas.Common.Library hiding (exerciseId) import Ideas.Common.Utils data Request = Request - { service :: String - , exerciseId :: Maybe Id - , source :: Maybe String - , dataformat :: DataFormat - , encoding :: [Encoding] + { serviceId :: Maybe Id + , exerciseId :: Maybe Id + , user :: Maybe String + , source :: Maybe String + , feedbackScript :: Maybe String + , cgiBinary :: Maybe String + , dataformat :: DataFormat + , encoding :: [Encoding] } +emptyRequest :: Request +emptyRequest = Request Nothing Nothing Nothing Nothing Nothing Nothing XML [] + data DataFormat = XML | JSON deriving Show -- needed for LoggingDatabase @@ -48,18 +55,16 @@ htmlOutput = (EncHTML `elem`) . encoding compactOutput :: Request -> Bool -compactOutput = compactOutputDefault True - -compactOutputDefault :: Bool -> Request -> Bool -compactOutputDefault b req = - let xs = encoding req - in case (EncCompact `elem` xs, EncPretty `elem` xs) of - (True, False) -> True - (False, True) -> False - _ -> b +compactOutput req = + case (EncCompact `elem` xs, EncPretty `elem` xs) of + (True, False) -> True + (False, True) -> False + _ -> isJust (cgiBinary req) + where + xs = encoding req useOpenMath :: Request -> Bool -useOpenMath = (EncString `notElem`) . encoding +useOpenMath r = all (`notElem` encoding r) [EncString, EncHTML] useLogging :: Request -> Bool useLogging = (EncHTML `notElem`) . encoding
src/Ideas/Service/ServiceList.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,13 +9,13 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: ServiceList.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: ServiceList.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.ServiceList (serviceList, metaServiceList) where import Ideas.Common.ExerciseTests -import Ideas.Common.Library hiding (apply, applicable, derivation, ready) -import Ideas.Common.Utils.TestSuite +import Ideas.Common.Library hiding (apply, applicable, suitable, ready) +import Ideas.Common.Utils.TestSuite hiding (Message) import Ideas.Service.BasicServices import Ideas.Service.DomainReasoner import Ideas.Service.FeedbackText @@ -23,6 +23,7 @@ import Ideas.Service.State import Ideas.Service.Types import qualified Ideas.Service.Diagnose as Diagnose +import qualified Ideas.Service.ProblemDecomposition as ProblemDecomposition import qualified Ideas.Service.Submit as Submit ------------------------------------------------------ @@ -31,14 +32,15 @@ serviceList :: [Service] serviceList = -- basic services - [ derivationS, allfirstsS, onefirstS, readyS + [ solutionS, derivationS, allfirstsS, onefirstS + , equivalenceS, similarityS, suitableS, finishedS, readyS , stepsremainingS, allapplicationsS , applyS, generateS, createS, applicableS - , examplesS, submitS, diagnoseS + , examplesS, exampleS, submitS, diagnoseS , findbuggyrulesS, problemdecompositionS -- textual services , onefirsttextS, submittextS - , derivationtextS, feedbacktextS + , derivationtextS, feedbacktextS, microstepsS ] metaServiceList :: DomainReasoner -> [Service] @@ -51,21 +53,26 @@ ------------------------------------------------------ -- Basic services -derivationS :: Service -derivationS = makeService "basic.derivation" - "Returns one possible derivation (or: worked-out example) starting with the \ +solutionS :: Service +solutionS = makeService "basic.solution" + "Returns one possible worked-out solution starting with the \ \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." $ - derivation ::: typed + solution ::: tMaybe tStrategyCfg .-> tState .-> tError (tDerivation (tPair tRule tEnvironment) tContext) +derivationS :: Service +derivationS = deprecate $ makeService "basic.derivation" + "See 'solution' service." $ + serviceFunction solutionS + allfirstsS :: Service allfirstsS = makeService "basic.allfirsts" "Returns all next steps that are suggested by the strategy. See the \ \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 ::: typed + allfirsts ::: tState .-> tError (tList (tPair tStepInfo tState)) onefirstS :: Service onefirstS = makeService "basic.onefirst" @@ -73,54 +80,73 @@ \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 ::: typed :-> Const String :|: Tag "elem" typed + onefirst ::: tState .-> tString :|: Tag "elem" (tPair tStepInfo tState) -- special tag for (legacy) xml encoding +equivalenceS :: Service +equivalenceS = makeService "basic.equivalence" + "Tests whether two terms are semantically equivalent." $ + equivalence ::: tExercise .-> tContext .-> tContext .-> tBool + +similarityS :: Service +similarityS = makeService "basic.similarity" + "Tests whether two terms are (nearly) the same." $ + similarity ::: tExercise .-> tContext .-> tContext .-> tBool + +suitableS :: Service +suitableS = makeService "basic.suitable" + "Identifies which terms can be solved by the strategy." $ + suitable ::: tState .-> tBool + +finishedS :: Service +finishedS = makeService "basic.finished" + "Checks whether a term is in solved form." $ + finished ::: tState .-> tBool + readyS :: Service -readyS = makeService "basic.ready" - "Test if the current expression is in a form accepted as a final answer. \ - \For this, the strategy is not used." $ - ready ::: typed +readyS = deprecate $ makeService "basic.ready" + "See 'finished' service." $ + serviceFunction finishedS stepsremainingS :: Service stepsremainingS = makeService "basic.stepsremaining" "Computes how many steps are remaining to be done, according to the \ \strategy. For this, only the first derivation is considered, which \ - \corresponds to the one returned by the derivation Ideas.Service." $ - stepsremaining ::: typed + \corresponds to the one returned by the derivation service." $ + stepsremaining ::: tState .-> tError tInt applicableS :: Service applicableS = deprecate $ makeService "basic.applicable" "Given a current expression and a location in this expression, this service \ \yields all rules that can be applied at this location, regardless of the \ \strategy." $ - applicable ::: typed + applicable ::: tLocation .-> tState .-> tList tRule allapplicationsS :: Service allapplicationsS = makeService "basic.allapplications" "Given a current expression, this service yields all rules that can be \ \applied at a certain location, regardless wether the rule used is buggy \ \or not. Some results are within the strategy, others are not." $ - allapplications ::: typed + allapplications ::: tState .-> tList (tTuple3 tRule tLocation tState) applyS :: Service applyS = makeService "basic.apply" "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 ::: typed + apply ::: tRule .-> tLocation .-> tEnvironment .-> tState .-> tError tState generateS :: Service generateS = makeService "basic.generate" "Given an exercise code and a difficulty level (optional), this service \ \returns an initial state with a freshly generated expression." $ - generate ::: typed + generate ::: tStdGen .-> tExercise .-> tMaybe tDifficulty .-> tError tState createS :: Service createS = makeService "basic.create" "Given an expression, this service \ \returns an initial state with the original given expression." $ - create ::: typed + create ::: tExercise .-> tString .-> tError tState examplesS :: Service examplesS = makeService "basic.examples" @@ -128,21 +154,34 @@ \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." $ - examplesContext ::: typed + examplesContext ::: tExercise .-> tExamples +exampleS :: Service +exampleS = makeService "basic.example" + "This services returns a specific (numbered) example expresssion that can be solved \ + \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 ::: tExercise .-> tInt .-> tError tState + where + f ex nr = + case drop nr (examplesContext ex) of + [] -> Left "No such example" + (_,c ):_ -> Right (emptyStateContext ex c) + findbuggyrulesS :: Service findbuggyrulesS = makeService "basic.findbuggyrules" "Search for common misconceptions (buggy rules) in an expression (compared \ \to the current state). It is assumed that the expression is indeed not \ \correct. This service has been superseded by the diagnose service." $ - findbuggyrules ::: typed + findbuggyrules ::: tState .-> tContext .-> tList (tTuple3 tRule tLocation tEnvironment) submitS :: Service submitS = deprecate $ makeService "basic.submit" "Analyze an expression submitted by a student. Possible answers are Buggy, \ \NotEquivalent, Ok, Detour, and Unknown. This service has been superseded \ - \by the diagnose Ideas.Service." $ - Submit.submit ::: typed + \by the diagnose service." $ + Submit.submit ::: tState .-> tContext .-> Submit.tResult diagnoseS :: Service diagnoseS = makeService "basic.diagnose" @@ -154,7 +193,7 @@ \expression was not expected by the strategy, but the applied rule was \ \detected), and Correct (it is correct, but we don't know which rule was \ \applied)." $ - Diagnose.diagnose ::: typed + Diagnose.diagnose ::: tState .-> tContext .-> tMaybe tId .-> Diagnose.tDiagnosis ------------------------------------------------------ -- Problem decomposition service @@ -164,7 +203,7 @@ "Strategy service developed for the SURF project Intelligent Feedback for a \ \binding with the MathDox system on linear algebra exercises. This is a \ \composite service, and available for backwards compatibility." $ - problemDecomposition ::: typed + problemDecomposition ::: tMaybe tId .-> tState .-> tMaybe ProblemDecomposition.tAnswer .-> tError ProblemDecomposition.tReply ------------------------------------------------------ -- Services with a feedback component @@ -174,13 +213,13 @@ "Similar to the onefirst service, except that the result is now returned as \ \a formatted text message. The optional string is for announcing the event \ \leading to this service call (which can influence the returned result)." $ - onefirsttext ::: typed + onefirsttext ::: tScript .-> tState .-> tMaybe tString .-> tPair tMessage (tMaybe tState) derivationtextS :: Service derivationtextS = makeService "textual.derivationtext" "Similar to the derivation service, but the rules appearing in the derivation \ \have been replaced by a short description of the rule." $ - derivationtext ::: typed + derivationtext ::: tScript .-> tState .-> tError (tDerivation tString tContext) submittextS :: Service submittextS = deprecate $ makeService "textual.submittext" @@ -190,12 +229,12 @@ \The boolean in the \ \result specifies whether the submitted term is accepted and incorporated \ \in the new state." $ - submittext ::: typed + submittext ::: tScript .-> tState .-> tString .-> tPair tMessage tState feedbacktextS :: Service feedbacktextS = makeService "textual.feedbacktext" - "Textual feedback for diagnose Ideas.Service. Experimental." $ - feedbacktext ::: typed + "Textual feedback for diagnose service. Experimental." $ + feedbacktext ::: tScript .-> tState .-> tContext .-> tMaybe tId .-> tPair tMessage tState ------------------------------------------------------ -- Reflective services @@ -203,23 +242,23 @@ indexS :: DomainReasoner -> Service indexS dr = makeService "meta.index" "Index of the domain reasoner" $ - dr ::: typed + dr ::: tDomainReasoner exerciselistS :: DomainReasoner -> Service exerciselistS dr = makeService "meta.exerciselist" "Returns all exercises known to the system. For each exercise, its domain, \ \identifier, a short description, and its current status are returned." $ - exercisesSorted dr ::: typed + exercisesSorted dr ::: tList tSomeExercise servicelistS :: DomainReasoner -> Service servicelistS dr = makeService "meta.servicelist" "List of all supported feedback services" $ - servicesSorted dr ::: typed + servicesSorted dr ::: tList tService serviceinfoS :: DomainReasoner -> Service serviceinfoS dr = makeService "meta.serviceinfo" "Information about a feedback service" $ - (findService dr :: Id -> Either String Service) ::: typed + findService dr ::: tId .-> tError tService rulelistS :: Service rulelistS = makeService "meta.rulelist" @@ -227,12 +266,12 @@ \name (or identifier), whether the rule is buggy, and whether the rule was \ \expressed as an observable rewrite rule. See rulesinfo for more details \ \about the rules." $ - ruleset ::: typed + ruleset ::: tExercise .-> tList tRule ruleinfoS :: Service ruleinfoS = makeService "meta.ruleinfo" "Information about a rule" $ - (id :: Rule (Context a) -> Rule (Context a)) ::: typed + id ::: tRule .-> tRule rulesinfoS :: Service rulesinfoS = makeService "meta.rulesinfo" @@ -243,23 +282,30 @@ strategyinfoS :: Service strategyinfoS = makeService "meta.strategyinfo" "Returns the representation of the strategy of a particular exercise." $ - (toStrategy . strategy) ::: typed + (toStrategy . strategy) ::: tExercise .-> tStrategy exerciseinfoS :: Service exerciseinfoS = makeService "meta.exerciseinfo" "Exercise information" $ - (id :: Exercise a -> Exercise a) ::: typed + id ::: tExercise .-> tExercise stateinfoS :: Service stateinfoS = makeService "meta.stateinfo" "State information" $ - (id :: State a -> State a) ::: typed + id ::: tState .-> tState +microstepsS :: Service +microstepsS = makeService "meta.microsteps" "Next (minor) steps." $ + (map f . microsteps) ::: tState .-> tList (tPair (tTuple3 tRule tLocation tEnvironment) tState) + where + f ((s, ctx), st) = ((stepRule s, location ctx, stepEnvironment s), st) + examplederivationsS :: Service examplederivationsS = makeService "meta.examplederivations" - "Show example derivations" $ exampleDerivations ::: typed + "Show example derivations" $ + exampleDerivations ::: tExercise .-> tError (tList (tDerivation (tPair tRule tEnvironment) tContext)) testreportS :: Service testreportS = makeService "meta.testreport" "Show test report for an exercise." $ - (\stdgen -> runTestSuiteResult False . exerciseTestSuite stdgen) ::: typed+ (\stdgen -> runTestSuiteResult False . exerciseTestSuite stdgen) ::: tStdGen .-> tExercise .-> tIO tTestSuiteResult
src/Ideas/Service/State.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,31 +13,33 @@ -- derivation. -- ----------------------------------------------------------------------------- --- $Id: State.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: State.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.State ( -- * Exercise state State, makeState, makeNoState, emptyStateContext, emptyState - , exercise, statePrefixes, stateContext, stateTerm, stateLabels + , exercise, statePrefix, stateContext, stateTerm + , withoutPrefix, stateLabels, suitable, finished, firsts, microsteps ) where +import Data.Function import Data.List import Data.Maybe -import Ideas.Common.Library -import Ideas.Common.Strategy.Abstract (LabelInfo) +import Ideas.Common.Library hiding (suitable, ready, (:~>)) +import Ideas.Common.Strategy.Choice +import Ideas.Common.Strategy.Sequence data State a = State - { exercise :: Exercise a - , statePrefixes :: [Prefix (Context a)] - , stateContext :: Context a + { exercise :: Exercise a + , statePrefix :: Prefix (Context a) + , stateContext :: Context a } instance Show (State a) where show s = unlines $ "State {" : map (" "++) xs ++ ["}"] where xs = [ "exercise = " ++ showId s - , "prefix = " ++ intercalate ";" (map showPrefix (statePrefixes s)) - , "steps = " ++ intercalate ";" (map (show . prefixToSteps) (statePrefixes s)) + , "prefix = " ++ show (statePrefix s) , "term = " ++ prettyPrinterContext (exercise s) (stateContext s) ] @@ -49,30 +52,57 @@ setEnvironment env s = s { stateContext = setEnvironment env (stateContext s) } +instance Firsts (State a) where + type Elem (State a) = (Step (Context a), Context a) + + firsts st = firstsOrdered cmp st + where + cmp = ruleOrdering (exercise st) `on` (stepRule . fst) + + menu st = fmap f (menu (majorPrefix (statePrefix st))) + where + f Done = Done + f (info :~> p) = info :~> State (exercise st) p (snd info) + +microsteps :: State a -> [((Step (Context a), Context a), State a)] +microsteps st = concatMap f (bests (menu (statePrefix st))) + where + f Done = [] + f (info :~> p) = [(info, State (exercise st) p (snd info))] + stateTerm :: State a -> a stateTerm = fromMaybe (error "invalid term") . fromContext . stateContext -stateLabels :: State a -> [[LabelInfo]] -stateLabels state = - map (filterRules . activeLabels) $ statePrefixes state - where - rs = ruleset $ exercise state - isRule = flip elem (map getId rs) . getId - filterRules = filter (not . isRule) - ----------------------------------------------------------- -makeState :: Exercise a -> [Prefix (Context a)] -> Context a -> State a +makeState :: Exercise a -> Prefix (Context a) -> Context a -> State a makeState = State -- State without a prefix makeNoState :: Exercise a -> Context a -> State a -makeNoState = flip makeState [] +makeNoState = flip makeState noPrefix emptyStateContext :: Exercise a -> Context a -> State a emptyStateContext ex ca = let pr = emptyPrefix (strategy ex) ca - in makeState ex [pr] ca + in makeState ex pr ca emptyState :: Exercise a -> a -> State a -emptyState ex = emptyStateContext ex . inContext ex+emptyState ex = emptyStateContext ex . inContext ex + +withoutPrefix :: State a -> Bool +withoutPrefix = null . prefixPaths . statePrefix + +suitable :: State a -> Bool +suitable st = isSuitable (exercise st) (stateTerm st) + +finished :: State a -> Bool +finished st = isReady (exercise st) (stateTerm st) + +stateLabels :: State a -> [[Id]] +stateLabels st = map make (prefixPaths (statePrefix st)) + where + ex = exercise st + make path = + let (xs, _) = replayPath path (strategy ex) (stateContext st) + in nub [l | Enter l <- xs] \\ [l | Exit l <- xs]
src/Ideas/Service/Submit.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,10 +12,10 @@ -- Diagnose a term submitted by a student. Deprecated (see diagnose service). -- ----------------------------------------------------------------------------- --- $Id: Submit.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Submit.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.Submit - ( submit, Result(..) + ( submit, Result(..), tResult ) where import Data.Maybe @@ -49,9 +49,12 @@ submit :: State a -> Context a -> Result a submit state ctx = fromDiagnose (diagnose state ctx Nothing) -instance Typed a (Result a) where - typed = Tag "Result" (Iso (f <-> g) typed) +tResult :: Type a (Result a) +tResult = Tag "Result" (Iso (f <-> g) tp) where + tp = tList tRule :|: tString :|: tPair (tList tRule) tState + :|: tPair (tList tRule) tState :|: tState + f (Left rs) = Buggy rs f (Right (Left s)) = NotEquivalent s f (Right (Right (Left (rs, s)))) = Ok rs s
src/Ideas/Service/Types.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE GADTs, Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, FlexibleContexts #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,15 +10,21 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Types.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Types.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Service.Types ( -- * Services Service, makeService, deprecate , serviceDeprecated, serviceFunction -- * Types - , TypeRep(..), Const(..), Type, TypedValue(..), Typed(..) + , TypeRep(..), Const(..), Type, TypedValue(..) , Equal(..), ShowF(..), equalM + -- * Constructing types + , tEnvironment, tLocation, tRule, tTuple3, tTuple4, tTuple5, tPair + , tStrategy, tTree, tState, tBool, tMaybe, tString, tList + , tId, tService, tSomeExercise, tText, tDifficulty, tContext + , tDerivation, tError, (.->), tIO, tExercise, tTestSuiteResult, tStdGen + , tScript, tExamples, tStrategyCfg, tInt ) where import Control.Monad @@ -65,9 +71,9 @@ instance Equal f => Equal (TypeRep f) where equal (Iso p a) t2 = fmap (. to p) (equal a t2) equal t1 (Iso p b) = fmap (from p .) (equal t1 b) - equal (Pair a b) (Pair c d) = do f <- equal a c - g <- equal b d - return $ f *** g + equal (a :-> b) (c :-> d) = liftM2 (\f g h -> g . h . f) + (equal c a) (equal b d) + 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) equal (Tag s1 a) (Tag s2 b) | s1 == s2 = equal a b @@ -138,7 +144,7 @@ Id :: Const a Id Location :: Const a Location Script :: Const a Script - StratCfg :: Const a StrategyConfiguration + StratCfg :: Const a StrategyCfg Environment :: Const a Environment Text :: Const a Text StdGen :: Const a StdGen @@ -238,118 +244,118 @@ --------------------------------------------------------------- -class Typed a t | t -> a where - typeOf :: t -> Type a t - typed :: Type a t - typedList :: Type a [t] - -- default implementation - typeOf = const typed - typedList = List typed - -instance Typed a Int where - typed = Const Int - -instance Typed a Bool where - typed = Const Bool - -instance Typed a () where - typed = Unit +tError :: Type a t -> Type a (Either String t) +tError = (:|:) tString -instance Typed a Char where - typed = Iso (head <-> return) typed - typedList = Const String +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)) + f (a, xs) = foldl extend (emptyDerivation a) xs + g d = (firstTerm d, [ (s, a) | (_, s, a) <- triples d ]) -instance Typed a (Rule (Context a)) where - typed = Const Rule +tIO :: Type a t -> Type a (IO t) +tIO = IO -instance Typed a (Strategy (Context a)) where - typed = Const Strategy +tText :: Type a Text +tText = Const Text -instance Typed a Id where - typed = Const Id +infixr 5 .-> -instance Typed a Location where - typed = Const Location +(.->) :: Type a t1 -> Type a t2 -> Type a (t1 -> t2) +(.->) = (:->) -instance Typed a Environment where - typed = Const Environment +tState :: Type a (State a) +tState = Const State -instance Typed a StdGen where - typed = Const StdGen +tMaybe :: Type a t -> Type a (Maybe t) +tMaybe t = Iso (f <-> g) (t :|: Unit) + where + f = either Just (const Nothing) + g = maybe (Right ()) Left -instance Typed a TestSuite.Result where - typed = Const Result +tStrategyCfg :: Type a StrategyCfg +tStrategyCfg = Const StratCfg -instance Typed a Difficulty where - typed = Tag "Difficulty" (Iso (f <-> show) typed) - where - f = fromMaybe Medium . readDifficulty +tList :: Type a t -> Type a [t] +tList = List -instance Typed a Service where - typed = Const Service +tPair :: Type a t1 -> Type a t2 -> Type a (t1, t2) +tPair = Pair -instance Typed a (State a) where - typed = Const State +tString :: Type a String +tString = Const String -instance Typed a (Exercise a) where - typed = Const Exercise +tExercise :: Type a (Exercise a) +tExercise = Const Exercise -instance Typed a (Context a) where - typed = Const Context +tContext :: Type a (Context a) +tContext = Const Context -instance Typed a StrategyConfiguration where - typed = Const StratCfg +tBool :: Type a Bool +tBool = Const Bool -instance Typed a Script where - typed = Const Script +tInt :: Type a Int +tInt = Const Int -instance Typed a Text where - typed = Const Text +tRule :: Type a (Rule (Context a)) +tRule = Const Rule -instance (Typed a t1, Typed a t2) => Typed a (t1, t2) where - typed = Pair typed typed +tLocation :: Type a Location +tLocation = Const Location -instance (Typed a t1, Typed a t2, Typed a t3) => Typed a (t1, t2, t3) where - typed = Iso (f <-> g) (Pair typed (Pair typed typed)) +tTuple3 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a (t1, t2, t3) +tTuple3 t1 t2 t3 = Iso (f <-> g) (Pair t1 (Pair t2 t3)) where f (a, (b, c)) = (a, b, c) g (a, b, c) = (a, (b, c)) -instance (Typed a t1, Typed a t2, Typed a t3, Typed a t4) => Typed a (t1, t2, t3, t4) where - typed = Iso (f <-> g) (Pair typed (Pair typed (Pair typed typed))) +tTuple4 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a t4 -> Type a (t1, t2, t3, t4) +tTuple4 t1 t2 t3 t4 = Iso (f <-> g) (Pair t1 (Pair t2 (Pair t3 t4))) where f (a, (b, (c, d))) = (a, b, c, d) g (a, b, c, d) = (a, (b, (c, d))) -instance (Typed a t1, Typed a t2) => Typed a (t1 -> t2) where - typed = typed :-> typed +tTuple5 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a t4 -> Type a t5 -> Type a (t1, t2, t3, t4, t5) +tTuple5 t1 t2 t3 t4 t5 = Iso (f <-> g) (Pair t1 (Pair t2 (Pair t3 (Pair t4 t5)))) + where + f (a, (b, (c, (d, e)))) = (a, b, c, d, e) + g (a, b, c, d, e) = (a, (b, (c, (d, e)))) -instance Typed a t => Typed a (IO t) where - typed = IO typed +tEnvironment :: Type a Environment +tEnvironment = Const Environment -instance Typed a t => Typed a (Maybe t) where - typed = Iso (f <-> g) (typed :|: Unit) +tDifficulty :: Type a Difficulty +tDifficulty = Tag "Difficulty" (Iso (f <-> show) tString) where - f = either Just (const Nothing) - g = maybe (Right ()) Left + f = fromMaybe Medium . readDifficulty -instance (Typed a t1, Typed a t2) => Typed a (Either t1 t2) where - typed = typed :|: typed +tStdGen :: Type a StdGen +tStdGen = Const StdGen -instance (Typed a t1, Typed a t2) => Typed a (Derivation t1 t2) where - typed = Tag "Derivation" $ Iso (f <-> g) typed - where - f (a, xs) = foldl extend (emptyDerivation a) xs - g d = (firstTerm d, [ (s, a) | (_, s, a) <- triples d ]) +tExamples :: Type a (Examples (Context a)) +tExamples = tList (tPair tDifficulty tContext) -instance Typed a t => Typed a [t] where - typed = typedList +tId :: Type a Id +tId = Const Id -instance Typed a t => Typed a (Tree t) where - typed = Tag "Tree" $ Iso (f <-> g) typed +tScript :: Type a Script +tScript = Const Script + +tSomeExercise :: Type a (Some Exercise) +tSomeExercise = Const SomeExercise + +tService :: Type a Service +tService = Const Service + +tStrategy :: Type a (Strategy (Context a)) +tStrategy = Const Strategy + +tTree :: Type a t -> Type a (Tree t) +tTree t = Tag "Tree" $ Iso (f <-> g) (tPair t (tList (tTree t))) where f = uncurry Node g (Node a xs) = (a, xs) -instance Typed a (Some Exercise) where - typed = Const SomeExercise+tTestSuiteResult :: Type a TestSuite.Result +tTestSuiteResult = Const Result
src/Ideas/Text/HTML.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- See http://www.w3.org/TR/html4/ -- ----------------------------------------------------------------------------- --- $Id: HTML.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: HTML.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.HTML ( HTMLPage, HTMLBuilder
src/Ideas/Text/JSON.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- JSON. JSON is a lightweight alternative for XML. -- ----------------------------------------------------------------------------- --- $Id: JSON.hs 6541 2014-05-14 18:44:36Z bastiaan $ +-- $Id: JSON.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.JSON ( JSON(..), Key, Number(..) -- types @@ -90,6 +90,8 @@ 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] @@ -206,13 +208,14 @@ , ("params", requestParams req) , ("id" , requestId req) ] - fromJSON obj = do - mj <- lookupM "method" obj - pj <- lookupM "params" obj - ij <- lookupM "id" obj - case mj of - String s -> return (Request s pj ij) - _ -> fail "expecting a string" + 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
src/Ideas/Text/OpenMath/FMP.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Formal mathematical properties (FMP) -- ----------------------------------------------------------------------------- --- $Id: FMP.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: FMP.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.OpenMath.FMP where
src/Ideas/Text/OpenMath/Object.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Object.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Object.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.OpenMath.Object ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml
src/Ideas/Text/OpenMath/Symbol.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Symbol.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Symbol.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.OpenMath.Symbol where
src/Ideas/Text/OpenMath/Tests.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Tests.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Tests.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.OpenMath.Tests (propEncoding) where
src/Ideas/Text/Parsing.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Utility functions for parsing with Parsec library -- ----------------------------------------------------------------------------- --- $Id: Parsing.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Parsing.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.Parsing ( module Export
src/Ideas/Text/UTF8.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Support for the UTF8 encoding -- ----------------------------------------------------------------------------- --- $Id: UTF8.hs 6541 2014-05-14 18:44:36Z bastiaan $ +-- $Id: UTF8.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.UTF8 ( encode, encodeM, decode, decodeM
src/Ideas/Text/XML.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,13 +12,13 @@ -- functions defined elsewhere. -- ----------------------------------------------------------------------------- --- $Id: XML.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: XML.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.XML ( XML, Attr, AttrList, Element(..), InXML(..) , XMLBuilder, makeXML , parseXML, parseXMLFile, compactXML, findAttribute - , children, Attribute(..), fromBuilder, findChild, getData + , children, Attribute(..), fromBuilder, findChild, findChildren, getData , BuildXML(..) , module Data.Monoid, munless, mwhen ) where
src/Ideas/Text/XML/Document.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Datatype for representing XML documents -- ----------------------------------------------------------------------------- --- $Id: Document.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Document.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.XML.Document ( Name, Attributes, Attribute(..), Reference(..), Parameter(..)
src/Ideas/Text/XML/Interface.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,12 +11,12 @@ -- Collection of common operation on XML documents -- ----------------------------------------------------------------------------- --- $Id: Interface.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Interface.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.XML.Interface ( Element(..), Content, Attribute(..), Attributes , normalize, parseXML, compactXML - , children, findAttribute, findChild, getData + , children, findAttribute, findChildren, findChild, getData ) where import Control.Arrow @@ -121,11 +121,15 @@ [hd] -> return hd _ -> fail $ "Invalid attribute: " ++ show s +findChildren :: String -> Element -> [Element] +findChildren s = filter ((==s) . name) . children + findChild :: Monad m => String -> Element -> m Element findChild s e = - case filter ((==s) . name) (children e) of + case findChildren s e of + [] -> fail $ "Child not found: " ++ show s [a] -> return a - _ -> fail $ "Child not found: " ++ show s + _ -> fail $ "Multiple children found: " ++ show s children :: Element -> [Element] children e = [ c | Right c <- content e ]
src/Ideas/Text/XML/Parser.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,7 @@ -- http://www.w3.org/TR/2006/REC-xml-20060816 -- ----------------------------------------------------------------------------- --- $Id: Parser.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Parser.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.XML.Parser (document, extParsedEnt, extSubset) where
src/Ideas/Text/XML/Unicode.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- Copyright 2015, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Support for Unicode -- ----------------------------------------------------------------------------- --- $Id: Unicode.hs 6535 2014-05-14 11:05:06Z bastiaan $ +-- $Id: Unicode.hs 7524 2015-04-08 07:31:15Z bastiaan $ module Ideas.Text.XML.Unicode ( isExtender, isLetter, isDigit, isCombiningChar
+ src/Network/CGI.hs view
@@ -0,0 +1,634 @@+{-# LANGUAGE OverlappingInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI +-- Copyright : (c) The University of Glasgow 2001 +-- (c) Bjorn Bringert 2004-2006 +-- (c) Ian Lynagh 2005 +-- (c) Jeremy Shaw 2005 +-- License : BSD-style +-- +-- Maintainer : John Chee <cheecheeo@gmail.com> +-- Stability : experimental +-- Portability : non-portable (uses Control.Monad.State) +-- +-- Simple Library for writing CGI programs. +-- See <http://hoohoo.ncsa.uiuc.edu/cgi/interface.html> for the +-- CGI specification. +-- +-- This version of the library is for systems with version 2.0 or greater +-- of the network package. This includes GHC 6.6 and later. For older +-- systems, see <http://www.cs.chalmers.se/~bringert/darcs/cgi-compat/doc/> +-- +-- Based on the original Haskell binding for CGI: +-- +-- Original Version by Erik Meijer <mailto:erik@cs.ruu.nl>. +-- Further hacked on by Sven Panne <mailto:sven.panne@aedion.de>. +-- Further hacking by Andy Gill <mailto:andy@galconn.com>. +-- A new, hopefully more flexible, interface +-- and support for file uploads by Bjorn Bringert <mailto:bjorn@bringert.net>. +-- +-- Here is a simple example, including error handling (not that there is +-- much that can go wrong with Hello World): +-- +-- > import Network.CGI +-- > +-- > cgiMain :: CGI CGIResult +-- > cgiMain = output "Hello World!" +-- > +-- > main :: IO () +-- > main = runCGI (handleErrors cgiMain) +-- +-- +----------------------------------------------------------------------------- + +module Network.CGI ( + -- * CGI monad + MonadCGI, CGIT, CGIResult, CGI + , MonadIO, liftIO + , runCGI + -- * Error handling + , throwCGI, catchCGI, tryCGI, handleExceptionCGI + , handleErrors + -- * Logging + , logCGI + -- * Output + , output, outputFPS, outputNothing, redirect + , setHeader, setStatus + -- * Error pages + , outputError, outputException + , outputNotFound, outputMethodNotAllowed, outputInternalServerError + -- * Input + , getInput, getInputFPS, readInput + , getBody, getBodyFPS + , getInputs, getInputsFPS, getInputNames + , getMultiInput, getMultiInputFPS + , getInputFilename, getInputContentType + -- * Environment + , getVar, getVarWithDefault, getVars + -- * Request information + , serverName, serverPort + , requestMethod, pathInfo + , pathTranslated, scriptName + , queryString + , remoteHost, remoteAddr + , authType, remoteUser + , requestContentType, requestContentLength + , requestHeader + -- * Program and request URI + , progURI, queryURI, requestURI + -- * Content negotiation + , Acceptable, Accept + , Charset(..), ContentEncoding(..), Language(..) + , requestAccept, requestAcceptCharset, requestAcceptEncoding, requestAcceptLanguage + , negotiate + -- * Content type + , ContentType(..), showContentType, parseContentType + -- * Cookies + , Cookie(..), newCookie + , getCookie, readCookie + , setCookie, deleteCookie + -- * URL encoding + , formEncode, urlEncode, formDecode, urlDecode + -- * Compatibility with the old API + , module Network.CGI.Compat + ) where + +import Control.Exception (Exception(..), SomeException, ErrorCall(..)) +import Control.Monad (liftM) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Char (toUpper) +import Data.List (intersperse, sort, group) +import Data.Maybe (fromMaybe) +import Network.Multipart +import Network.Multipart.Header +import Network.URI (URI(..), URIAuth(..), nullURI, parseRelativeReference, escapeURIString, isUnescapedInURI) +import qualified Data.Map as Map +import System.IO (stdin, stdout) + +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BS + +import Network.CGI.Accept +import Network.CGI.Compat +import Network.CGI.Cookie (Cookie(..), showCookie, newCookie, findCookie) +import Network.CGI.Monad +import Network.CGI.Protocol +import qualified Network.CGI.Cookie as Cookie (deleteCookie) + +import Text.XHtml (renderHtml, header, (<<), thetitle, (+++), + body, h1, paragraph, hr, address) + +-- | Run a CGI action. Typically called by the main function. +-- Reads input from stdin and writes to stdout. Gets +-- CGI environment variables from the program environment. +runCGI :: MonadIO m => CGIT m CGIResult -> m () +runCGI f = do env <- getCGIVars + hRunCGI env stdin stdout (runCGIT f) + +-- +-- * Output \/ redirect +-- + +-- | Output a 'String'. The output is assumed to be text\/html, encoded using +-- ISO-8859-1. To change this, set the Content-type header using +-- 'setHeader'. +output :: MonadCGI m => + String -- ^ The string to output. + -> m CGIResult +output = return . CGIOutput . BS.pack + +-- | Output a 'ByteString'. The output is assumed to be text\/html, +-- encoded using ISO-8859-1. To change this, set the +-- Content-type header using 'setHeader'. +outputFPS :: MonadCGI m => + ByteString -- ^ The string to output. + -> m CGIResult +outputFPS = return . CGIOutput + +-- | Do not output anything (except headers). +outputNothing :: MonadCGI m => m CGIResult +outputNothing = return CGINothing + +-- | Redirect to some location. +redirect :: MonadCGI m => + String -- ^ A URL to redirect to. + -> m CGIResult +redirect url = do setHeader "Location" url + outputNothing + +-- +-- * Error handling +-- + +-- | Catches any exception thrown by the given CGI action, +-- returns an error page with a 500 Internal Server Error, +-- showing the exception information, and logs the error. +-- +-- Typical usage: +-- +-- > cgiMain :: CGI CGIResult +-- > cgiMain = ... +-- > +-- > main :: IO () +-- > main = runCGI (handleErrors cgiMain) +handleErrors :: (MonadCGI m, MonadCatch m, MonadIO m) => m CGIResult -> m CGIResult +handleErrors = flip catchCGI outputException + +-- +-- * Error output +-- + +-- | Output a 500 Internal Server Error with information from +-- an 'Exception'. +outputException :: (MonadCGI m,MonadIO m) => SomeException -> m CGIResult +outputException e = outputInternalServerError es + where es = case fromException e of + Just (ErrorCall msg) -> [msg] + _ -> [show e] + +-- | Output an error page to the user, with the given +-- HTTP status code in the response. Also logs the error information +-- using 'logCGI'. +outputError :: (MonadCGI m, MonadIO m) => + Int -- ^ HTTP Status code + -> String -- ^ Status message + -> [String] -- ^ Error information + -> m CGIResult +outputError c m es = + do logCGI $ show (c,m,es) + setStatus c m + let textType = ContentType "text" "plain" [("charset","ISO-8859-1")] + htmlType = ContentType "text" "html" [("charset","ISO-8859-1")] + cts <- liftM (negotiate [htmlType,textType]) requestAccept + case cts of + ct:_ | ct == textType -> + do setHeader "Content-type" (showContentType textType) + text <- errorText c m es + output text + _ -> do setHeader "Content-type" (showContentType htmlType) + page <- errorPage c m es + output $ renderHtml page + +-- | Create an HTML error page. +errorPage :: MonadCGI m => + Int -- ^ Status code + -> String -- ^ Status message + -> [String] -- ^ Error information + -> m Html +errorPage c m es = + do server <- getVar "SERVER_SOFTWARE" + host <- getVar "SERVER_NAME" + port <- getVar "SERVER_PORT" + let tit = show c ++ " " ++ m + sig = "Haskell CGI" + ++ " on " ++ fromMaybe "" server + ++ " at " ++ fromMaybe "" host ++ maybe "" (", port "++) port + return $ header << thetitle << tit + +++ body << (h1 << tit +++ map (paragraph <<) es + +++ hr +++ address << sig) + +errorText :: MonadCGI m => + Int -- ^ Status code + -> String -- ^ Status message + -> [String] -- ^ Error information + -> m String +errorText c m es = return $ unlines $ (show c ++ " " ++ m) : es + +-- +-- * Specific HTTP errors +-- + +-- | Use 'outputError' to output and log a 404 Not Found error. +outputNotFound :: (MonadIO m, MonadCGI m) => + String -- ^ The name of the requested resource. + -> m CGIResult +outputNotFound r = + outputError 404 "Not Found" ["The requested resource was not found: " ++ r] + +-- | Use 'outputError' to output and log a 405 Method Not Allowed error. +outputMethodNotAllowed :: (MonadIO m, MonadCGI m) => + [String] -- ^ The allowed methods. + -> m CGIResult +outputMethodNotAllowed ms = + do let allow = concat $ intersperse ", " ms + setHeader "Allow" allow + outputError 405 "Method Not Allowed" ["Allowed methods : " ++ allow] + +-- | Use 'outputError' to output and log a 500 Internal Server Error. +outputInternalServerError :: (MonadIO m, MonadCGI m) => + [String] -- ^ Error information. + -> m CGIResult +outputInternalServerError es = outputError 500 "Internal Server Error" es + +-- +-- * Environment variables +-- + +-- | Get the value of a CGI environment variable. Example: +-- +-- > remoteAddr <- getVar "REMOTE_ADDR" +getVar :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe String) +getVar name = liftM (Map.lookup name) $ cgiGet cgiVars + +getVarWithDefault :: MonadCGI m => + String -- ^ The name of the variable. + -> String -- ^ Default value + -> m String +getVarWithDefault name def = liftM (fromMaybe def) $ getVar name + +-- | Get all CGI environment variables and their values. +getVars :: MonadCGI m => + m [(String,String)] +getVars = liftM Map.toList $ cgiGet cgiVars + +-- +-- * Request information +-- + +-- | The server\'s hostname, DNS alias, or IP address as it would +-- appear in self-referencing URLs. +serverName :: MonadCGI m => m String +serverName = getVarWithDefault "SERVER_NAME" "" + +-- | The port number to which the request was sent. +serverPort :: MonadCGI m => m Int +serverPort = liftM (fromMaybe 80 . (>>= maybeRead)) (getVar "SERVER_PORT") + +-- | The method with which the request was made. +-- For HTTP, this is \"GET\", \"HEAD\", \"POST\", etc. +requestMethod :: MonadCGI m => m String +requestMethod = getVarWithDefault "REQUEST_METHOD" "GET" + +-- | The extra path information, as given by the client. +-- This is any part of the request path that follows the +-- CGI program path. +-- If the string returned by this function is not empty, +-- it is guaranteed to start with a @\'\/\'@. +-- +-- Note that this function returns an unencoded string. +-- Make sure to percent-encode any characters +-- that are not allowed in URI paths before using the result of +-- this function to construct a URI. +-- See 'progURI', 'queryURI' and 'requestURI' for a higher-level +-- interface. +pathInfo :: MonadCGI m => m String +pathInfo = liftM slash $ getVarWithDefault "PATH_INFO" "" + where slash s = if not (null s) && head s /= '/' then '/':s else s + +-- | The path returned by 'pathInfo', but with virtual-to-physical +-- mapping applied to it. +pathTranslated :: MonadCGI m => m String +pathTranslated = getVarWithDefault "PATH_TRANSLATED" "" + +-- | A virtual path to the script being executed, +-- used for self-referencing URIs. +-- +-- Note that this function returns an unencoded string. +-- Make sure to percent-encode any characters +-- that are not allowed in URI paths before using the result of +-- this function to construct a URI. +-- See 'progURI', 'queryURI' and 'requestURI' for a higher-level +-- interface. +scriptName :: MonadCGI m => m String +scriptName = getVarWithDefault "SCRIPT_NAME" "" + +-- | The information which follows the ? in the URL which referenced +-- this program. This is the percent-encoded query information. +-- For most normal uses, 'getInput' and friends are probably +-- more convenient. +queryString :: MonadCGI m => m String +queryString = getVarWithDefault "QUERY_STRING" "" + +-- | The hostname making the request. If the server does not have +-- this information, Nothing is returned. See also 'remoteAddr'. +remoteHost :: MonadCGI m => m (Maybe String) +remoteHost = getVar "REMOTE_HOST" + +-- | The IP address of the remote host making the request. +remoteAddr :: MonadCGI m => m String +remoteAddr = getVarWithDefault "REMOTE_ADDR" "" + +-- | If the server supports user authentication, and the script is +-- protected, this is the protocol-specific authentication method +-- used to validate the user. +authType :: MonadCGI m => m (Maybe String) +authType = getVar "AUTH_TYPE" + +-- | If the server supports user authentication, and the script is +-- protected, this is the username they have authenticated as. +remoteUser :: MonadCGI m => m (Maybe String) +remoteUser = getVar "REMOTE_USER" + +-- | For queries which have attached information, such as +-- HTTP POST and PUT, this is the content type of the data. +-- You can use 'parseContentType' to get a structured +-- representation of the the content-type value. +requestContentType :: MonadCGI m => m (Maybe String) +requestContentType = getVar "CONTENT_TYPE" + +-- | For queries which have attached information, such as +-- HTTP POST and PUT, this is the length of the content +-- given by the client. +requestContentLength :: MonadCGI m => m (Maybe Int) +requestContentLength = liftM (>>= maybeRead) $ getVar "CONTENT_LENGTH" + +-- | Gets the value of the request header with the given name. +-- The header name is case-insensitive. +-- Example: +-- +-- > requestHeader "User-Agent" +requestHeader :: MonadCGI m => String -> m (Maybe String) +requestHeader name = getVar var + where var = "HTTP_" ++ map toUpper (replace '-' '_' name) + +-- +-- * Content negotiation +-- + +requestHeaderValue :: (MonadCGI m, HeaderValue a) => String -> m (Maybe a) +requestHeaderValue h = liftM (>>= parseM parseHeaderValue h) $ requestHeader h + +requestAccept :: MonadCGI m => m (Maybe (Accept ContentType)) +requestAccept = requestHeaderValue "Accept" + +requestAcceptCharset :: MonadCGI m => m (Maybe (Accept Charset)) +requestAcceptCharset = requestHeaderValue "Accept-Charset" + +requestAcceptEncoding :: MonadCGI m => m (Maybe (Accept ContentEncoding)) +requestAcceptEncoding = requestHeaderValue "Accept-Encoding" + +requestAcceptLanguage :: MonadCGI m => m (Maybe (Accept Language)) +requestAcceptLanguage = requestHeaderValue "Accept-Language" + +-- +-- * Program and request URI +-- + +-- | Attempts to reconstruct the absolute URI of this program. +-- This does not include +-- any extra path information or query parameters. See +-- 'queryURI' for that. +-- If the server is rewriting request URIs, this URI can +-- be different from the one requested by the client. +-- See also 'requestURI'. +-- +-- Characters in the components of the returned URI are escaped +-- when needed, as required by "Network.URI". +progURI :: MonadCGI m => m URI +progURI = + do -- Use HTTP_HOST if available, otherwise SERVER_NAME + h <- requestHeader "Host" >>= maybe serverName return + p <- serverPort + name <- scriptName + https <- liftM (maybe False (const True)) (getVar "HTTPS") + -- SERVER_PORT might not be the port that the client used + -- if the server listens on multiple ports, so we give priority + -- to the port in HTTP_HOST. + -- HTTP_HOST should include the port according to RFC2616 sec 14.23 + -- Some servers (e.g. lighttpd) also seem to include the port in + -- SERVER_NAME. + -- We include the port if it is in HTTP_HOST or SERVER_NAME, or if + -- it is a non-standard port. + let (host,port) = case break (==':') h of + (_,"") -> (h, if (not https && p == 80) + || (https && p == 443) + then "" else ':':show p) + (h',p') -> (h',p') + let auth = URIAuth { uriUserInfo = "", + uriRegName = host, + uriPort = port } + return $ nullURI { uriScheme = if https then "https:" else "http:", + uriAuthority = Just auth, + uriPath = escapePath name } + +-- | Like 'progURI', but the returned 'URI' also includes +-- any extra path information, and any query parameters. +-- If the server is rewriting request URIs, this URI can +-- be different from the one requested by the client. +-- See also 'requestURI'. +-- +-- Characters in the components of the returned URI are escaped +-- when needed, as required by "Network.URI". +queryURI :: MonadCGI m => m URI +queryURI = + do uri <- progURI + path <- pathInfo + qs <- liftM (\q -> if null q then q else '?':q) $ queryString + return $ uri { uriPath = uriPath uri ++ escapePath path, + uriQuery = qs } + +-- | Does percent-encoding as needed for URI path components. +escapePath :: String -> String +escapePath = escapeURIString isUnescapedInURIPath + where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#" + +-- | Attempts to reconstruct the absolute URI requested by the client, +-- including extra path information and query parameters. +-- If no request URI rewriting is done, or if the web server does not +-- provide the information needed to reconstruct the request URI, +-- this function returns the same value as 'queryURI'. +-- +-- Characters in the components of the returned URI are escaped +-- when needed, as required by "Network.URI". +requestURI :: MonadCGI m => m URI +requestURI = + do uri <- queryURI + -- Apache sets REQUEST_URI to the original request URI, + -- with percent-encoding intact. + mreq <- liftM (>>= parseRelativeReference) $ getVar "REQUEST_URI" + return $ case mreq of + Nothing -> uri + Just req -> uri { + uriPath = uriPath req, + uriQuery = uriQuery req + } + +-- +-- * Inputs +-- + +-- | Get the value of an input variable, for example from a form. +-- If the variable has multiple values, the first one is returned. +-- Example: +-- +-- > query <- getInput "query" +getInput :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe String) -- ^ The value of the variable, + -- or Nothing, if it was not set. +getInput = liftM (fmap BS.unpack) . getInputFPS + +-- | Like 'getInput', but returns a 'ByteString'. +getInputFPS :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe ByteString) -- ^ The value of the variable, + -- or Nothing, if it was not set. +getInputFPS = liftM (fmap inputValue) . getInput_ + +-- | Get all the values of an input variable, for example from a form. +-- This can be used to get all the values from form controls +-- which allow multiple values to be selected. +-- Example: +-- +-- > vals <- getMultiInput "my_checkboxes" +getMultiInput :: MonadCGI m => + String -- ^ The name of the variable. + -> m [String] -- ^ The values of the variable, + -- or the empty list if the variable was not set. +getMultiInput = liftM (map BS.unpack) . getMultiInputFPS + +-- | Same as 'getMultiInput' but using 'ByteString's. +getMultiInputFPS :: MonadCGI m => + String -- ^ The name of the variable. + -> m [ByteString] -- ^ The values of the variable, + -- or the empty list if the variable was not set. +getMultiInputFPS n = do is <- cgiGet cgiInputs + return [inputValue v | (p,v) <- is, p == n] + +-- | Get the file name of an input. +getInputFilename :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe String) -- ^ The file name corresponding to the + -- input, if there is one. +getInputFilename = liftM (>>= inputFilename) . getInput_ + +-- | Get the content-type of an input, if the input exists, e.g. "image\/jpeg". +-- For non-file inputs, this function returns "text\/plain". +-- You can use 'parseContentType' to get a structured +-- representation of the the content-type value. +getInputContentType :: MonadCGI m => + String -- ^ The name of the variable. + -> m (Maybe String) -- ^ The content type, formatted as a string. +getInputContentType = + liftM (fmap (showContentType . inputContentType)) . getInput_ + +-- | Same as 'getInput', but tries to read the value to the desired type. +readInput :: (Read a, MonadCGI m) => + String -- ^ The name of the variable. + -> m (Maybe a) -- ^ 'Nothing' if the variable does not exist + -- or if the value could not be interpreted + -- at the desired type. +readInput = liftM (>>= maybeRead) . getInput + +-- | Get the names and values of all inputs. +-- Note: the same name may occur more than once in the output, +-- if there are several values for the name. +getInputs :: MonadCGI m => m [(String,String)] +getInputs = do is <- cgiGet cgiInputs + return [ (n, BS.unpack (inputValue i)) | (n,i) <- is ] + +-- | Get the names and values of all inputs. +-- Note: the same name may occur more than once in the output, +-- if there are several values for the name. +getInputsFPS :: MonadCGI m => m [(String,ByteString)] +getInputsFPS = do is <- cgiGet cgiInputs + return [ (n, inputValue i) | (n,i) <- is ] + +-- | Get the names of all input variables. +getInputNames :: MonadCGI m => m [String] +getInputNames = (sortNub . map fst) `liftM` cgiGet cgiInputs + where sortNub = map head . group . sort + +-- Internal stuff + +getInput_ :: MonadCGI m => String -> m (Maybe Input) +getInput_ n = lookup n `liftM` cgiGet cgiInputs + +-- | Get the uninterpreted request body as a String +getBody :: MonadCGI m => m String +getBody = BS.unpack `liftM` cgiGet cgiRequestBody + +-- | Get the uninterpreted request body as lazy ByteString +getBodyFPS :: MonadCGI m => m ByteString +getBodyFPS = cgiGet cgiRequestBody + +-- +-- * Cookies +-- + +-- | Get the value of a cookie. +getCookie :: MonadCGI m => + String -- ^ The name of the cookie. + -> m (Maybe String) -- ^ 'Nothing' if the cookie does not exist. +getCookie name = liftM (>>= findCookie name) (getVar "HTTP_COOKIE") + +-- | Same as 'getCookie', but tries to read the value to the desired type. +readCookie :: (Read a, MonadCGI m) => + String -- ^ The name of the cookie. + -> m (Maybe a) -- ^ 'Nothing' if the cookie does not exist + -- or if the value could not be interpreted + -- at the desired type. +readCookie = liftM (>>= maybeRead) . getCookie + +-- | Set a cookie. +setCookie :: MonadCGI m => Cookie -> m () +setCookie = setHeader "Set-cookie" . showCookie + +-- | Delete a cookie from the client +deleteCookie :: MonadCGI m => Cookie -> m () +deleteCookie = setCookie . Cookie.deleteCookie + +-- +-- * Headers +-- + +-- | Add a response header. +-- Example: +-- +-- > setHeader "Content-type" "text/plain" +setHeader :: MonadCGI m => + String -- ^ Header name. + -> String -- ^ Header value. + -> m () +setHeader n v = cgiAddHeader (HeaderName n) v + +-- | Set the HTTP response status. +setStatus :: MonadCGI m => + Int -- ^ HTTP status code, e.g. @404@ + -> String -- ^ HTTP status message, e.g. @"Not Found"@ + -> m () +setStatus c m = setHeader "Status" (show c ++ " " ++ m)
+ src/Network/CGI/Accept.hs view
@@ -0,0 +1,173 @@+module Network.CGI.Accept ( + -- * Accept-X headers + Acceptable + , Accept + , Charset(..), ContentEncoding(..), Language(..) + -- * Content negotiation + , negotiate + ) where + +import Data.Function +import Data.List +import Data.Maybe +import Numeric + +import Text.ParserCombinators.Parsec + +import Network.Multipart +import Network.Multipart.Header + +-- +-- * Accept-X headers +-- + +newtype Accept a = Accept [(a, Quality)] + deriving (Show) + +type Quality = Double + +-- A bounded join-semilattice +class Eq a => Acceptable a where + includes :: a -> a -> Bool + top :: a + +instance HeaderValue a => HeaderValue (Accept a) where + parseHeaderValue = fmap Accept $ sepBy p (lexeme (char ',')) + where p = do a <- parseHeaderValue + q <- option 1 $ do _ <- lexeme $ char ';' + _ <- lexeme $ char 'q' + _ <- lexeme $ char '=' + lexeme pQuality + return (a,q) + pQuality = (char '0' >> option "0" (char '.' >> many digit) >>= \ds -> return (read ("0." ++ ds ++ "0"))) + <|> (char '1' >> optional (char '.' >> many (char '0')) >> return 1) + prettyHeaderValue (Accept xs) = concat $ intersperse ", " [prettyHeaderValue a ++ "; q=" ++ showQuality q | (a,q) <- xs] + where showQuality q = showFFloat (Just 3) q "" + +starOrEqualTo :: String -> String -> Bool +starOrEqualTo x y = x == "*" || x == y + +negotiate :: Acceptable a => [a] -> Maybe (Accept a) -> [a] +negotiate ys Nothing = ys +negotiate ys (Just xs) = reverse [ z | (q,z) <- sortBy (compare `on` fst) [ (quality xs y,y) | y <- ys], q > 0] + +--testNegotiate :: (HeaderValue a, Acceptable a) => [String] -> String -> [a] +--testNegotiate ts a = negotiate [t | Just t <- map (parseM parseHeaderValue "<source>") ts] (parseM parseHeaderValue "<source>" a) + +quality :: Acceptable a => Accept a -> a -> Quality +quality (Accept xs) y = fromMaybe 0 $ listToMaybe $ sort $ map snd $ sortBy (compareSpecificity `on` fst) $ filter ((`includes` y) . fst) xs + +compareSpecificity :: Acceptable a => a -> a -> Ordering +compareSpecificity x y + | x `includes` y && y `includes` x = EQ + | x `includes` y = GT + | y `includes` x = LT + | otherwise = error "Non-comparable Acceptables" + +-- +-- ** Accept +-- + +instance Acceptable ContentType where + includes x y = ctType x `starOrEqualTo` ctType y + && ctSubtype x `starOrEqualTo` ctSubtype y + && all (hasParameter y) (ctParameters x) + top = ContentType "*" "*" [] + +hasParameter :: ContentType -> (String, String) -> Bool +hasParameter t (k,v) = maybe False (==v) $ lookup k (ctParameters t) + +-- +-- ** Accept-Charset +-- + +{- +RFC 2616 14.2: + +The special value "*", if present in the Accept-Charset field, matches +every character set (including ISO-8859-1) which is not mentioned +elsewhere in the Accept-Charset field. If no "*" is present in an +Accept-Charset field, then all character sets not explicitly mentioned +get a quality value of 0, except for ISO-8859-1, which gets a quality +value of 1 if not explicitly mentioned. + +If no Accept-Charset header is present, the default is that any +character set is acceptable. If an Accept-Charset header is present, +and if the server cannot send a response which is acceptable according +to the Accept-Charset header, then the server SHOULD send an error +response with the 406 (not acceptable) status code, though the sending +of an unacceptable response is also allowed. +-} + +newtype Charset = Charset String + deriving (Show) + +instance Eq Charset where + Charset x == Charset y = caseInsensitiveEq x y + +instance Ord Charset where + Charset x `compare` Charset y = caseInsensitiveCompare x y + +instance HeaderValue Charset where + parseHeaderValue = fmap Charset $ many ws1 >> lexeme p_token + prettyHeaderValue (Charset s) = s + +instance Acceptable Charset where + Charset x `includes` Charset y = starOrEqualTo x y + top = Charset "*" + +-- +-- ** Accept-Encoding +-- + +{- +RFC 2616, section 14.3 +-} + +newtype ContentEncoding = ContentEncoding String + deriving (Show) + +instance Eq ContentEncoding where + ContentEncoding x == ContentEncoding y = caseInsensitiveEq x y + +instance Ord ContentEncoding where + ContentEncoding x `compare` ContentEncoding y = caseInsensitiveCompare x y + +instance HeaderValue ContentEncoding where + parseHeaderValue = fmap ContentEncoding $ many ws1 >> lexeme p_token + prettyHeaderValue (ContentEncoding s) = s + +instance Acceptable ContentEncoding where + ContentEncoding x `includes` ContentEncoding y = starOrEqualTo x y + top = ContentEncoding "*" + +-- +-- ** Accept-Language +-- + +newtype Language = Language String + deriving (Show) + +instance Eq Language where + Language x == Language y = caseInsensitiveEq x y + +instance Ord Language where + Language x `compare` Language y = caseInsensitiveCompare x y + +instance HeaderValue Language where + parseHeaderValue = fmap Language $ many ws1 >> lexeme p_token + prettyHeaderValue (Language s) = s + +{- +RFC 2616 14.4 + +A language-range matches a language-tag if it exactly equals the tag, +or if it exactly equals a prefix of the tag such that the first tag +character following the prefix is "-". The special range "*", if +present in the Accept-Language field, matches every tag not matched by +any other range present in the Accept-Language field. +-} +instance Acceptable Language where + Language x `includes` Language y = + x == "*" || x == y || (x `isPrefixOf` y && "-" `isPrefixOf` drop (length x) y) + top = Language "*"
+ src/Network/CGI/Compat.hs view
@@ -0,0 +1,112 @@+----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Compat +-- Copyright : (c) The University of Glasgow 2001 +-- (c) Bjorn Bringert 2004-2006 +-- (c) Ian Lynagh 2005 +-- (c) Jeremy Shaw 2005 +-- License : BSD-style +-- +-- Maintainer : John Chee <cheecheeo@gmail.com> +-- Stability : experimental +-- Portability : non-portable (uses Control.Monad.State) +-- +-- Compatibility functions for the old Network.CGI API. +-- +----------------------------------------------------------------------------- + +module Network.CGI.Compat ( + Html, wrapper, pwrapper, connectToCGIScript + ) where + +import Control.Concurrent (forkIO) +import Control.Exception as Exception (SomeException, throw, catch, finally) +import Control.Monad (unless) +import Control.Monad.Trans (MonadIO, liftIO) +import Network (PortID, Socket, listenOn, connectTo) +import Network.Socket as Socket (SockAddr(SockAddrInet), accept, socketToHandle) +import System.IO (Handle, hPutStrLn, stdin, stdout, hGetLine, hClose, IOMode(ReadWriteMode)) +import qualified Data.Map as Map + +import System.IO.Error (isEOFError) + +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BS + +import Text.XHtml (Html, renderHtml) + +import Network.CGI.Protocol + +{-# DEPRECATED wrapper, pwrapper, connectToCGIScript "Use the new interface." #-} + +-- | Compatibility wrapper for the old CGI interface. +-- Output the output from a function from CGI environment and +-- input variables to an HTML document. +wrapper :: ([(String,String)] -> IO Html) -> IO () +wrapper = run stdin stdout + +-- | Compatibility wrapper for the old CGI interface. +-- Runs a simple CGI server. +-- Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main. +pwrapper :: PortID -- ^ The port to run the server on. + -> ([(String,String)] -> IO Html) + -> IO () +pwrapper pid f = do sock <- listenOn pid + acceptConnections fn sock + where fn h = run h h f + +acceptConnections :: (Handle -> IO ()) -> Socket -> IO () +acceptConnections fn sock = do + (h, SockAddrInet _ _) <- accept' sock + _ <- forkIO (fn h `finally` (hClose h)) + acceptConnections fn sock + +accept' :: Socket -- Listening Socket + -> IO (Handle,SockAddr) -- StdIO Handle for read/write +accept' sock = do + (sock', addr) <- Socket.accept sock + handle <- socketToHandle sock' ReadWriteMode + return (handle,addr) + +run :: MonadIO m => Handle -> Handle -> ([(String,String)] -> IO Html) -> m () +run inh outh f = + do env <- getCGIVars + hRunCGI env inh outh f' + where f' req = do let vs = Map.toList (cgiVars req) + is = [ (n,BS.unpack (inputValue i)) | (n,i) <- cgiInputs req ] + html <- liftIO (f (vs++is)) + return ([], CGIOutput $ BS.pack $ renderHtml html) + +-- | Note: if using Windows, you might need to wrap 'Network.withSocketsDo' around main. +connectToCGIScript :: String -> PortID -> IO () +connectToCGIScript host portId + = do env <- getCGIVars + input <- BS.hGetContents stdin + let str = getRequestInput env input + h <- connectTo host portId + `Exception.catch` + (\ e -> abort "Cannot connect to CGI daemon." e) + BS.hPut h str >> hPutStrLn h "" + (sendBack h `finally` hClose h) + `Exception.catch` (\e -> unless (isEOFError e) (ioError e)) + +-- | Returns the query string, or the request body if it is +-- a POST request, or the empty string if there is an error. +getRequestInput :: [(String,String)] -- ^ CGI environment variables. + -> ByteString -- ^ Request body. + -> ByteString -- ^ Query string. +getRequestInput env req = + case lookup "REQUEST_METHOD" env of + Just "POST" -> takeInput env req + _ -> maybe BS.empty BS.pack (lookup "QUERY_STRING" env) + +abort :: String -> SomeException -> IO a +abort msg e = + do putStrLn ("Content-type: text/html\n\n" ++ + "<html><body>" ++ msg ++ "</body></html>") + throw e + +sendBack :: Handle -> IO () +sendBack h = do s <- hGetLine h + putStrLn s + sendBack h
+ src/Network/CGI/Cookie.hs view
@@ -0,0 +1,154 @@+----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Cookie +-- Copyright : (c) Bjorn Bringert 2004-2005 +-- (c) Ian Lynagh 2005 +-- License : BSD-style +-- +-- Maintainer : John Chee <cheecheeo@gmail.com> +-- Stability : experimental +-- Portability : portable +-- +-- General server side HTTP cookie library. +-- Based on <http://wp.netscape.com/newsref/std/cookie_spec.html> +-- +-- TODO +-- +-- * Add client side stuff (basically parsing Set-Cookie: value) +-- +-- * Update for RFC2109 <http://www.ietf.org/rfc/rfc2109.txt> +-- +----------------------------------------------------------------------------- +module Network.CGI.Cookie ( + Cookie(..) + , newCookie + , findCookie, deleteCookie + , showCookie, readCookies + ) where + +import Data.Char (isSpace) +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import System.Locale (defaultTimeLocale, rfc822DateFormat) +import System.Time (CalendarTime(..), Month(..), Day(..), + formatCalendarTime) + +-- +-- * Types +-- + +-- | Contains all information about a cookie set by the server. +data Cookie = Cookie { + -- | Name of the cookie. + cookieName :: String, + -- | Value of the cookie. + cookieValue :: String, + -- | Expiry date of the cookie. If 'Nothing', the + -- cookie expires when the browser sessions ends. + -- If the date is in the past, the client should + -- delete the cookie immediately. + cookieExpires :: Maybe CalendarTime, + -- | The domain suffix to which this cookie will be sent. + cookieDomain :: Maybe String, + -- | The path to which this cookie will be sent. + cookiePath :: Maybe String, + -- | 'True' if this cookie should only be sent using + -- secure means. + cookieSecure :: Bool + } + deriving (Show, Read, Eq, Ord) + +-- +-- * Constructing cookies +-- + +-- | Construct a cookie with only name and value set. +-- This client will expire when the browser sessions ends, +-- will only be sent to the server and path which set it +-- and may be sent using any means. +newCookie :: String -- ^ Name + -> String -- ^ Value + -> Cookie -- ^ Cookie +newCookie name value = Cookie { cookieName = name, + cookieValue = value, + cookieExpires = Nothing, + cookieDomain = Nothing, + cookiePath = Nothing, + cookieSecure = False + } + +-- +-- * Getting and setting cookies +-- + +-- | Get the value of a cookie from a string on the form +-- @\"cookieName1=cookieValue1;...;cookieName2=cookieValue2\"@. +-- This is the format of the @Cookie@ HTTP header. +findCookie :: String -- ^ Cookie name + -> String -- ^ Semicolon separated list of name-value pairs + -> Maybe String -- ^ Cookie value, if found +findCookie name s = maybeLast [ cv | (cn,cv) <- readCookies s, cn == name ] + +-- | Delete a cookie from the client by setting the cookie expiry date +-- to a date in the past. +deleteCookie :: Cookie -- ^ Cookie to delete. The only fields that matter + -- are 'cookieName', 'cookieDomain' and 'cookiePath' + -> Cookie +deleteCookie c = c { cookieExpires = Just epoch } + where + epoch = CalendarTime { + ctYear = 1970, + ctMonth = January, + ctDay = 1, + ctHour = 0, + ctMin = 0, + ctSec = 0, + ctPicosec = 0, + ctWDay = Thursday, + ctYDay = 1, + ctTZName = "GMT", + ctTZ = 0, + ctIsDST = False + } + +-- +-- * Reading and showing cookies +-- + +-- | Show a cookie on the format used as the value of the Set-Cookie header. +showCookie :: Cookie -> String +showCookie c = concat $ intersperse "; " $ + showPair (cookieName c) (cookieValue c) + : catMaybes [expires, path, domain, secure] + where expires = fmap (showPair "expires" . dateFmt) (cookieExpires c) + domain = fmap (showPair "domain") (cookieDomain c) + path = fmap (showPair "path") (cookiePath c) + secure = if cookieSecure c then Just "secure" else Nothing + dateFmt = formatCalendarTime defaultTimeLocale rfc822DateFormat + +-- | Show a name-value pair. FIXME: if the name or value +-- contains semicolons, this breaks. The problem +-- is that the original cookie spec does not mention +-- how to do escaping or quoting. +showPair :: String -- ^ name + -> String -- ^ value + -> String +showPair name value = name ++ "=" ++ value + +-- | Gets all the cookies from a Cookie: header value +readCookies :: String -- ^ String to parse + -> [(String,String)] -- ^ Cookie name - cookie value pairs +readCookies s = + let (xs,ys) = break (=='=') (dropWhile isSpace s) + (zs,ws) = break (==';') (dropWhile isSpace (drop 1 ys)) + in if null xs then [] else (xs,zs):readCookies (drop 1 ws) + +-- +-- Utilities +-- + +-- | Return 'Nothing' is the list is empty, otherwise return +-- the last element of the list. +maybeLast :: [a] -> Maybe a +maybeLast [] = Nothing +maybeLast xs = Just (last xs)
+ src/Network/CGI/Monad.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Monad +-- Copyright : (c) Bjorn Bringert 2006 +-- License : BSD-style +-- +-- Maintainer : John Chee <cheecheeo@gmail.com> +-- Stability : experimental +-- Portability : non-portable +-- +-- Internal stuff that most people shouldn't have to use. +-- This module mostly deals with the +-- internals of the CGIT monad transformer. +-- +----------------------------------------------------------------------------- + +module Network.CGI.Monad ( + -- * CGI monad class + MonadCGI(..), + -- * CGI monad transformer + CGIT(..), CGI, + runCGIT, + -- * Request info + CGIRequest(..), + -- * Error handling + throwCGI, catchCGI, tryCGI, handleExceptionCGI, + ) where + +import Control.Applicative (Applicative(..)) +import Control.Exception as Exception (SomeException) +import Control.Monad (liftM) +import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask, throwM, catch, try, mask, uninterruptibleMask) +import Control.Monad.Error (MonadError(..)) +import Control.Monad.Reader (ReaderT(..), asks) +import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift) +import Control.Monad.Writer (WriterT(..), tell) +import Prelude hiding (catch) +-- #if MIN_VERSION_base(4,7,0) +-- import Data.Typeable +-- #else +-- import Data.Typeable (Typeable(..), Typeable1(..), +-- mkTyConApp, mkTyCon) +-- #endif + +import Network.CGI.Protocol + +-- +-- * CGIT monad transformer +-- + +-- | A simple CGI monad with just IO. +type CGI a = CGIT IO a + +-- | The CGIT monad transformer. +newtype CGIT m a = CGIT { unCGIT :: ReaderT CGIRequest (WriterT Headers m) a } +-- #if MIN_VERSION_base(4,7,0) +-- deriving (Typeable) +-- +-- #else +-- instance (Typeable1 m, Typeable a) => Typeable (CGIT m a) where +-- typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Monad.CGIT") +-- [typeOf1 (undefined :: m a), typeOf (undefined :: a)] +-- #endif + +instance (Functor m, Monad m) => Functor (CGIT m) where + fmap f c = CGIT (fmap f (unCGIT c)) + +instance (Applicative m, Monad m) => Applicative (CGIT m) where + pure = CGIT . pure + f <*> x = CGIT (unCGIT f <*> unCGIT x) + +instance Monad m => Monad (CGIT m) where + c >>= f = CGIT (unCGIT c >>= unCGIT . f) + return = CGIT . return + -- FIXME: should we have an error monad instead? + fail = CGIT . fail + +instance MonadIO m => MonadIO (CGIT m) where + liftIO = lift . liftIO + +instance MonadThrow m => MonadThrow (CGIT m) where + throwM e = CGIT . throwM $ e + +instance MonadCatch m => MonadCatch (CGIT m) where + CGIT m `catch` h = CGIT $ m `catch` (unCGIT . h) + +instance MonadMask m => MonadMask (CGIT m) where + mask a = CGIT $ mask $ \u -> unCGIT $ a $ CGIT . u . unCGIT + uninterruptibleMask a = CGIT $ uninterruptibleMask $ \u -> unCGIT $ a $ CGIT . u . unCGIT + +-- | The class of CGI monads. Most CGI actions can be run in +-- any monad which is an instance of this class, which means that +-- you can use your own monad transformers to add extra functionality. +class Monad m => MonadCGI m where + -- | Add a response header. + cgiAddHeader :: HeaderName -> String -> m () + -- | Get something from the CGI request. + cgiGet :: (CGIRequest -> a) -> m a + +instance Monad m => MonadCGI (CGIT m) where + cgiAddHeader n v = CGIT $ lift $ tell [(n,v)] + cgiGet = CGIT . asks + +instance MonadTrans CGIT where + lift = CGIT . lift . lift + +-- | Run a CGI action. +runCGIT :: Monad m => CGIT m a -> CGIRequest -> m (Headers, a) +runCGIT (CGIT c) = liftM (uncurry (flip (,))) . runWriterT . runReaderT c + +-- +-- * Error handling +-- + +instance MonadCatch m => MonadError SomeException (CGIT m) where + throwError = throwM + catchError = catch + +-- | Throw an exception in a CGI monad. The monad is required to be +-- a 'MonadThrow', so that we can use 'throwM' to guarantee ordering. +throwCGI :: (MonadCGI m, MonadThrow m) => SomeException -> m a +throwCGI = throwM + +-- | Catches any expection thrown by a CGI action, and uses the given +-- exception handler if an exception is thrown. +catchCGI :: (MonadCGI m, MonadCatch m) => m a -> (SomeException -> m a) -> m a +catchCGI = catch + +-- | Catches any exception thrown by an CGI action, and returns either +-- the exception, or if no exception was raised, the result of the action. +tryCGI :: (Functor m, MonadCGI m, MonadCatch m) => m a -> m (Either SomeException a) +tryCGI = try + +{-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-} +-- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead. +handleExceptionCGI :: (MonadCGI m, MonadCatch m) => m a -> (SomeException -> m a) -> m a +handleExceptionCGI = catchCGI
+ src/Network/CGI/Protocol.hs view
@@ -0,0 +1,317 @@+----------------------------------------------------------------------------- +-- | +-- Module : Network.CGI.Protocol +-- Copyright : (c) Bjorn Bringert 2006 +-- License : BSD-style +-- +-- Maintainer : John Chee <cheecheeo@gmail.com> +-- Stability : experimental +-- Portability : non-portable +-- +-- An implementation of the program side of the CGI protocol. +-- +----------------------------------------------------------------------------- +{-# LANGUAGE CPP, DeriveDataTypeable #-} +module Network.CGI.Protocol ( + -- * CGI request + CGIRequest(..), Input(..), + -- * CGI response + CGIResult(..), + Headers, HeaderName(..), + -- * Running CGI actions + hRunCGI, runCGIEnvFPS, + -- * Inputs + decodeInput, takeInput, + -- * Environment variables + getCGIVars, + -- * Logging + logCGI, + -- * URL encoding + formEncode, urlEncode, formDecode, urlDecode, + -- * Utilities + maybeRead, replace + ) where + +import Control.Monad.Trans (MonadIO(..)) +import Data.List (intersperse) +import Data.Map (Map) +import Data.Maybe (fromMaybe, listToMaybe, isJust) +import Network.URI (unEscapeString,escapeURIString,isUnescapedInURI) +import System.Environment (getEnvironment) +import System.IO (Handle, hPutStrLn, stderr, hFlush, hSetBinaryMode) +import qualified Data.Map as Map + +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BS + +-- #if MIN_VERSION_base(4,7,0) +-- import Data.Typeable +-- #else +-- import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon) +-- #endif + +import Network.Multipart + +-- +-- * CGI request +-- + +-- | The input to a CGI action. +data CGIRequest = + CGIRequest { + -- | Environment variables. + cgiVars :: Map String String, + -- | Input parameters. For better laziness in reading inputs, + -- this is not a Map. + cgiInputs :: [(String, Input)], + -- | Raw request body. To avoid memory leaks, + -- this is the empty string if the request body has been + -- interpreted as inputs in + -- "application\/x-www-form-urlencoded" or + -- "multipart\/form-data" format. + cgiRequestBody :: ByteString + } + deriving (Show) + +-- #if ! MIN_VERSION_base(4,7,0) +-- instance Typeable CGIResult where +-- typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Protocol.CGIResult") [] +-- #endif + +-- | The value of an input parameter, and some metadata. +data Input = Input { + inputValue :: ByteString, + inputFilename :: Maybe String, + inputContentType :: ContentType + } + deriving Show + +-- +-- * CGI response +-- + +-- | The result of a CGI program. +data CGIResult = CGIOutput ByteString + | CGINothing +-- #if MIN_VERSION_base(4,7,0) +-- deriving (Show, Read, Eq, Ord, Typeable) +-- #else + deriving (Show, Read, Eq, Ord) +-- #endif + +-- +-- * Running CGI actions +-- + +-- | Runs a CGI action in a given environment. Uses Handles for input and output. +hRunCGI :: MonadIO m => + [(String,String)] -- ^ CGI environment variables, e.g. from 'getCGIVars'. + -> Handle -- ^ Handle that input will be read from, e.g. 'System.IO.stdin'. + -> Handle -- ^ Handle that output will be written to, e.g. 'System.IO.stdout'. + -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action + -> m () +hRunCGI env hin hout f = + do liftIO $ hSetBinaryMode hin True + inp <- liftIO $ BS.hGetContents hin + outp <- runCGIEnvFPS env inp f + liftIO $ BS.hPut hout outp + liftIO $ hFlush hout + +-- | Runs a CGI action in a given environment. Uses lazy ByteStrings +-- for input and output. +runCGIEnvFPS :: Monad m => + [(String,String)] -- ^ CGI environment variables. + -> ByteString -- ^ Request body. + -> (CGIRequest -> m (Headers, CGIResult)) -- ^ CGI action. + -> m ByteString -- ^ Response (headers and content). +runCGIEnvFPS vars inp f + = do let (inputs,body) = decodeInput vars inp + (hs,outp) <- f $ CGIRequest { + cgiVars = Map.fromList vars, + cgiInputs = inputs, + cgiRequestBody = body + } + return $ case outp of + CGIOutput c -> formatResponse c hs' + where hs' = if isJust (lookup ct hs) + then hs else hs ++ [(ct,defaultContentType)] + ct = HeaderName "Content-type" + CGINothing -> formatResponse BS.empty hs + +formatResponse :: ByteString -> Headers -> ByteString +formatResponse c hs = + -- NOTE: we use CRLF since lighttpd mod_fastcgi can't handle + -- just LF if there are CRs in the content. + unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs] + ++ [BS.empty,c]) + where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n") + +defaultContentType :: String +defaultContentType = "text/html; charset=ISO-8859-1" + +-- +-- * Inputs +-- + +-- | Gets and decodes the input according to the request +-- method and the content-type. +decodeInput :: [(String,String)] -- ^ CGI environment variables. + -> ByteString -- ^ Request body. + -> ([(String,Input)],ByteString) + -- ^ A list of input variables and values, and the request body + -- if it was not interpreted. +decodeInput env inp = + let (inputs, body) = bodyInput env inp in (queryInput env ++ inputs, body) + +-- | Builds an 'Input' object for a simple value. +simpleInput :: String -> Input +simpleInput v = Input { inputValue = BS.pack v, + inputFilename = Nothing, + inputContentType = defaultInputType } + +-- | The default content-type for variables. +defaultInputType :: ContentType +defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding? + +-- +-- * Environment variables +-- + +-- | Gets the values of all CGI variables from the program environment. +getCGIVars :: MonadIO m => m [(String,String)] +getCGIVars = liftIO getEnvironment + +-- +-- * Logging +-- + +-- | Logs some message using the server\'s logging facility. +-- FIXME: does this have to be more general to support +-- FastCGI etc? Maybe we should store log messages in the +-- CGIState? +logCGI :: MonadIO m => String -> m () +logCGI s = liftIO (hPutStrLn stderr s) + +-- +-- * Query string +-- + +-- | Gets inputs from the query string. +queryInput :: [(String,String)] -- ^ CGI environment variables. + -> [(String,Input)] -- ^ Input variables and values. +queryInput env = formInput $ lookupOrNil "QUERY_STRING" env + +-- | Decodes application\/x-www-form-urlencoded inputs. +formInput :: String + -> [(String,Input)] -- ^ Input variables and values. +formInput qs = [(n, simpleInput v) | (n,v) <- formDecode qs] + +-- +-- * URL encoding +-- + +-- | Formats name-value pairs as application\/x-www-form-urlencoded. +formEncode :: [(String,String)] -> String +formEncode xs = + concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs] + +-- | Converts a single value to the application\/x-www-form-urlencoded encoding. +urlEncode :: String -> String +urlEncode = replace ' ' '+' . escapeURIString okChar + where okChar c = c == ' ' || + (isUnescapedInURI c && c `notElem` "&=+") + +-- | Gets the name-value pairs from application\/x-www-form-urlencoded data. +formDecode :: String -> [(String,String)] +formDecode "" = [] +formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs) + where (nv,rs) = break (=='&') s + (n,v) = break (=='=') nv + +-- | Converts a single value from the +-- application\/x-www-form-urlencoded encoding. +urlDecode :: String -> String +urlDecode = unEscapeString . replace '+' ' ' + +-- +-- * Request content and form-data stuff +-- + +-- | Gets input variables from the body, if any. +bodyInput :: [(String,String)] + -> ByteString + -> ([(String,Input)], ByteString) +bodyInput env inp = + case lookup "REQUEST_METHOD" env of + Just "POST" -> + let ctype = lookup "CONTENT_TYPE" env >>= parseContentType + in decodeBody ctype $ takeInput env inp + _ -> ([], inp) + +-- | Decodes a POST body. +decodeBody :: Maybe ContentType + -> ByteString + -> ([(String,Input)], ByteString) +decodeBody ctype inp = + case ctype of + Just (ContentType "application" "x-www-form-urlencoded" _) + -> (formInput (BS.unpack inp), BS.empty) + Just (ContentType "multipart" "form-data" ps) + -> (multipartDecode ps inp, BS.empty) + Just _ -> ([], inp) -- unknown content-type, the user will have to + -- deal with it by looking at the raw content + -- No content-type given, assume x-www-form-urlencoded + Nothing -> (formInput (BS.unpack inp), BS.empty) + +-- | Takes the right number of bytes from the input. +takeInput :: [(String,String)] -- ^ CGI environment variables. + -> ByteString -- ^ Request body. + -> ByteString -- ^ CONTENT_LENGTH bytes from the request + -- body, or the empty string if there is no + -- CONTENT_LENGTH. +takeInput env req = + case len of + Just l -> BS.take l req + Nothing -> BS.empty + where len = lookup "CONTENT_LENGTH" env >>= maybeRead + +-- | Decodes multipart\/form-data input. +multipartDecode :: [(String,String)] -- ^ Content-type parameters + -> ByteString -- ^ Request body + -> [(String,Input)] -- ^ Input variables and values. +multipartDecode ps inp = + case lookup "boundary" ps of + Just b -> let MultiPart bs = parseMultipartBody b inp + in map bodyPartToInput bs + Nothing -> [] -- FIXME: report that there was no boundary + +bodyPartToInput :: BodyPart -> (String,Input) +bodyPartToInput (BodyPart hs b) = + case getContentDisposition hs of + Just (ContentDisposition "form-data" ps) -> + (lookupOrNil "name" ps, + Input { inputValue = b, + inputFilename = lookup "filename" ps, + inputContentType = ctype }) + _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error + where ctype = fromMaybe defaultInputType (getContentType hs) + +-- +-- * Utilities +-- + +-- | Replaces all instances of a value in a list by another value. +replace :: Eq a => + a -- ^ Value to look for + -> a -- ^ Value to replace it with + -> [a] -- ^ Input list + -> [a] -- ^ Output list +replace x y = map (\z -> if z == x then y else z) + +maybeRead :: Read a => String -> Maybe a +maybeRead = fmap fst . listToMaybe . reads + +-- | Same as 'lookup' specialized to strings, but +-- returns the empty string if lookup fails. +lookupOrNil :: String -> [(String,String)] -> String +lookupOrNil n = fromMaybe "" . lookup n