diff --git a/CHANGELOG.txt b/CHANGELOG.txt --- a/CHANGELOG.txt +++ b/CHANGELOG.txt @@ -1,3 +1,17 @@ +Changelog ideas-1.4 => ideas.1.5 + +* upgrade to ghc-7.10 +* reintroducing dependency on standard cgi library +* adding missing instances for Term and ShowString +* new option for JSON mode: exercise terms can be encoded in JSON +* switched to QuickCheck's random number generator QCGen +* requests can fix the random seed +* added Term to service types, encoders and decoders +* JSON-Int can be used for decoded environments +* new implementation for interleave and atomic prefix combinators (more lazy) +* bug fix: "no prefix" now handled by json decoder + + Changelog ideas-1.3.1 => ideas.1.4 ----------------------------------------------------------------------------- diff --git a/NOTICE.txt b/NOTICE.txt --- a/NOTICE.txt +++ b/NOTICE.txt @@ -1,4 +1,4 @@ -Copyright 2015 Ideas project team +Copyright 2016 Ideas project team Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -34,11 +34,5 @@ CREDITS - 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 + Harrie Passier, Arthur van Leeuwen, Josje Lodder, Hieke Keuning, + Marcell van Geest, Jordy van Dortmont diff --git a/ideas.cabal b/ideas.cabal --- a/ideas.cabal +++ b/ideas.cabal @@ -1,5 +1,5 @@ name: ideas -version: 1.4 +version: 1.5 synopsis: Feedback services for intelligent tutoring systems homepage: http://ideas.cs.uu.nl/www/ description: @@ -19,7 +19,7 @@ practicing communication skills (the serious game Communicate!). category: Education -copyright: (c) 2015 +copyright: (c) 2016 license: Apache-2.0 license-file: LICENSE.txt author: Bastiaan Heeren, Alex Gerdes, Johan Jeuring @@ -28,15 +28,11 @@ extra-source-files: NOTICE.txt, CHANGELOG.txt build-type: Simple cabal-version: >= 1.8.0.2 -tested-with: GHC == 7.4.1, GHC == 7.8.3, GHC == 7.8.4 +tested-with: GHC == 7.10.3 source-repository head - type: svn - location: https://ideas.cs.uu.nl/svn/Feedback/trunk/ - -flag network-uri - description: Get Network.URI from the network-uri package - default: True + type: git + location: https://github.com/ideas-edu/ideas.git flag logging description: enable support for logging interactions to a sqlite3 database @@ -52,30 +48,19 @@ ghc-options: -Wall hs-source-dirs: src - Build-Depends: base >= 4.2 && < 5, - mtl == 2.1.*, - QuickCheck >= 2.4.1 && < 2.7, - Diff, - containers, - random, - uniplate, - time, - filepath, - directory, - parsec, - wl-pprint, - array, - exceptions, - multipart, - bytestring, - old-time, - old-locale, - xhtml - - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network < 2.6 + Build-Depends: + base >= 4.8 && < 5, + cgi >= 3001.3.0.0, + QuickCheck >= 2.8, + Diff, + containers, + directory, + filepath, + parsec, + random, + time, + uniplate, + wl-pprint Exposed-modules: Ideas.Common.Algebra.Boolean @@ -192,14 +177,6 @@ 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 -------------------------------------------------------------------------------- diff --git a/src/Ideas/Common/Algebra/Boolean.hs b/src/Ideas/Common/Algebra/Boolean.hs --- a/src/Ideas/Common/Algebra/Boolean.hs +++ b/src/Ideas/Common/Algebra/Boolean.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Boolean.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Algebra.Boolean ( -- * Boolean algebra diff --git a/src/Ideas/Common/Algebra/BooleanLaws.hs b/src/Ideas/Common/Algebra/BooleanLaws.hs --- a/src/Ideas/Common/Algebra/BooleanLaws.hs +++ b/src/Ideas/Common/Algebra/BooleanLaws.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: BooleanLaws.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Algebra.BooleanLaws ( -- * Boolean laws diff --git a/src/Ideas/Common/Algebra/Field.hs b/src/Ideas/Common/Algebra/Field.hs --- a/src/Ideas/Common/Algebra/Field.hs +++ b/src/Ideas/Common/Algebra/Field.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Field.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Common.Algebra.Field ( -- * Semi-ring diff --git a/src/Ideas/Common/Algebra/FieldLaws.hs b/src/Ideas/Common/Algebra/FieldLaws.hs --- a/src/Ideas/Common/Algebra/FieldLaws.hs +++ b/src/Ideas/Common/Algebra/FieldLaws.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: FieldLaws.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Algebra.FieldLaws ( -- * Semi-ring laws diff --git a/src/Ideas/Common/Algebra/Group.hs b/src/Ideas/Common/Algebra/Group.hs --- a/src/Ideas/Common/Algebra/Group.hs +++ b/src/Ideas/Common/Algebra/Group.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Group.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Algebra.Group ( -- * Monoids @@ -26,10 +25,8 @@ import Control.Applicative import Control.Monad (liftM2) -import Data.Foldable (Foldable) import Data.Maybe import Data.Monoid -import Data.Traversable (Traversable, traverse) import Ideas.Common.Classes import qualified Data.Set as S diff --git a/src/Ideas/Common/Algebra/GroupLaws.hs b/src/Ideas/Common/Algebra/GroupLaws.hs --- a/src/Ideas/Common/Algebra/GroupLaws.hs +++ b/src/Ideas/Common/Algebra/GroupLaws.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: GroupLaws.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Algebra.GroupLaws ( -- * Monoid laws @@ -29,9 +28,9 @@ , leftDistributiveFor, rightDistributiveFor ) where -import Data.Monoid import Ideas.Common.Algebra.Group import Ideas.Common.Algebra.Law +import Prelude hiding ((<*>)) -------------------------------------------------------- -- Monoids diff --git a/src/Ideas/Common/Algebra/Law.hs b/src/Ideas/Common/Algebra/Law.hs --- a/src/Ideas/Common/Algebra/Law.hs +++ b/src/Ideas/Common/Algebra/Law.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Law.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Common.Algebra.Law ( Law, LawSpec((:==:)), law, lawAbs, mapLaw diff --git a/src/Ideas/Common/Algebra/SmartGroup.hs b/src/Ideas/Common/Algebra/SmartGroup.hs --- a/src/Ideas/Common/Algebra/SmartGroup.hs +++ b/src/Ideas/Common/Algebra/SmartGroup.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: SmartGroup.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Algebra.SmartGroup ( -- * Smart datatypes diff --git a/src/Ideas/Common/Classes.hs b/src/Ideas/Common/Classes.hs --- a/src/Ideas/Common/Classes.hs +++ b/src/Ideas/Common/Classes.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Type classes and instances. -- ----------------------------------------------------------------------------- --- $Id: Classes.hs 8763 2015-10-23 06:46:32Z bastiaan $ module Ideas.Common.Classes ( -- * Type class Apply diff --git a/src/Ideas/Common/Context.hs b/src/Ideas/Common/Context.hs --- a/src/Ideas/Common/Context.hs +++ b/src/Ideas/Common/Context.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -16,7 +16,6 @@ -- the 'Navigator' type class (for traversing the term). -- ----------------------------------------------------------------------------- --- $Id: Context.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Context ( -- * Abstract data type diff --git a/src/Ideas/Common/CyclicTree.hs b/src/Ideas/Common/CyclicTree.hs --- a/src/Ideas/Common/CyclicTree.hs +++ b/src/Ideas/Common/CyclicTree.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: CyclicTree.hs 8747 2015-10-15 14:54:48Z bastiaan $ module Ideas.Common.CyclicTree ( -- * Data type @@ -28,9 +27,7 @@ import Control.Applicative import Control.Monad -import Data.Foldable (Foldable, foldMap) import Data.List (intercalate) -import Data.Traversable (Traversable, traverse, sequenceA) import Ideas.Common.Classes import Ideas.Common.Id import Test.QuickCheck hiding (label) diff --git a/src/Ideas/Common/Derivation.hs b/src/Ideas/Common/Derivation.hs --- a/src/Ideas/Common/Derivation.hs +++ b/src/Ideas/Common/Derivation.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- and the steps) -- ----------------------------------------------------------------------------- --- $Id: Derivation.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Derivation ( -- * Data type diff --git a/src/Ideas/Common/DerivationTree.hs b/src/Ideas/Common/DerivationTree.hs --- a/src/Ideas/Common/DerivationTree.hs +++ b/src/Ideas/Common/DerivationTree.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- intermediate results as well as annotations for the steps. -- ----------------------------------------------------------------------------- --- $Id: DerivationTree.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.DerivationTree ( -- * Data types diff --git a/src/Ideas/Common/Environment.hs b/src/Ideas/Common/Environment.hs --- a/src/Ideas/Common/Environment.hs +++ b/src/Ideas/Common/Environment.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- References, bindings, and heterogenous environments -- ----------------------------------------------------------------------------- --- $Id: Environment.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Environment ( -- * Reference @@ -29,7 +28,6 @@ import Control.Monad import Data.Function import Data.List -import Data.Monoid import Data.Typeable import Ideas.Common.Id import Ideas.Common.Rewriting.Term @@ -72,6 +70,8 @@ instance Reference Char where makeRefList n = Ref (newId n) id Just variableView + +instance Reference ShowString instance Reference a => Reference [a] where makeRef = makeRefList diff --git a/src/Ideas/Common/Exercise.hs b/src/Ideas/Common/Exercise.hs --- a/src/Ideas/Common/Exercise.hs +++ b/src/Ideas/Common/Exercise.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Rank2Types, DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -15,7 +15,6 @@ -- "Ideas.Common.ExerciseTests" module. -- ----------------------------------------------------------------------------- --- $Id: Exercise.hs 8758 2015-10-22 06:48:52Z bastiaan $ module Ideas.Common.Exercise ( -- * Exercise record @@ -61,6 +60,7 @@ import System.Random import Test.QuickCheck hiding (label) import Test.QuickCheck.Gen +import Test.QuickCheck.Random (QCGen) import qualified Data.Map as M import qualified Ideas.Common.Strategy as S @@ -118,7 +118,7 @@ -- | A finite list of examples, each with an assigned difficulty. , examples :: Examples a -- | A generator for random exercises of a certain difficulty. - , randomExercise :: Maybe (StdGen -> Maybe Difficulty -> a) + , randomExercise :: Maybe (QCGen -> Maybe Difficulty -> a) -- | An exercise generator for testing purposes (including corner cases). , testGenerator :: Maybe (Gen a) -- | Conversion to and from the (generic) 'Term' datatype. Needed for @@ -348,12 +348,12 @@ -- | Makes a random exercise generator from a QuickCheck generator; the exercise -- generator ignores the difficulty level. See the 'randomExercise' field. -simpleGenerator :: Gen a -> Maybe (StdGen -> Maybe Difficulty -> a) +simpleGenerator :: Gen a -> Maybe (QCGen -> Maybe Difficulty -> a) simpleGenerator = useGenerator . const -- | Makes a random exercise generator based on a QuickCheck generator for a -- particular difficulty level. See the 'randomExercise' field. -useGenerator :: (Maybe Difficulty -> Gen a) -> Maybe (StdGen -> Maybe Difficulty -> a) +useGenerator :: (Maybe Difficulty -> Gen a) -> Maybe (QCGen -> Maybe Difficulty -> a) useGenerator makeGen = Just (\rng -> rec rng . makeGen) where rec rng (MkGen f) = a @@ -364,7 +364,7 @@ -- | Returns a random exercise of a certain difficulty with some random -- number generator. The field 'randomExercise' is used; if this is not -- defined (i.e., Nothing), one of the examples is used instead. -randomTerm :: StdGen -> Exercise a -> Maybe Difficulty -> Maybe a +randomTerm :: QCGen -> Exercise a -> Maybe Difficulty -> Maybe a randomTerm rng ex mdif = case randomExercise ex of Just f -> return (f rng mdif) @@ -377,7 +377,7 @@ i = fst (randomR (0, length xs - 1) rng) -- | Returns a list of randomly generated terms of a certain difficulty. -randomTerms :: StdGen -> Exercise a -> Maybe Difficulty -> [a] +randomTerms :: QCGen -> Exercise a -> Maybe Difficulty -> [a] randomTerms rng ex mdif = rec rng where rec a = maybe id (:) (randomTerm a ex mdif) (rec (snd (next a))) diff --git a/src/Ideas/Common/ExerciseTests.hs b/src/Ideas/Common/ExerciseTests.hs --- a/src/Ideas/Common/ExerciseTests.hs +++ b/src/Ideas/Common/ExerciseTests.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: ExerciseTests.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.ExerciseTests where @@ -26,19 +25,19 @@ import Ideas.Common.Rule import Ideas.Common.Utils.TestSuite import Ideas.Common.View -import System.Random import Test.QuickCheck +import Test.QuickCheck.Random --------------------------------------------------------------- -- Checks for an exercise checkExercise :: Exercise a -> IO () checkExercise ex = do - stdgen <- getStdGen - runTestSuite True (exerciseTestSuite stdgen ex) + qcgen <- newQCGen + runTestSuite True (exerciseTestSuite qcgen ex) -exerciseTestSuite :: StdGen -> Exercise a -> TestSuite -exerciseTestSuite stdgen ex = suite ("Exercise " ++ show (exerciseId ex)) $ +exerciseTestSuite :: QCGen -> Exercise a -> TestSuite +exerciseTestSuite qcgen ex = suite ("Exercise " ++ show (exerciseId ex)) $ [ assertTrue "exercise terms defined" (not (null xs)) , assertTrue "equivalence implemented" $ let eq a b = equivalence ex (inContext ex a) (inContext ex b) @@ -46,7 +45,7 @@ , assertTrue "similarity implemented" $ let sim a b = similarity ex (inContext ex a) (inContext ex b) in length (nubBy sim xs) > 1 - , checkExamples stdgen ex + , checkExamples qcgen ex ] ++ case testGenerator ex of Nothing -> [] @@ -73,7 +72,7 @@ showAsGen = showAs (prettyPrinter ex) gen where xs | isJust (randomExercise ex) = - take 10 (randomTerms stdgen ex Nothing) + take 10 (randomTerms qcgen ex Nothing) | otherwise = map snd (examples ex) data ShowAs a = S {showS :: a -> String, fromS :: a} @@ -103,15 +102,15 @@ forAll (elements xs) $ \b -> a `eq` b -checkExamples :: StdGen -> Exercise a -> TestSuite -checkExamples stdgen ex +checkExamples :: QCGen -> Exercise a -> TestSuite +checkExamples qcgen ex | null xs = mempty | otherwise = suite "Examples" $ - concatMap (checksForTerm True stdgen ex) xs + concatMap (checksForTerm True qcgen ex) xs where xs = map snd (examples ex) -checksForTerm :: Bool -> StdGen -> Exercise a -> a -> [TestSuite] +checksForTerm :: Bool -> QCGen -> Exercise a -> a -> [TestSuite] checksForTerm leftMost _ ex a = concat -- Left-most derivation @@ -120,7 +119,7 @@ Nothing -> [assertTrue ("no derivation for " ++ prettyPrinter ex a) False] | leftMost ] {- ++ - case randomDerivation stdgen tree of + case randomDerivation qcgen tree of Just d -> checksForDerivation ex d Nothing -> [] where diff --git a/src/Ideas/Common/Id.hs b/src/Ideas/Common/Id.hs --- a/src/Ideas/Common/Id.hs +++ b/src/Ideas/Common/Id.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -30,7 +30,6 @@ -- The 'Id' datatype implements and re-exports the Monoid interface. -- ----------------------------------------------------------------------------- --- $Id: Id.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Id ( -- * Constructing identifiers diff --git a/src/Ideas/Common/Library.hs b/src/Ideas/Common/Library.hs --- a/src/Ideas/Common/Library.hs +++ b/src/Ideas/Common/Library.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Exports most from package Common -- ----------------------------------------------------------------------------- --- $Id: Library.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Library ( module Export diff --git a/src/Ideas/Common/Predicate.hs b/src/Ideas/Common/Predicate.hs --- a/src/Ideas/Common/Predicate.hs +++ b/src/Ideas/Common/Predicate.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- Representation for predicates -- ----------------------------------------------------------------------------- --- $Id: Predicate.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Predicate ( -- * Predicate representation diff --git a/src/Ideas/Common/Rewriting.hs b/src/Ideas/Common/Rewriting.hs --- a/src/Ideas/Common/Rewriting.hs +++ b/src/Ideas/Common/Rewriting.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Rewriting.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rewriting (module Export) where diff --git a/src/Ideas/Common/Rewriting/AC.hs b/src/Ideas/Common/Rewriting/AC.hs --- a/src/Ideas/Common/Rewriting/AC.hs +++ b/src/Ideas/Common/Rewriting/AC.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: AC.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rewriting.AC ( -- * Types diff --git a/src/Ideas/Common/Rewriting/Confluence.hs b/src/Ideas/Common/Rewriting/Confluence.hs --- a/src/Ideas/Common/Rewriting/Confluence.hs +++ b/src/Ideas/Common/Rewriting/Confluence.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Confluence.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rewriting.Confluence ( isConfluent, checkConfluence, checkConfluenceWith diff --git a/src/Ideas/Common/Rewriting/Difference.hs b/src/Ideas/Common/Rewriting/Difference.hs --- a/src/Ideas/Common/Rewriting/Difference.hs +++ b/src/Ideas/Common/Rewriting/Difference.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- into account. -- ----------------------------------------------------------------------------- --- $Id: Difference.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rewriting.Difference ( difference, differenceEqual diff --git a/src/Ideas/Common/Rewriting/RewriteRule.hs b/src/Ideas/Common/Rewriting/RewriteRule.hs --- a/src/Ideas/Common/Rewriting/RewriteRule.hs +++ b/src/Ideas/Common/Rewriting/RewriteRule.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: RewriteRule.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rewriting.RewriteRule ( -- * Supporting type class @@ -27,7 +26,6 @@ ) where import Data.Maybe -import Data.Monoid import Ideas.Common.Classes import Ideas.Common.Environment import Ideas.Common.Id @@ -76,6 +74,9 @@ instance Different Char where different = ('a', 'b') + +instance Different Term where + different = (TNum 0, TNum 1) class (IsTerm a, Show a) => RuleBuilder t a | t -> a where buildRuleSpec :: Int -> t -> RuleSpec Term diff --git a/src/Ideas/Common/Rewriting/Substitution.hs b/src/Ideas/Common/Rewriting/Substitution.hs --- a/src/Ideas/Common/Rewriting/Substitution.hs +++ b/src/Ideas/Common/Rewriting/Substitution.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Substitutions on terms. Substitutions are idempotent, and non-cyclic. -- ----------------------------------------------------------------------------- --- $Id: Substitution.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rewriting.Substitution ( Substitution, emptySubst, singletonSubst, dom, lookupVar @@ -22,7 +21,6 @@ import Control.Monad import Data.List import Data.Maybe -import Data.Monoid import Ideas.Common.Rewriting.Term import Ideas.Common.Utils.TestSuite import Ideas.Common.Utils.Uniplate diff --git a/src/Ideas/Common/Rewriting/Term.hs b/src/Ideas/Common/Rewriting/Term.hs --- a/src/Ideas/Common/Rewriting/Term.hs +++ b/src/Ideas/Common/Rewriting/Term.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS -fno-warn-orphans #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,6 @@ -- A simple data type for term rewriting -- ----------------------------------------------------------------------------- --- $Id: Term.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rewriting.Term ( -- * Symbols diff --git a/src/Ideas/Common/Rewriting/Unification.hs b/src/Ideas/Common/Rewriting/Unification.hs --- a/src/Ideas/Common/Rewriting/Unification.hs +++ b/src/Ideas/Common/Rewriting/Unification.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Unification.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rewriting.Unification ( unify, match, matchExtended, matchList diff --git a/src/Ideas/Common/Rule.hs b/src/Ideas/Common/Rule.hs --- a/src/Ideas/Common/Rule.hs +++ b/src/Ideas/Common/Rule.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Rule.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rule (module Export) where diff --git a/src/Ideas/Common/Rule/Abstract.hs b/src/Ideas/Common/Rule/Abstract.hs --- a/src/Ideas/Common/Rule/Abstract.hs +++ b/src/Ideas/Common/Rule/Abstract.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -14,7 +14,6 @@ -- can be lifted with a view using the LiftView type class. -- ----------------------------------------------------------------------------- --- $Id: Abstract.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rule.Abstract ( -- * Rule data type and accessors @@ -34,7 +33,6 @@ import Control.Arrow import Control.Monad -import Data.Monoid import Ideas.Common.Classes import Ideas.Common.Environment import Ideas.Common.Id diff --git a/src/Ideas/Common/Rule/EnvironmentMonad.hs b/src/Ideas/Common/Rule/EnvironmentMonad.hs --- a/src/Ideas/Common/Rule/EnvironmentMonad.hs +++ b/src/Ideas/Common/Rule/EnvironmentMonad.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- State monad for environments -- ----------------------------------------------------------------------------- --- $Id: EnvironmentMonad.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rule.EnvironmentMonad ( -- * Environment Monad @@ -24,7 +23,7 @@ , envMonadRefs, envMonadFunctionRefs ) where -import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Applicative (Alternative(..)) import Control.Monad import Data.Maybe import Data.Typeable diff --git a/src/Ideas/Common/Rule/Parameter.hs b/src/Ideas/Common/Rule/Parameter.hs --- a/src/Ideas/Common/Rule/Parameter.hs +++ b/src/Ideas/Common/Rule/Parameter.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -15,7 +15,6 @@ -- the LiftView type class. -- ----------------------------------------------------------------------------- --- $Id: Parameter.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rule.Parameter ( ParamTrans diff --git a/src/Ideas/Common/Rule/Recognizer.hs b/src/Ideas/Common/Rule/Recognizer.hs --- a/src/Ideas/Common/Rule/Recognizer.hs +++ b/src/Ideas/Common/Rule/Recognizer.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Recognizer.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rule.Recognizer ( -- * data type and type class @@ -20,7 +19,6 @@ import Control.Monad import Data.Maybe -import Data.Monoid import Ideas.Common.Environment import Ideas.Common.Rule.EnvironmentMonad import Ideas.Common.Rule.Transformation diff --git a/src/Ideas/Common/Rule/Transformation.hs b/src/Ideas/Common/Rule/Transformation.hs --- a/src/Ideas/Common/Rule/Transformation.hs +++ b/src/Ideas/Common/Rule/Transformation.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, Rank2Types #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,6 @@ -- a list of results (often a singleton list or the empty list). -- ----------------------------------------------------------------------------- --- $Id: Transformation.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Rule.Transformation ( -- * Trans data type @@ -34,7 +33,6 @@ import Control.Arrow import Data.Maybe -import Data.Monoid import Data.Typeable import Ideas.Common.Classes import Ideas.Common.Context diff --git a/src/Ideas/Common/Strategy.hs b/src/Ideas/Common/Strategy.hs --- a/src/Ideas/Common/Strategy.hs +++ b/src/Ideas/Common/Strategy.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -15,7 +15,6 @@ -- of the underlying modules. -- ----------------------------------------------------------------------------- --- $Id: Strategy.hs 8758 2015-10-22 06:48:52Z bastiaan $ module Ideas.Common.Strategy ( -- * Data types and type classes diff --git a/src/Ideas/Common/Strategy/Abstract.hs b/src/Ideas/Common/Strategy/Abstract.hs --- a/src/Ideas/Common/Strategy/Abstract.hs +++ b/src/Ideas/Common/Strategy/Abstract.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies, RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- Abstract data type for a 'Strategy' and a 'LabeledStrategy'. -- ----------------------------------------------------------------------------- --- $Id: Abstract.hs 8758 2015-10-22 06:48:52Z bastiaan $ module Ideas.Common.Strategy.Abstract ( -- * Strategy data type diff --git a/src/Ideas/Common/Strategy/Choice.hs b/src/Ideas/Common/Strategy/Choice.hs --- a/src/Ideas/Common/Strategy/Choice.hs +++ b/src/Ideas/Common/Strategy/Choice.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,6 @@ -- alternatives. -- ----------------------------------------------------------------------------- --- $Id: Choice.hs 8758 2015-10-22 06:48:52Z bastiaan $ module Ideas.Common.Strategy.Choice ( -- * Choice type class diff --git a/src/Ideas/Common/Strategy/Combinators.hs b/src/Ideas/Common/Strategy/Combinators.hs --- a/src/Ideas/Common/Strategy/Combinators.hs +++ b/src/Ideas/Common/Strategy/Combinators.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,20 +12,19 @@ -- data types -- ----------------------------------------------------------------------------- --- $Id: Combinators.hs 8745 2015-10-15 14:45:46Z bastiaan $ module Ideas.Common.Strategy.Combinators where -import Data.Array import Data.Graph import Data.List ((\\)) +import Data.Maybe import Ideas.Common.CyclicTree hiding (label) import Ideas.Common.Id import Ideas.Common.Rule import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Process import Ideas.Common.Strategy.StrategyTree -import Ideas.Common.Utils (fst3) +import Ideas.Common.Utils (fst3, thd3) import Prelude hiding (not, repeat, fail, sequence) import qualified Ideas.Common.Strategy.Choice as Choice import qualified Ideas.Common.Strategy.Derived as Derived @@ -172,17 +171,19 @@ -- Graph to strategy ---------------------- -type DependencyGraph node key = (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) +type DependencyGraph node key = [(node, key, [key])] -- | Create a strategy from a dependency graph with strategies as nodes -- Does not check for cycles -dependencyGraph:: IsStrategy f => DependencyGraph (f a) key -> Strategy a -dependencyGraph (graph, vertex2data, _) = g2s [] +dependencyGraph:: (IsStrategy f, Ord key) => DependencyGraph (f a) key -> Strategy a +dependencyGraph = make . graphFromEdges + where + make (graph, vertex2data, key2data) = rec [] where - g2s seen - | null reachables = succeed - | otherwise = choice $ map makePath reachables - where - reachables = filter isReachable $ vertices graph \\ seen - isReachable = null . (\\ seen) . (graph!) - makePath vertex = (fst3 . vertex2data) vertex .*. g2s (vertex:seen) + rec seen + | null reachables = succeed + | otherwise = choice $ map makePath reachables + where + reachables = filter isReachable $ vertices graph \\ seen + isReachable = null . (\\ seen) . mapMaybe key2data . thd3 . vertex2data + makePath v = fst3 (vertex2data v) .*. rec (v:seen) diff --git a/src/Ideas/Common/Strategy/Configuration.hs b/src/Ideas/Common/Strategy/Configuration.hs --- a/src/Ideas/Common/Strategy/Configuration.hs +++ b/src/Ideas/Common/Strategy/Configuration.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +13,6 @@ -- are remove/reinsert, collapse/expand, and hide/reveal. -- ----------------------------------------------------------------------------- --- $Id: Configuration.hs 8758 2015-10-22 06:48:52Z bastiaan $ module Ideas.Common.Strategy.Configuration ( StrategyCfg, byName, ConfigAction(..) @@ -22,7 +22,6 @@ ) where import Data.Char -import Data.Monoid import Ideas.Common.Classes import Ideas.Common.CyclicTree hiding (label) import Ideas.Common.Id diff --git a/src/Ideas/Common/Strategy/Derived.hs b/src/Ideas/Common/Strategy/Derived.hs --- a/src/Ideas/Common/Strategy/Derived.hs +++ b/src/Ideas/Common/Strategy/Derived.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,14 +12,13 @@ -- This module defines extra combinators. -- ----------------------------------------------------------------------------- --- $Id: Derived.hs 8747 2015-10-15 14:54:48Z bastiaan $ module Ideas.Common.Strategy.Derived ( -- * General combinators permute, many, many1, replicate, option, try , repeat, repeat1, exhaustive -- * Process-specific combinators - , atomic, (<%>), interleave, concurrent + , atomic, (<%>), interleave , (<@>), (!*>), inits, filterP, hide ) where @@ -56,9 +56,11 @@ -- atomic prefix (!*>) :: AtomicSymbol a => Process a -> Process a -> Process a -a !*> p = split op (atomic a) p +a !*> p = atomicOpen ~> a .*. withMenu op (single atomicClose) p where - op b q = atomic (a .*. b) .*. q + op b q + | b == atomicOpen = q + | otherwise = b ~> atomicClose ~> q filterP :: (a -> Bool) -> Process a -> Process a filterP cond = fold (\a q -> if cond a then a ~> q else empty) done @@ -72,23 +74,28 @@ interleave :: (AtomicSymbol a, LabelSymbol a) => [Process a] -> Process a interleave xs = if null xs then done else foldr1 (<%>) xs +-- interleaving (<%>) :: (AtomicSymbol a, LabelSymbol a) => Process a -> Process a -> Process a -(<%>) = concurrent (not . isEnterSymbol) - -concurrent :: AtomicSymbol a => (a -> Bool) -> Process a -> Process a -> Process a -concurrent switch = normal +p <%> q = + bothAreDone p q .|. ((p %>> q) .|. (q %>> p)) where - normal p q = stepBoth q p .|. (stepRight q p .|. stepRight p q) - - stepBoth = withMenu stop2 . withMenu stop2 done - stop2 _ _ = empty + bothAreDone = withMenu stop2 . withMenu stop2 done + stop2 _ _ = empty - stepRight p = split2 op1 op2 empty +-- left-interleaving +(%>>) :: (AtomicSymbol a, LabelSymbol a) => Process a -> Process a -> Process a +p %>> q = rec (0 :: Int) p + where + rec n = withMenu op empty where - op1 a q2 - | switch a = a ~> normal p q2 - | otherwise = a ~> stepRight p q2 - op2 q1 q2 = q1 .*. normal p q2 + op a = a ~> rest + where + next | a == atomicOpen = n+1 + | a == atomicClose = n-1 + | otherwise = n + rest | isEnterSymbol a = rec next + | next > 0 = rec next + | otherwise = (<%> q) -- | Allows all permutations of the list permute :: (Choice a, Sequence a) => [a] -> a diff --git a/src/Ideas/Common/Strategy/Legacy.hs b/src/Ideas/Common/Strategy/Legacy.hs --- a/src/Ideas/Common/Strategy/Legacy.hs +++ b/src/Ideas/Common/Strategy/Legacy.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,13 +11,12 @@ -- Legacy strategy combinators (before the Functor-Applicative-Monad proposal) -- ----------------------------------------------------------------------------- --- $Id: Legacy.hs 8747 2015-10-15 14:54:48Z bastiaan $ module Ideas.Common.Strategy.Legacy where import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Combinators -import qualified Prelude +import qualified Prelude () infixr 2 <%>, <@> infixr 3 <|> diff --git a/src/Ideas/Common/Strategy/Location.hs b/src/Ideas/Common/Strategy/Location.hs --- a/src/Ideas/Common/Strategy/Location.hs +++ b/src/Ideas/Common/Strategy/Location.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Locations that correspond to the labels in a strategy -- ----------------------------------------------------------------------------- --- $Id: Location.hs 8745 2015-10-15 14:45:46Z bastiaan $ module Ideas.Common.Strategy.Location ( checkLocation, subTaskLocation, nextTaskLocation diff --git a/src/Ideas/Common/Strategy/Prefix.hs b/src/Ideas/Common/Strategy/Prefix.hs --- a/src/Ideas/Common/Strategy/Prefix.hs +++ b/src/Ideas/Common/Strategy/Prefix.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -17,7 +17,6 @@ -- operation. -- ----------------------------------------------------------------------------- --- $Id: Prefix.hs 8745 2015-10-15 14:45:46Z bastiaan $ module Ideas.Common.Strategy.Prefix ( -- * Prefix @@ -32,7 +31,6 @@ import Data.List (intercalate) import Ideas.Common.Classes import Ideas.Common.Environment -import Ideas.Common.Id import Ideas.Common.Rule import Ideas.Common.Strategy.Choice import Ideas.Common.Strategy.Process diff --git a/src/Ideas/Common/Strategy/Process.hs b/src/Ideas/Common/Strategy/Process.hs --- a/src/Ideas/Common/Strategy/Process.hs +++ b/src/Ideas/Common/Strategy/Process.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,6 @@ -- calculus. -- ----------------------------------------------------------------------------- --- $Id: Process.hs 8758 2015-10-22 06:48:52Z bastiaan $ module Ideas.Common.Strategy.Process ( Process, eqProcessBy, menu, withMenu diff --git a/src/Ideas/Common/Strategy/Sequence.hs b/src/Ideas/Common/Strategy/Sequence.hs --- a/src/Ideas/Common/Strategy/Sequence.hs +++ b/src/Ideas/Common/Strategy/Sequence.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,6 @@ -- accessing the firsts set and ready predicate. -- ----------------------------------------------------------------------------- --- $Id: Sequence.hs 8758 2015-10-22 06:48:52Z bastiaan $ module Ideas.Common.Strategy.Sequence ( -- * Sequence type class diff --git a/src/Ideas/Common/Strategy/StrategyTree.hs b/src/Ideas/Common/Strategy/StrategyTree.hs --- a/src/Ideas/Common/Strategy/StrategyTree.hs +++ b/src/Ideas/Common/Strategy/StrategyTree.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,6 @@ -- The nodes in the tree are named strategy combinators. The leafs are rules. -- ----------------------------------------------------------------------------- --- $Id: StrategyTree.hs 8758 2015-10-22 06:48:52Z bastiaan $ module Ideas.Common.Strategy.StrategyTree ( -- * StrategyTree type synonym diff --git a/src/Ideas/Common/Strategy/Symbol.hs b/src/Ideas/Common/Strategy/Symbol.hs --- a/src/Ideas/Common/Strategy/Symbol.hs +++ b/src/Ideas/Common/Strategy/Symbol.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- This module defines special symbols for labeling and atomicity. -- ----------------------------------------------------------------------------- --- $Id: Symbol.hs 8747 2015-10-15 14:54:48Z bastiaan $ module Ideas.Common.Strategy.Symbol ( AtomicSymbol(..), LabelSymbol(..) diff --git a/src/Ideas/Common/Strategy/Traversal.hs b/src/Ideas/Common/Strategy/Traversal.hs --- a/src/Ideas/Common/Strategy/Traversal.hs +++ b/src/Ideas/Common/Strategy/Traversal.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Parameterized traversals based on the strategy language. -- ----------------------------------------------------------------------------- --- $Id: Traversal.hs 8745 2015-10-15 14:45:46Z bastiaan $ module Ideas.Common.Strategy.Traversal ( -- * Parameterized traversals @@ -37,7 +36,7 @@ import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Combinators import Ideas.Common.Traversal.Navigator -import Prelude hiding (repeat, not) +import Prelude hiding (repeat, not, traverse) import qualified Prelude ---------------------------------------------------------------------- diff --git a/src/Ideas/Common/Traversal/Iterator.hs b/src/Ideas/Common/Traversal/Iterator.hs --- a/src/Ideas/Common/Traversal/Iterator.hs +++ b/src/Ideas/Common/Traversal/Iterator.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Iterator.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Traversal.Iterator ( -- * Iterator type class diff --git a/src/Ideas/Common/Traversal/Navigator.hs b/src/Ideas/Common/Traversal/Navigator.hs --- a/src/Ideas/Common/Traversal/Navigator.hs +++ b/src/Ideas/Common/Traversal/Navigator.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Navigator.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Traversal.Navigator ( -- * Location information @@ -36,11 +35,10 @@ import Data.Function import Data.Generics.Str import Data.Maybe -import Ideas.Common.Algebra.Group import Ideas.Common.Traversal.Iterator import Ideas.Common.Traversal.Utils import Ideas.Common.Utils.Uniplate -import Test.QuickCheck hiding (Str) +import Test.QuickCheck --------------------------------------------------------------- -- Navigator type class diff --git a/src/Ideas/Common/Traversal/Tests.hs b/src/Ideas/Common/Traversal/Tests.hs --- a/src/Ideas/Common/Traversal/Tests.hs +++ b/src/Ideas/Common/Traversal/Tests.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Tests.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Traversal.Tests ( testIterator, testNavigator, tests @@ -23,7 +22,7 @@ import Ideas.Common.Traversal.Utils import Ideas.Common.Utils.TestSuite import Ideas.Common.Utils.Uniplate -import Test.QuickCheck +import Test.QuickCheck hiding ((===)) testIterator :: (Show a, Eq a, Iterator a) => String -> Gen a -> TestSuite testIterator s gen = suite (s ++ " Iterator") diff --git a/src/Ideas/Common/Traversal/Utils.hs b/src/Ideas/Common/Traversal/Utils.hs --- a/src/Ideas/Common/Traversal/Utils.hs +++ b/src/Ideas/Common/Traversal/Utils.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Utils.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Traversal.Utils ( -- * Update type class diff --git a/src/Ideas/Common/Utils.hs b/src/Ideas/Common/Utils.hs --- a/src/Ideas/Common/Utils.hs +++ b/src/Ideas/Common/Utils.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- A collection of general utility functions -- ----------------------------------------------------------------------------- --- $Id: Utils.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Utils ( Some(..), ShowString(..), readInt, readM @@ -20,7 +19,7 @@ , cartesian, distinct, allsame , fixpoint , splitAtElem, splitsWithElem - , useFixedStdGen, timedSeconds + , timedSeconds , fst3, snd3, thd3 , headM, findIndexM , elementAt, changeAt, replaceAt @@ -29,17 +28,20 @@ import Data.Char import Data.List -import System.Random +import Data.Typeable import System.Timeout data Some f = forall a . Some (f a) data ShowString = ShowString { fromShowString :: String } - deriving (Eq, Ord) + deriving (Eq, Ord, Typeable) instance Show ShowString where show = fromShowString +instance Read ShowString where + readsPrec n s = [ (ShowString x, y) | (x, y) <- readsPrec n s ] + readInt :: String -> Maybe Int readInt xs | null xs = Nothing @@ -70,12 +72,12 @@ allsame (x:xs) = all (==x) xs fixpoint :: Eq a => (a -> a) -> a -> a -fixpoint f = stop . iterate f +fixpoint f = rec . iterate f where - stop [] = error "Ideas.Common.Utils: empty list" - stop (x:xs) + rec [] = error "Ideas.Common.Utils: empty list" + rec (x:xs) | x == head xs = x - | otherwise = stop xs + | otherwise = rec xs splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a]) splitAtElem c s = @@ -88,11 +90,6 @@ case splitAtElem c s of Just (xs, ys) -> xs : splitsWithElem c ys Nothing -> [s] - --- | Use a fixed standard "random" number generator. This generator is --- accessible by calling System.Random.getStdGen -useFixedStdGen :: IO () -useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -} timedSeconds :: Int -> IO a -> IO a timedSeconds n m = timeout (n * 10^(6 :: Int)) m >>= diff --git a/src/Ideas/Common/Utils/QuickCheck.hs b/src/Ideas/Common/Utils/QuickCheck.hs --- a/src/Ideas/Common/Utils/QuickCheck.hs +++ b/src/Ideas/Common/Utils/QuickCheck.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Extensions to the QuickCheck library -- ----------------------------------------------------------------------------- --- $Id: QuickCheck.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Utils.QuickCheck ( module Test.QuickCheck @@ -26,7 +25,6 @@ import Control.Arrow import Control.Monad -import Data.Monoid import Data.Ratio import Test.QuickCheck diff --git a/src/Ideas/Common/Utils/StringRef.hs b/src/Ideas/Common/Utils/StringRef.hs --- a/src/Ideas/Common/Utils/StringRef.hs +++ b/src/Ideas/Common/Utils/StringRef.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -14,7 +14,6 @@ -- Virutal Machine (LVM) identifiers. -- ----------------------------------------------------------------------------- --- $Id: StringRef.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Utils.StringRef ( StringRef, stringRef, toString, tableStatus @@ -38,6 +37,7 @@ type HashTable = IM.IntMap [String] +{-# NOINLINE tableRef #-} tableRef :: IORef HashTable tableRef = unsafePerformIO (newIORef IM.empty) diff --git a/src/Ideas/Common/Utils/TestSuite.hs b/src/Ideas/Common/Utils/TestSuite.hs --- a/src/Ideas/Common/Utils/TestSuite.hs +++ b/src/Ideas/Common/Utils/TestSuite.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -14,7 +14,6 @@ -- is a monoid. -- ----------------------------------------------------------------------------- --- $Id: TestSuite.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Utils.TestSuite ( -- * TestSuite @@ -47,7 +46,6 @@ import Data.Maybe import Data.Monoid import Data.Time -import Prelude hiding (catch) import System.IO import Test.QuickCheck hiding (Result) import qualified Data.Sequence as S @@ -98,6 +96,8 @@ message "no expected failure" GaveUp {numTests = i} -> warning ("passed only " ++ show i ++ " tests") + InsufficientCoverage {numTests = i} -> + warning ("only performed " ++ show i ++ " tests") assertTrue :: String -> Bool -> TestSuite assertTrue s = assertIO s . return @@ -155,7 +155,6 @@ result <- runner ref chattyIO ts newline ref return result - where runner :: IORef Int -> Bool -> TestSuite -> IO Result runner ref chattyIO = runTS diff --git a/src/Ideas/Common/Utils/Uniplate.hs b/src/Ideas/Common/Utils/Uniplate.hs --- a/src/Ideas/Common/Utils/Uniplate.hs +++ b/src/Ideas/Common/Utils/Uniplate.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- class and its utility plus constructor functions) -- ----------------------------------------------------------------------------- --- $Id: Uniplate.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.Utils.Uniplate ( -- * Uniplate type class and utility functions diff --git a/src/Ideas/Common/View.hs b/src/Ideas/Common/View.hs --- a/src/Ideas/Common/View.hs +++ b/src/Ideas/Common/View.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,6 @@ -- in Interactive Exercise Assistants" -- ----------------------------------------------------------------------------- --- $Id: View.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Common.View ( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..) diff --git a/src/Ideas/Encoding/DecoderJSON.hs b/src/Ideas/Encoding/DecoderJSON.hs --- a/src/Ideas/Encoding/DecoderJSON.hs +++ b/src/Ideas/Encoding/DecoderJSON.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,13 +12,13 @@ -- Services using JSON notation -- ----------------------------------------------------------------------------- --- $Id: DecoderJSON.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Encoding.DecoderJSON ( JSONDecoder, jsonDecoder ) where import Control.Monad +import Data.Char import Data.Maybe import Ideas.Common.Library hiding (exerciseId, symbol) import Ideas.Common.Traversal.Navigator @@ -49,7 +49,7 @@ liftM Left (decodeType t1) `mplus` liftM Right (decodeType t2) Unit -> return () - Const StdGen -> getStdGen + Const QCGen -> getQCGen Const Script -> getScript Const t -> symbol >>= \a -> decodeConst t // a _ -> fail $ "No support for argument type: " ++ show tp @@ -62,6 +62,7 @@ Exercise -> getExercise Environment -> decodeEnvironment Location -> decodeLocation + Term -> decoderFor (return . jsonToTerm) Int -> decoderFor fromJSON Tp.String -> decoderFor fromJSON Id -> decodeId @@ -96,12 +97,12 @@ Array [a] -> setInput a >> decodeState Array (String _code : pref : term : jsonContext : rest) -> do pts <- decodePaths // pref - a <- decodeTerm // term + a <- decodeExpression // term env <- decodeEnvironment // jsonContext let loc = envToLoc env ctx = navigateTowards loc $ deleteRef locRef $ setEnvironment env $ inContext ex a - prfx = replayPaths pts (strategy ex) ctx + prfx = pts (strategy ex) ctx case rest of [] -> return $ makeState ex prfx ctx [Array [String user, String session, String startterm]] -> @@ -119,12 +120,16 @@ locRef :: Ref String locRef = makeRef "location" -decodePaths :: JSONDecoder a [Path] +decodePaths :: JSONDecoder a (LabeledStrategy (Context a) -> Context a -> Prefix (Context a)) decodePaths = decoderFor $ \json -> case json of - String p -> readPaths p + String p + | p ~= "noprefix" -> return (\_ _ -> noPrefix) + | otherwise -> liftM replayPaths (readPaths p) _ -> fail "invalid prefixes" + where + x ~= y = filter isAlphaNum (map toLower x) == y decodeEnvironment :: JSONDecoder a Environment decodeEnvironment = decoderFor $ \json -> @@ -134,17 +139,21 @@ _ -> fail $ "invalid context: " ++ show json where add (k, String s) = return . insertRef (makeRef k) s + add (k, Number n) = return . insertRef (makeRef k) (show n) add _ = fail "invalid item in context" decodeContext :: JSONDecoder a (Context a) decodeContext = do ex <- getExercise - liftM (inContext ex) decodeTerm + liftM (inContext ex) decodeExpression -decodeTerm :: JSONDecoder a a -decodeTerm = do - ex <- getExercise - decoderFor $ \json -> +decodeExpression :: JSONDecoder a a +decodeExpression = withJSONTerm $ \b -> getExercise >>= decoderFor . f b + where + f True ex json = + let Just v = hasTermView ex + in matchM v (jsonToTerm json) + f False ex json = case json of String s -> either fail return (parser ex s) - _ -> fail "Expecting a string when reading a term" + _ -> fail "Expecting a string when reading a term" diff --git a/src/Ideas/Encoding/DecoderXML.hs b/src/Ideas/Encoding/DecoderXML.hs --- a/src/Ideas/Encoding/DecoderXML.hs +++ b/src/Ideas/Encoding/DecoderXML.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- --- $Id: DecoderXML.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Encoding.DecoderXML ( XMLDecoder, xmlDecoder @@ -59,9 +58,10 @@ Context -> decodeContext Rule -> decodeRule Environment -> decodeArgEnvironment + Term -> decoderFor (fromXML >=> fromOMOBJ) Location -> decodeLocation StratCfg -> decodeConfiguration - StdGen -> getStdGen + QCGen -> getQCGen Script -> getScript Exercise -> getExercise Id -> -- improve! @@ -106,7 +106,7 @@ decodeContext :: XMLDecoder a (Context a) decodeContext = do ex <- getExercise - expr <- decodeTerm + expr <- decodeExpression env <- decodeEnvironment let ctx = setEnvironment env (inContext ex expr) locRef = makeRef "location" @@ -117,8 +117,8 @@ Nothing -> return ctx -decodeTerm :: XMLDecoder a a -decodeTerm = withOpenMath f +decodeExpression :: XMLDecoder a a +decodeExpression = withOpenMath f where f True = decodeOMOBJ f False = decodeChild "expr" $ do diff --git a/src/Ideas/Encoding/Encoder.hs b/src/Ideas/Encoding/Encoder.hs --- a/src/Ideas/Encoding/Encoder.hs +++ b/src/Ideas/Encoding/Encoder.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,13 +10,14 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Encoder.hs 8747 2015-10-15 14:54:48Z bastiaan $ module Ideas.Encoding.Encoder ( -- * Converter type class Converter(..) - , getExercise, getStdGen, getScript, getRequest - , withExercise, withOpenMath, (//) + , getExercise, getQCGen, getScript, getRequest + , withExercise, withOpenMath, withJSONTerm, (//) + -- * JSON terms + , termToJSON, jsonToTerm, jsonTermView -- * Options , Options, simpleOptions, makeOptions -- * Encoder datatype @@ -28,23 +29,25 @@ , makeDecoder, decoderFor , split, symbol, setInput -- re-export - , module Data.Monoid, module Control.Applicative - , module Control.Arrow + , module Export ) where -import Control.Applicative hiding (Const) -import Control.Arrow +import Control.Applicative as Export hiding (Const) +import Control.Arrow as Export import Control.Monad -import Data.Monoid +import Data.Monoid as Export 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.JSON hiding (String) import Ideas.Text.XML -import System.Random (newStdGen, mkStdGen, StdGen) +import Test.QuickCheck.Random import qualified Control.Category as C +import qualified Ideas.Common.Rewriting.Term as Term +import qualified Ideas.Text.JSON as JSON ------------------------------------------------------------------- -- Converter type class @@ -56,8 +59,8 @@ getExercise :: Converter f => f a s (Exercise a) getExercise = fromOptions exercise -getStdGen :: Converter f => f a s StdGen -getStdGen = fromOptions stdGen +getQCGen :: Converter f => f a s QCGen +getQCGen = fromOptions qcGen getScript :: Converter f => f a s Script getScript = fromOptions script @@ -71,25 +74,76 @@ withOpenMath :: (Converter f, Monad (f a s)) => (Bool -> f a s t) -> f a s t withOpenMath = (liftM useOpenMath getRequest >>=) +withJSONTerm :: (Converter f, Monad (f a s)) => (Bool -> f a s t) -> f a s t +withJSONTerm = (liftM useJSONTerm 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 ------------------------------------------------------------------- +-- JSON terms + +termToJSON :: Term -> JSON +termToJSON term = + case term of + TVar s -> JSON.String s + TCon s [] + | s == trueSymbol -> Boolean True + | s == falseSymbol -> Boolean False + | s == nullSymbol -> Null + TCon s ts + | s == objectSymbol -> Object (f ts) + | otherwise -> Object [("_apply", Array (JSON.String (show s):map termToJSON ts))] + TList xs -> Array (map termToJSON xs) + TNum n -> Number (I n) + TFloat d -> Number (D d) + TMeta n -> Object [("_meta", Number (I (toInteger n)))] + where + f [] = [] + f (TVar s:x:xs) = (s, termToJSON x) : f xs + f _ = error "termToJSON" + +jsonToTerm :: JSON -> Term +jsonToTerm json = + case json of + Number (I n) -> TNum n + Number (D d) -> TFloat d + JSON.String s -> TVar s + Boolean b -> Term.symbol (if b then trueSymbol else falseSymbol) + Array xs -> TList (map jsonToTerm xs) + Object [("_meta", Number (I n))] -> TMeta (fromInteger n) + Object [("_apply", Array (JSON.String s:xs))] -> TCon (newSymbol s) (map jsonToTerm xs) + Object xs -> TCon objectSymbol (concatMap f xs) + Null -> Term.symbol nullSymbol + where + f (s, x) = [TVar s, jsonToTerm x] + +jsonTermView :: InJSON a => View Term a +jsonTermView = makeView (fromJSON . termToJSON) (jsonToTerm . toJSON) + +trueSymbol, falseSymbol, nullSymbol, objectSymbol :: Symbol +trueSymbol = newSymbol "true" +falseSymbol = newSymbol "false" +nullSymbol = newSymbol "null" +objectSymbol = newSymbol "object" + +------------------------------------------------------------------- -- Options data Options a = Options { exercise :: Exercise a -- the current exercise , request :: Request -- meta-information about the request - , stdGen :: StdGen -- random number generator + , qcGen :: QCGen -- 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 + gen = mkQCGen 0 + in Options ex req gen mempty makeOptions :: DomainReasoner -> Request -> IO (Some Options) makeOptions dr req = do @@ -103,11 +157,11 @@ Nothing | getId ex == mempty -> return mempty | otherwise -> defaultScript dr (getId ex) - stdgen <- newStdGen + gen <- maybe newQCGen (return . mkQCGen) (randomSeed req) return $ Some Options { exercise = ex , request = req - , stdGen = stdgen + , qcGen = gen , script = scr } @@ -134,7 +188,7 @@ return a = Enc $ \_ _ -> return a fail s = Enc $ \_ _ -> fail s p >>= f = Enc $ \xs s -> do - (a) <- runEnc p xs s + a <- runEnc p xs s runEnc (f a) xs s instance MonadPlus (Encoder a s) where diff --git a/src/Ideas/Encoding/EncoderHTML.hs b/src/Ideas/Encoding/EncoderHTML.hs --- a/src/Ideas/Encoding/EncoderHTML.hs +++ b/src/Ideas/Encoding/EncoderHTML.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- Encoding in HTML -- ----------------------------------------------------------------------------- --- $Id: EncoderHTML.hs 8745 2015-10-15 14:45:46Z bastiaan $ module Ideas.Encoding.EncoderHTML (htmlEncoder, htmlEncoderAt) where @@ -104,6 +103,7 @@ State -> exerciseHeader lm <> (encodeState lm dr // val) Location -> text val Environment -> text val + Term -> text val Context -> encodeContext // val String -> string val Result -> exerciseHeader lm <> encodeResult lm val diff --git a/src/Ideas/Encoding/EncoderJSON.hs b/src/Ideas/Encoding/EncoderJSON.hs --- a/src/Ideas/Encoding/EncoderJSON.hs +++ b/src/Ideas/Encoding/EncoderJSON.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,14 +12,13 @@ -- Services using JSON notation -- ----------------------------------------------------------------------------- --- $Id: EncoderJSON.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Encoding.EncoderJSON (jsonEncoder) where import Data.Maybe import Ideas.Common.Library hiding (exerciseId) import Ideas.Common.Utils (Some(..), distinct) -import Ideas.Encoding.Encoder +import Ideas.Encoding.Encoder hiding (symbol) import Ideas.Service.State import Ideas.Service.Types hiding (String) import Ideas.Text.JSON @@ -77,6 +76,7 @@ Context -> encodeContext // val Location -> pure (toJSON (show val)) Environment -> encodeEnvironment // val + Term -> pure (termToJSON val) Text -> pure (toJSON (show val)) Int -> pure (toJSON val) Bool -> pure (toJSON val) @@ -92,8 +92,14 @@ in Array [ f a | a <- bindings env ] encodeContext :: JSONEncoder a (Context a) -encodeContext = exerciseEncoder $ \ex ctx -> - String $ prettyPrinterContext ex ctx +encodeContext = withJSONTerm (exerciseEncoder . f) + where + f True ex ctx = fromMaybe Null $ do + v <- hasTermView ex + a <- fromContext ctx + return (termToJSON (build v a)) + f False ex ctx = + String $ prettyPrinterContext ex ctx encodeState :: JSONEncoder a (State a) encodeState = encoderFor $ \st -> @@ -102,7 +108,7 @@ make pp env = Array $ [ String $ showId (exercise st) , String $ if withoutPrefix st - then "NoPrefix" + then "no prefix" else show (statePrefix st) , pp , env diff --git a/src/Ideas/Encoding/EncoderXML.hs b/src/Ideas/Encoding/EncoderXML.hs --- a/src/Ideas/Encoding/EncoderXML.hs +++ b/src/Ideas/Encoding/EncoderXML.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- --- $Id: EncoderXML.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Encoding.EncoderXML ( XMLEncoder @@ -59,7 +58,7 @@ Tag "RulesInfo" _ -> withExercise $ \ex -> withOpenMath $ \useOM -> - pure (rulesInfoXML ex (buildTerm useOM ex)) + pure (rulesInfoXML ex (buildExpression useOM ex)) Tag "elem" t -> tag "elem" (xmlEncoder // (val ::: t)) -- special cases for lists @@ -90,6 +89,7 @@ Context -> encodeContext // val Location -> encodeLocation // val Environment -> encodeEnvironment // val + Term -> builder (toXML (toOMOBJ val)) Text -> encodeText // val Bool -> string (showBool val) _ -> text tv @@ -104,7 +104,7 @@ encodeContext :: XMLEncoder a (Context a) encodeContext = withOpenMath $ \useOM -> exerciseEncoder $ \ex ctx -> - maybe (error "encodeContext") (buildTerm useOM ex) (fromContext ctx) + maybe (error "encodeContext") (buildExpression useOM ex) (fromContext ctx) <> let values = bindings (withLoc ctx) loc = fromLocation (location ctx) @@ -122,8 +122,8 @@ | tb <- values ] -buildTerm :: BuildXML b => Bool -> Exercise a -> a -> b -buildTerm useOM ex +buildExpression :: BuildXML b => Bool -> Exercise a -> a -> b +buildExpression useOM ex | useOM = either msg (builder . toXML) . toOpenMath ex | otherwise = tag "expr" . string . prettyPrinter ex where @@ -177,7 +177,7 @@ TextTerm a -> fromMaybe (text item) $ do v <- hasTermView ex b <- match v a - return (buildTerm useOM ex b) + return (buildExpression useOM ex b) _ -> text item encodeMessage :: XMLEncoder a FeedbackText.Message diff --git a/src/Ideas/Encoding/Evaluator.hs b/src/Ideas/Encoding/Evaluator.hs --- a/src/Ideas/Encoding/Evaluator.hs +++ b/src/Ideas/Encoding/Evaluator.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Evaluator.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Encoding.Evaluator (Evaluator(..), evalService) where diff --git a/src/Ideas/Encoding/LinkManager.hs b/src/Ideas/Encoding/LinkManager.hs --- a/src/Ideas/Encoding/LinkManager.hs +++ b/src/Ideas/Encoding/LinkManager.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- Manages links to information -- ----------------------------------------------------------------------------- --- $Id: LinkManager.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Encoding.LinkManager ( LinkManager(..) diff --git a/src/Ideas/Encoding/ModeJSON.hs b/src/Ideas/Encoding/ModeJSON.hs --- a/src/Ideas/Encoding/ModeJSON.hs +++ b/src/Ideas/Encoding/ModeJSON.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,12 +11,12 @@ -- Services using JSON notation -- ----------------------------------------------------------------------------- --- $Id: ModeJSON.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Encoding.ModeJSON (processJSON) where import Control.Monad import Data.Char +import Data.Maybe import Ideas.Common.Library hiding (exerciseId) import Ideas.Common.Utils (Some(..), timedSeconds) import Ideas.Encoding.DecoderJSON @@ -67,6 +67,7 @@ srv <- stringOption "method" json newId src <- stringOption "source" json id rinf <- stringOption "requestinfo" json id + seed <- stringOptionM "randomseed" json (defaultSeed cgiBin) (return . readM) enc <- stringOptionM "encoding" json [] readEncoding sch <- stringOptionM "logging" json Nothing (liftM Just . readSchema) return emptyRequest @@ -76,9 +77,16 @@ , cgiBinary = cgiBin , requestInfo = rinf , logSchema = sch + , randomSeed = seed , dataformat = JSON , encoding = enc } + +-- Use a fixed seed for random number generation for command-line invocations +defaultSeed :: Maybe String -> Maybe Int +defaultSeed cgiBin + | isJust cgiBin = Nothing + | otherwise = Just 2805 -- magic number stringOption :: Monad m => String -> JSON -> (String -> a) -> m (Maybe a) stringOption attr json f = stringOptionM attr json Nothing (return . Just . f) diff --git a/src/Ideas/Encoding/ModeXML.hs b/src/Ideas/Encoding/ModeXML.hs --- a/src/Ideas/Encoding/ModeXML.hs +++ b/src/Ideas/Encoding/ModeXML.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,13 +11,11 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- --- $Id: ModeXML.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Encoding.ModeXML (processXML) where import Control.Exception import Control.Monad -import Data.Maybe import Ideas.Common.Library hiding (exerciseId, (:=)) import Ideas.Common.Utils (Some(..), timedSeconds) import Ideas.Encoding.DecoderXML @@ -30,8 +28,7 @@ import Ideas.Service.Request import Ideas.Text.HTML import Ideas.Text.XML -import Prelude hiding (catch) -import System.IO.Error hiding (catch) +import System.IO.Error processXML :: Maybe Int -> Maybe String -> DomainReasoner -> LogRef -> String -> IO (Request, String, String) processXML maxTime cgiBin dr logRef input = do @@ -62,16 +59,23 @@ Just s -> readEncoding s Nothing -> return [] return emptyRequest - { serviceId = fmap newId $ findAttribute "service" xml + { serviceId = newId <$> findAttribute "service" xml , exerciseId = extractExerciseId xml , source = findAttribute "source" xml , cgiBinary = cgiBin , requestInfo = findAttribute "requestinfo" xml , logSchema = findAttribute "logging" xml >>= readSchema , feedbackScript = findAttribute "script" xml + , randomSeed = defaultSeed cgiBin $ + findAttribute "randomseed" xml >>= readM , dataformat = XML , encoding = enc } + +-- Use a fixed seed for random number generation for command-line invocations +defaultSeed :: Maybe String -> Maybe Int -> Maybe Int +defaultSeed Nothing Nothing = Just 2805 -- magic number +defaultSeed _ m = m xmlReply :: DomainReasoner -> LogRef -> Request -> XML -> IO XML xmlReply dr logRef request xml = do diff --git a/src/Ideas/Encoding/OpenMathSupport.hs b/src/Ideas/Encoding/OpenMathSupport.hs --- a/src/Ideas/Encoding/OpenMathSupport.hs +++ b/src/Ideas/Encoding/OpenMathSupport.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: OpenMathSupport.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Encoding.OpenMathSupport ( -- * Conversion functions to/from OpenMath diff --git a/src/Ideas/Encoding/RulePresenter.hs b/src/Ideas/Encoding/RulePresenter.hs --- a/src/Ideas/Encoding/RulePresenter.hs +++ b/src/Ideas/Encoding/RulePresenter.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: RulePresenter.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Encoding.RulePresenter (ruleToHTML) where diff --git a/src/Ideas/Encoding/RulesInfo.hs b/src/Ideas/Encoding/RulesInfo.hs --- a/src/Ideas/Encoding/RulesInfo.hs +++ b/src/Ideas/Encoding/RulesInfo.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: RulesInfo.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Encoding.RulesInfo ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap diff --git a/src/Ideas/Encoding/StrategyInfo.hs b/src/Ideas/Encoding/StrategyInfo.hs --- a/src/Ideas/Encoding/StrategyInfo.hs +++ b/src/Ideas/Encoding/StrategyInfo.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Converting a strategy to XML, and the other way around. -- ----------------------------------------------------------------------------- --- $Id: StrategyInfo.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Encoding.StrategyInfo (strategyToXML) where diff --git a/src/Ideas/Main/BlackBoxTests.hs b/src/Ideas/Main/BlackBoxTests.hs --- a/src/Ideas/Main/BlackBoxTests.hs +++ b/src/Ideas/Main/BlackBoxTests.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,14 +9,13 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: BlackBoxTests.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Main.BlackBoxTests (blackBoxTests) where import Control.Monad import Data.Char import Data.List -import Ideas.Common.Utils (useFixedStdGen, snd3) +import Ideas.Common.Utils (snd3) import Ideas.Common.Utils.TestSuite import Ideas.Encoding.ModeJSON import Ideas.Encoding.ModeXML @@ -51,7 +50,6 @@ doBlackBoxTest dr format path = assertMessageIO (stripDirectoryPart path) $ do -- Comparing output with expected output - useFixedStdGen -- fix the random number generator withFile path ReadMode $ \h1 -> do hSetBinaryMode h1 True txt <- hGetContents h1 diff --git a/src/Ideas/Main/Default.hs b/src/Ideas/Main/Default.hs --- a/src/Ideas/Main/Default.hs +++ b/src/Ideas/Main/Default.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Main module for feedback services -- ----------------------------------------------------------------------------- --- $Id: Default.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Main.Default ( defaultMain, defaultCGI @@ -23,7 +22,7 @@ import Control.Exception import Control.Monad import Data.Maybe -import Ideas.Common.Utils (useFixedStdGen, Some(..)) +import Ideas.Common.Utils (Some(..)) import Ideas.Common.Utils.TestSuite import Ideas.Encoding.ModeJSON (processJSON) import Ideas.Encoding.ModeXML (processXML) @@ -36,7 +35,6 @@ import Ideas.Service.ServiceList import Ideas.Service.Types (Service) import Network.CGI -import Prelude hiding (catch) import System.IO import System.IO.Error (ioeGetErrorString) import qualified Ideas.Main.Logging as Log @@ -102,7 +100,6 @@ defaultCommandLine :: DomainReasoner -> [Flag] -> IO () defaultCommandLine dr flags = do hSetBinaryMode stdout True - useFixedStdGen -- always use a predictable "random" number generator mapM_ doAction flags where doAction flag = diff --git a/src/Ideas/Main/Documentation.hs b/src/Ideas/Main/Documentation.hs --- a/src/Ideas/Main/Documentation.hs +++ b/src/Ideas/Main/Documentation.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Manages links to information -- ----------------------------------------------------------------------------- --- $Id: Documentation.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Main.Documentation (makeDocumentation) where diff --git a/src/Ideas/Main/Logging.hs b/src/Ideas/Main/Logging.hs --- a/src/Ideas/Main/Logging.hs +++ b/src/Ideas/Main/Logging.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, FlexibleContexts #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- Facilities to create a log database -- ----------------------------------------------------------------------------- --- $Id: Logging.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Main.Logging ( Record(..), addRequest, addState diff --git a/src/Ideas/Main/Options.hs b/src/Ideas/Main/Options.hs --- a/src/Ideas/Main/Options.hs +++ b/src/Ideas/Main/Options.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Options and command-line flags for services -- ----------------------------------------------------------------------------- --- $Id: Options.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Main.Options ( Flag(..), getFlags @@ -35,14 +34,14 @@ header :: String header = "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++ - "Copyright 2015, Open Universiteit Nederland\n" ++ + "Copyright 2016, Open Universiteit Nederland\n" ++ versionText ++ "\n\nUsage: ideas [OPTION] (by default, CGI protocol)\n" ++ "\nOptions:" versionText :: String versionText = - "version " ++ ideasVersion ++ ", revision " ++ show ideasRevision ++ + "version " ++ ideasVersion ++ ", revision " ++ ideasRevision ++ ", logging " ++ (if logEnabled then "enabled" else "disabled") helpText :: String @@ -50,10 +49,10 @@ fullVersion :: String fullVersion = "version " ++ ideasVersion ++ " (revision " - ++ show ideasRevision ++ ", " ++ ideasLastChanged ++ ")" + ++ ideasRevision ++ ", " ++ ideasLastChanged ++ ")" shortVersion :: String -shortVersion = ideasVersion ++ " (" ++ show ideasRevision ++ ")" +shortVersion = ideasVersion ++ " (" ++ ideasRevision ++ ")" options :: [OptDescr Flag] options = diff --git a/src/Ideas/Main/Revision.hs b/src/Ideas/Main/Revision.hs --- a/src/Ideas/Main/Revision.hs +++ b/src/Ideas/Main/Revision.hs @@ -2,10 +2,10 @@ module Ideas.Main.Revision where ideasVersion :: String -ideasVersion = "1.4" +ideasVersion = "1.5" -ideasRevision :: Int -ideasRevision = 8775 +ideasRevision :: String +ideasRevision = "cfe6d70796113f07095f803981e1d2cc222d4b8e" ideasLastChanged :: String -ideasLastChanged = "vr, 23 okt 2015" +ideasLastChanged = "Thu May 26 20:50:01 2016 +0200" diff --git a/src/Ideas/Service/BasicServices.hs b/src/Ideas/Service/BasicServices.hs --- a/src/Ideas/Service/BasicServices.hs +++ b/src/Ideas/Service/BasicServices.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: BasicServices.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Service.BasicServices ( -- * Basic Services @@ -26,24 +25,24 @@ import Ideas.Common.Utils (fst3) import Ideas.Service.State import Ideas.Service.Types -import System.Random +import Test.QuickCheck.Random import qualified Ideas.Common.Classes as Apply import qualified Ideas.Common.Library as Library -generate :: StdGen -> Exercise a -> Maybe Difficulty -> Maybe String -> IO (State a) +generate :: QCGen -> Exercise a -> Maybe Difficulty -> Maybe String -> Either String (State a) generate rng ex md userId = case randomTerm rng ex md of - Just a -> startState ex userId a - Nothing -> fail "No random term" + Just a -> Right $ startState rng ex userId a + Nothing -> Left "No random term" -create :: Exercise a -> String -> Maybe String -> IO (State a) -create ex input userId = +create :: QCGen -> Exercise a -> String -> Maybe String -> Either String (State a) +create rng ex input userId = case parser ex input of Left err -> fail err Right a - | evalPredicate (Library.ready ex) a -> fail "Is ready" - | evalPredicate (Library.suitable ex) a -> startState ex userId a - | otherwise -> fail "Not suitable" + | evalPredicate (Library.ready ex) a -> Left "Is ready" + | evalPredicate (Library.suitable ex) a -> Right $ startState rng ex userId a + | otherwise -> Left "Not suitable" -- TODO: add a location to each step solution :: Maybe StrategyCfg -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a)) diff --git a/src/Ideas/Service/Diagnose.hs b/src/Ideas/Service/Diagnose.hs --- a/src/Ideas/Service/Diagnose.hs +++ b/src/Ideas/Service/Diagnose.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- Diagnose a term submitted by a student -- ----------------------------------------------------------------------------- --- $Id: Diagnose.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Service.Diagnose ( Diagnosis(..), tDiagnosis, diagnose diff --git a/src/Ideas/Service/DomainReasoner.hs b/src/Ideas/Service/DomainReasoner.hs --- a/src/Ideas/Service/DomainReasoner.hs +++ b/src/Ideas/Service/DomainReasoner.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: DomainReasoner.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Service.DomainReasoner ( DomainReasoner(..), tDomainReasoner, newDomainReasoner diff --git a/src/Ideas/Service/FeedbackScript/Analysis.hs b/src/Ideas/Service/FeedbackScript/Analysis.hs --- a/src/Ideas/Service/FeedbackScript/Analysis.hs +++ b/src/Ideas/Service/FeedbackScript/Analysis.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Analysis of a feedbackscript -- ----------------------------------------------------------------------------- --- $Id: Analysis.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Service.FeedbackScript.Analysis ( -- Analysis functions diff --git a/src/Ideas/Service/FeedbackScript/Parser.hs b/src/Ideas/Service/FeedbackScript/Parser.hs --- a/src/Ideas/Service/FeedbackScript/Parser.hs +++ b/src/Ideas/Service/FeedbackScript/Parser.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Simple parser for feedback scripts -- ----------------------------------------------------------------------------- --- $Id: Parser.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Service.FeedbackScript.Parser ( parseScript, parseScriptSafe, Script @@ -25,7 +24,6 @@ import Ideas.Common.Id import Ideas.Service.FeedbackScript.Syntax import Ideas.Text.Parsing -import Prelude hiding (catch) import System.Directory import System.FilePath diff --git a/src/Ideas/Service/FeedbackScript/Run.hs b/src/Ideas/Service/FeedbackScript/Run.hs --- a/src/Ideas/Service/FeedbackScript/Run.hs +++ b/src/Ideas/Service/FeedbackScript/Run.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Run a feedbackscript -- ----------------------------------------------------------------------------- --- $Id: Run.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Service.FeedbackScript.Run ( Script @@ -24,7 +23,6 @@ import Control.Monad import Data.List import Data.Maybe -import Data.Monoid import Ideas.Common.Library hiding (ready, Environment) import Ideas.Service.BasicServices import Ideas.Service.Diagnose diff --git a/src/Ideas/Service/FeedbackScript/Syntax.hs b/src/Ideas/Service/FeedbackScript/Syntax.hs --- a/src/Ideas/Service/FeedbackScript/Syntax.hs +++ b/src/Ideas/Service/FeedbackScript/Syntax.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Abstract syntax for feedback scripts, and pretty-printer (Show instance) -- ----------------------------------------------------------------------------- --- $Id: Syntax.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Service.FeedbackScript.Syntax ( Script, makeScript, scriptDecls, makeText, textItems @@ -22,7 +21,6 @@ import Data.Char import Data.List import Data.Maybe -import Data.Monoid import Ideas.Common.Library import Ideas.Common.Utils.Uniplate diff --git a/src/Ideas/Service/FeedbackText.hs b/src/Ideas/Service/FeedbackText.hs --- a/src/Ideas/Service/FeedbackText.hs +++ b/src/Ideas/Service/FeedbackText.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: FeedbackText.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Service.FeedbackText ( Message, tMessage, accept, text diff --git a/src/Ideas/Service/ProblemDecomposition.hs b/src/Ideas/Service/ProblemDecomposition.hs --- a/src/Ideas/Service/ProblemDecomposition.hs +++ b/src/Ideas/Service/ProblemDecomposition.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: ProblemDecomposition.hs 8745 2015-10-15 14:45:46Z bastiaan $ module Ideas.Service.ProblemDecomposition ( problemDecomposition, Reply(..), Answer, tAnswer, tReply diff --git a/src/Ideas/Service/Request.hs b/src/Ideas/Service/Request.hs --- a/src/Ideas/Service/Request.hs +++ b/src/Ideas/Service/Request.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Request.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Service.Request where @@ -27,13 +26,14 @@ , requestInfo :: Maybe String , cgiBinary :: Maybe String , logSchema :: Maybe Schema + , randomSeed :: Maybe Int , dataformat :: DataFormat , encoding :: [Encoding] } emptyRequest :: Request emptyRequest = Request Nothing Nothing Nothing Nothing - Nothing Nothing Nothing XML [] + Nothing Nothing Nothing Nothing XML [] data Schema = V1 | V2 | NoLogging deriving (Show, Eq) @@ -57,6 +57,7 @@ | EncString -- encode terms as strings | EncCompact -- compact ouput | EncPretty -- pretty output + | EncJSON -- encode terms in JSON deriving Eq instance Show Encoding where @@ -66,6 +67,7 @@ show EncString = "string" show EncCompact = "compact" show EncPretty = "pretty" + show EncJSON = "json" htmlOutput :: Request -> Bool htmlOutput = (EncHTML `elem`) . encoding @@ -80,8 +82,17 @@ xs = encoding req useOpenMath :: Request -> Bool -useOpenMath r = all (`notElem` encoding r) [EncString, EncHTML] +useOpenMath r = + case dataformat r of + JSON -> False + XML -> all (`notElem` encoding r) [EncString, EncHTML] +useJSONTerm :: Request -> Bool +useJSONTerm r = + case dataformat r of + JSON -> EncJSON `elem` encoding r + XML -> False + useLogging :: Request -> Bool useLogging = (EncHTML `notElem`) . encoding @@ -100,4 +111,5 @@ f "string" = return EncString f "compact" = return EncCompact f "pretty" = return EncPretty + f "json" = return EncJSON f s = fail $ "Invalid encoding: " ++ s diff --git a/src/Ideas/Service/ServiceList.hs b/src/Ideas/Service/ServiceList.hs --- a/src/Ideas/Service/ServiceList.hs +++ b/src/Ideas/Service/ServiceList.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: ServiceList.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Service.ServiceList (serviceList, metaServiceList) where @@ -140,13 +139,13 @@ 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 ::: tStdGen .-> tExercise .-> tMaybe tDifficulty .-> tMaybe tUserId .-> tIO tState + generate ::: tQCGen .-> tExercise .-> tMaybe tDifficulty .-> tMaybe tUserId .-> tError tState createS :: Service createS = makeService "basic.create" "Given an expression, this service \ \returns an initial state with the original given expression." $ - create ::: tExercise .-> tString .-> tMaybe tUserId .-> tIO tState + create ::: tQCGen .-> tExercise .-> tString .-> tMaybe tUserId .-> tError tState examplesS :: Service examplesS = makeService "basic.examples" @@ -162,12 +161,12 @@ \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 .-> tMaybe tUserId .-> tIO tState + f ::: tQCGen .-> tExercise .-> tInt .-> tMaybe tUserId .-> tError tState where - f ex nr userId = + f rng ex nr userId = case drop nr (examples ex) of - [] -> fail "No such example" - (_,a):_ -> startState ex userId a + [] -> Left "No such example" + (_,a):_ -> Right $ startState rng ex userId a findbuggyrulesS :: Service findbuggyrulesS = makeService "basic.findbuggyrules" @@ -321,7 +320,7 @@ testreportS :: Service testreportS = makeService "meta.testreport" "Show test report for an exercise." $ - (\stdgen -> runTestSuiteResult False . exerciseTestSuite stdgen) ::: tStdGen .-> tExercise .-> tIO tTestSuiteResult + (\qcgen -> runTestSuiteResult False . exerciseTestSuite qcgen) ::: tQCGen .-> tExercise .-> tIO tTestSuiteResult logS :: Service logS = makeService "meta.log" diff --git a/src/Ideas/Service/State.hs b/src/Ideas/Service/State.hs --- a/src/Ideas/Service/State.hs +++ b/src/Ideas/Service/State.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +13,6 @@ -- derivation. -- ----------------------------------------------------------------------------- --- $Id: State.hs 8745 2015-10-15 14:45:46Z bastiaan $ module Ideas.Service.State ( -- * Exercise state @@ -23,7 +22,6 @@ , withoutPrefix, stateLabels, suitable, finished, firsts, microsteps ) where -import Control.Monad import Data.Char import Data.List import Data.Maybe @@ -32,6 +30,7 @@ import Ideas.Common.Strategy.Sequence import Ideas.Common.Strategy.Symbol import System.Random +import Test.QuickCheck.Random data State a = State { exercise :: Exercise a @@ -97,14 +96,15 @@ emptyState :: Exercise a -> a -> State a emptyState ex = emptyStateContext ex . inContext ex -startState :: Exercise a -> Maybe String -> a -> IO (State a) -startState ex userId a = do - sid <- newSessionId - return (emptyStateContext ex (inContext ex a)) - { stateUser = userId - , stateSession = Just sid - , stateStartTerm = Just (prettyPrinter ex a) - } +startState :: QCGen -> Exercise a -> Maybe String -> a -> State a +startState gen ex userId a = st + { stateUser = userId + , stateSession = Just sid + , stateStartTerm = Just (prettyPrinter ex a) + } + where + st = emptyStateContext ex (inContext ex a) + sid = newSessionId gen -- Restart the strategy: make sure that the new state has a prefix -- When resetting the prefix, also make sure that the context is refreshed @@ -137,10 +137,8 @@ in nub (mapMaybe isEnterRule xs) \\ mapMaybe isExitRule xs -- | Produces a 80 bit random number, represented as 20 hexadecimal digits -newSessionId :: IO String -newSessionId = replicateM 20 $ do - n <- randomRIO (0 :: Int, 15) - return (hex n) +newSessionId :: QCGen -> String +newSessionId = map hex . take 20 . randomRs (0 :: Int, 15) where hex :: Int -> Char hex n | n < 10 = chr (n+48) diff --git a/src/Ideas/Service/Submit.hs b/src/Ideas/Service/Submit.hs --- a/src/Ideas/Service/Submit.hs +++ b/src/Ideas/Service/Submit.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- Diagnose a term submitted by a student. Deprecated (see diagnose service). -- ----------------------------------------------------------------------------- --- $Id: Submit.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Service.Submit ( submit, Result(..), tResult diff --git a/src/Ideas/Service/Types.hs b/src/Ideas/Service/Types.hs --- a/src/Ideas/Service/Types.hs +++ b/src/Ideas/Service/Types.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, FlexibleContexts #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Types.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Service.Types ( -- * Services @@ -21,9 +20,9 @@ , Equal(..), ShowF(..), equalM -- * Constructing types , tEnvironment, tLocation, tRule, tUnit, tTuple3, tTuple4, tTuple5, tPair - , tStrategy, tTree, tState, tBool, tMaybe, tString, tList + , tTerm, tStrategy, tTree, tState, tBool, tMaybe, tString, tList , tId, tService, tSomeExercise, tText, tDifficulty, tUserId ,tContext - , tDerivation, tError, (.->), tIO, tExercise, tTestSuiteResult, tStdGen + , tDerivation, tError, (.->), tIO, tExercise, tTestSuiteResult, tQCGen , tScript, tExamples, tStrategyCfg, tInt -- * Searching a typed value , findValuesOfType @@ -38,7 +37,7 @@ import Ideas.Common.Utils import Ideas.Service.FeedbackScript.Syntax import Ideas.Service.State -import System.Random +import Test.QuickCheck.Random (QCGen) import qualified Ideas.Common.Utils.TestSuite as TestSuite ----------------------------------------------------------------------------- @@ -98,9 +97,10 @@ equal Script Script = Just id equal StratCfg StratCfg = Just id equal Environment Environment = Just id + equal Term Term = Just id equal SomeExercise SomeExercise = Just id equal Text Text = Just id - equal StdGen StdGen = Just id + equal QCGen QCGen = Just id equal Result Result = Just id equal _ _ = Nothing @@ -148,8 +148,9 @@ Script :: Const a Script StratCfg :: Const a StrategyCfg Environment :: Const a Environment + Term :: Const a Term Text :: Const a Text - StdGen :: Const a StdGen + QCGen :: Const a QCGen Result :: Const a TestSuite.Result SomeExercise :: Const a (Some Exercise) -- basic types @@ -206,8 +207,9 @@ Script -> show val StratCfg -> show val Environment -> show val + Term -> show val Text -> show val - StdGen -> show val + QCGen -> show val Result -> show val Bool -> map toLower (show val) Int -> show val @@ -228,8 +230,9 @@ showF Script = "Script" showF StratCfg = "StrategyConfiguration" showF Environment = "Environment" + showF Term = "Term" showF Text = "TextMessage" - showF StdGen = "StdGen" + showF QCGen = "QCGen" showF Result = "TestSuiteResult" showF SomeExercise = "Exercise" showF Bool = "Bool" @@ -330,6 +333,9 @@ tEnvironment :: Type a Environment tEnvironment = Const Environment +tTerm :: Type a Term +tTerm = Const Term + tDifficulty :: Type a Difficulty tDifficulty = Tag "Difficulty" (Iso (f <-> show) tString) where @@ -338,8 +344,8 @@ tUserId :: Type a String tUserId = Tag "UserId" tString -tStdGen :: Type a StdGen -tStdGen = Const StdGen +tQCGen :: Type a QCGen +tQCGen = Const QCGen tExamples :: Type a (Examples (Context a)) tExamples = tList (tPair tDifficulty tContext) diff --git a/src/Ideas/Text/HTML.hs b/src/Ideas/Text/HTML.hs --- a/src/Ideas/Text/HTML.hs +++ b/src/Ideas/Text/HTML.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- See http://www.w3.org/TR/html4/ -- ----------------------------------------------------------------------------- --- $Id: HTML.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.HTML ( HTMLPage, HTMLBuilder diff --git a/src/Ideas/Text/JSON.hs b/src/Ideas/Text/JSON.hs --- a/src/Ideas/Text/JSON.hs +++ b/src/Ideas/Text/JSON.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- JSON. JSON is a lightweight alternative for XML. -- ----------------------------------------------------------------------------- --- $Id: JSON.hs 8743 2015-10-14 19:48:13Z bastiaan $ module Ideas.Text.JSON ( JSON(..), Key, Number(..) -- types @@ -28,8 +27,7 @@ import Data.List (intersperse) import Data.Maybe import Ideas.Text.Parsing hiding (string, char) -import Prelude hiding (catch) -import System.IO.Error hiding (catch) +import System.IO.Error import Test.QuickCheck import Text.PrettyPrint.Leijen hiding ((<$>)) import qualified Ideas.Text.UTF8 as UTF8 diff --git a/src/Ideas/Text/OpenMath/FMP.hs b/src/Ideas/Text/OpenMath/FMP.hs --- a/src/Ideas/Text/OpenMath/FMP.hs +++ b/src/Ideas/Text/OpenMath/FMP.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Formal mathematical properties (FMP) -- ----------------------------------------------------------------------------- --- $Id: FMP.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.OpenMath.FMP where diff --git a/src/Ideas/Text/OpenMath/Object.hs b/src/Ideas/Text/OpenMath/Object.hs --- a/src/Ideas/Text/OpenMath/Object.hs +++ b/src/Ideas/Text/OpenMath/Object.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -10,7 +10,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Object.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.OpenMath.Object ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml diff --git a/src/Ideas/Text/OpenMath/Symbol.hs b/src/Ideas/Text/OpenMath/Symbol.hs --- a/src/Ideas/Text/OpenMath/Symbol.hs +++ b/src/Ideas/Text/OpenMath/Symbol.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Symbol.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.OpenMath.Symbol where diff --git a/src/Ideas/Text/OpenMath/Tests.hs b/src/Ideas/Text/OpenMath/Tests.hs --- a/src/Ideas/Text/OpenMath/Tests.hs +++ b/src/Ideas/Text/OpenMath/Tests.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -9,7 +9,6 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- --- $Id: Tests.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.OpenMath.Tests (propEncoding) where diff --git a/src/Ideas/Text/Parsing.hs b/src/Ideas/Text/Parsing.hs --- a/src/Ideas/Text/Parsing.hs +++ b/src/Ideas/Text/Parsing.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Utility functions for parsing with Parsec library -- ----------------------------------------------------------------------------- --- $Id: Parsing.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.Parsing ( module Export diff --git a/src/Ideas/Text/UTF8.hs b/src/Ideas/Text/UTF8.hs --- a/src/Ideas/Text/UTF8.hs +++ b/src/Ideas/Text/UTF8.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Support for the UTF8 encoding -- ----------------------------------------------------------------------------- --- $Id: UTF8.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.UTF8 ( encode, encodeM, decode, decodeM diff --git a/src/Ideas/Text/XML.hs b/src/Ideas/Text/XML.hs --- a/src/Ideas/Text/XML.hs +++ b/src/Ideas/Text/XML.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -12,7 +12,6 @@ -- functions defined elsewhere. -- ----------------------------------------------------------------------------- --- $Id: XML.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.XML ( XML, Attr, AttrList, Element(..), InXML(..) diff --git a/src/Ideas/Text/XML/Document.hs b/src/Ideas/Text/XML/Document.hs --- a/src/Ideas/Text/XML/Document.hs +++ b/src/Ideas/Text/XML/Document.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Datatype for representing XML documents -- ----------------------------------------------------------------------------- --- $Id: Document.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.XML.Document ( Name, Attributes, Attribute(..), Reference(..), Parameter(..) @@ -21,6 +20,8 @@ , Conditional(..), TextDecl, External , prettyXML, prettyElement ) where + +import Prelude hiding ((<$>)) import Text.PrettyPrint.Leijen diff --git a/src/Ideas/Text/XML/Interface.hs b/src/Ideas/Text/XML/Interface.hs --- a/src/Ideas/Text/XML/Interface.hs +++ b/src/Ideas/Text/XML/Interface.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Collection of common operation on XML documents -- ----------------------------------------------------------------------------- --- $Id: Interface.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.XML.Interface ( Element(..), Content, Attribute(..), Attributes diff --git a/src/Ideas/Text/XML/Parser.hs b/src/Ideas/Text/XML/Parser.hs --- a/src/Ideas/Text/XML/Parser.hs +++ b/src/Ideas/Text/XML/Parser.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -13,7 +14,6 @@ -- http://www.w3.org/TR/2006/REC-xml-20060816 -- ----------------------------------------------------------------------------- --- $Id: Parser.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.XML.Parser (document, extParsedEnt, extSubset) where diff --git a/src/Ideas/Text/XML/Unicode.hs b/src/Ideas/Text/XML/Unicode.hs --- a/src/Ideas/Text/XML/Unicode.hs +++ b/src/Ideas/Text/XML/Unicode.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2015, Ideas project team. This file is distributed under the +-- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,6 @@ -- Support for Unicode -- ----------------------------------------------------------------------------- --- $Id: Unicode.hs 8740 2015-10-14 19:26:22Z bastiaan $ module Ideas.Text.XML.Unicode ( isExtender, isLetter, isDigit, isCombiningChar diff --git a/src/Network/CGI.hs b/src/Network/CGI.hs deleted file mode 100644 --- a/src/Network/CGI.hs +++ /dev/null @@ -1,634 +0,0 @@ -{-# 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 --- Stability : experimental --- Portability : non-portable (uses Control.Monad.State) --- --- Simple Library for writing CGI programs. --- See 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 --- --- Based on the original Haskell binding for CGI: --- --- Original Version by Erik Meijer . --- Further hacked on by Sven Panne . --- Further hacking by Andy Gill . --- A new, hopefully more flexible, interface --- and support for file uploads by Bjorn Bringert . --- --- 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 System.IO (stdin, stdout) -import qualified Data.Map as Map - -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) diff --git a/src/Network/CGI/Accept.hs b/src/Network/CGI/Accept.hs deleted file mode 100644 --- a/src/Network/CGI/Accept.hs +++ /dev/null @@ -1,173 +0,0 @@ -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 "") ts] (parseM parseHeaderValue "" 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 "*" diff --git a/src/Network/CGI/Compat.hs b/src/Network/CGI/Compat.hs deleted file mode 100644 --- a/src/Network/CGI/Compat.hs +++ /dev/null @@ -1,112 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 --- 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" ++ - "" ++ msg ++ "") - throw e - -sendBack :: Handle -> IO () -sendBack h = do s <- hGetLine h - putStrLn s - sendBack h diff --git a/src/Network/CGI/Cookie.hs b/src/Network/CGI/Cookie.hs deleted file mode 100644 --- a/src/Network/CGI/Cookie.hs +++ /dev/null @@ -1,154 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Cookie --- Copyright : (c) Bjorn Bringert 2004-2005 --- (c) Ian Lynagh 2005 --- License : BSD-style --- --- Maintainer : John Chee --- Stability : experimental --- Portability : portable --- --- General server side HTTP cookie library. --- Based on --- --- TODO --- --- * Add client side stuff (basically parsing Set-Cookie: value) --- --- * Update for RFC2109 --- ------------------------------------------------------------------------------ -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) diff --git a/src/Network/CGI/Monad.hs b/src/Network/CGI/Monad.hs deleted file mode 100644 --- a/src/Network/CGI/Monad.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Monad --- Copyright : (c) Bjorn Bringert 2006 --- License : BSD-style --- --- Maintainer : John Chee --- 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 diff --git a/src/Network/CGI/Protocol.hs b/src/Network/CGI/Protocol.hs deleted file mode 100644 --- a/src/Network/CGI/Protocol.hs +++ /dev/null @@ -1,313 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.CGI.Protocol --- Copyright : (c) Bjorn Bringert 2006 --- License : BSD-style --- --- Maintainer : John Chee --- 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 - deriving (Show, Read, Eq, Ord) - --- --- * 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